From a2591534700e5cd1c8253fa7d71d70b292e69b96 Mon Sep 17 00:00:00 2001
From: Sam Caldwell <samc@ccs.neu.edu>
Date: Mon, 15 Jul 2019 14:24:58 -0400
Subject: [PATCH] 7-GUIS port task 6

---
 .../examples/7-GUIS/task-6.rkt                | 206 ++++++++++++++++++
 racket/syndicate-gui-toolbox/widgets.rkt      |  62 +++++-
 2 files changed, 261 insertions(+), 7 deletions(-)
 create mode 100644 racket/syndicate-gui-toolbox/examples/7-GUIS/task-6.rkt

diff --git a/racket/syndicate-gui-toolbox/examples/7-GUIS/task-6.rkt b/racket/syndicate-gui-toolbox/examples/7-GUIS/task-6.rkt
new file mode 100644
index 0000000..52a61ee
--- /dev/null
+++ b/racket/syndicate-gui-toolbox/examples/7-GUIS/task-6.rkt
@@ -0,0 +1,206 @@
+#lang syndicate
+
+(require "../../widgets.rkt")
+(require racket/list
+         racket/gui/base
+         (except-in racket/class field))
+
+;; a circle drawer with undo/redo facilities (unclear spec for resizing)
+
+(message-struct circle-canvas-event (type x y))
+(message-struct resize (circ d))
+(message-struct draw-circles (closest others))
+
+;; ---------------------------------------------------------------------------------------------------
+(define Default-Diameter 20)
+
+(struct circle (x y d action) #:transparent)
+
+(define (draw-1-circle dc brush c)
+  (match-define (circle x y d _a) c)
+  (send dc set-brush brush)
+  (define r (/ d 2))
+  (send dc draw-ellipse (- x r) (- y r) d d))
+
+
+;; N N (Circle -> Real]
+(define ((distance xm ym) c)
+  (match-define (circle xc yc _d _a) c)
+  (sqrt (+ (expt (- xc xm) 2) (expt (- yc ym) 2))))
+
+;; ---------------------------------------------------------------------------------------------------
+(define solid-gray  (new brush% [color "gray"]))
+(define white-brush (new brush% [color "white"]))
+
+(define circle-canvas%
+  (class canvas%
+    (inherit on-paint get-dc)
+
+    (define/override (on-event evt)
+      (define type (send evt get-event-type))
+      (define x (send evt get-x))
+      (define y (send evt get-y))
+      (send-ground-message (circle-canvas-event type x y)))
+
+    (define (paint-callback _self _evt)
+      (draw-circles *last-closest *last-others))
+
+    (define *last-closest #f)
+    (define *last-others #f)
+
+    (define/public (draw-circles closest (others-without-closest #f))
+      (set! *last-closest closest)
+      (set! *last-others others-without-closest)
+      (define dc (get-dc))
+      (send dc clear)
+      (when others-without-closest
+        (for ((c others-without-closest)) (draw-1-circle dc white-brush c)))
+      (when closest (draw-1-circle dc solid-gray closest)))
+
+    (super-new [paint-callback paint-callback])))
+
+(define (spawn-circle-canvas parent frame undo-but redo-but)
+  (define cc (new circle-canvas% [parent (seal-contents parent)][style '(border)]))
+
+  (spawn
+   (field [*circles '()]
+          [*history '()]
+          [*x 0]
+          [*y 0]
+          [*in-adjuster #f])
+
+   (define (add-circle! x y)
+     (define added (circle x y Default-Diameter 'added))
+     (*circles (cons added (*circles))))
+
+   (define (resize! old-closest new-d)
+     (match-define (circle x y d a) old-closest)
+     (define resized
+       (match a
+         ['added (circle x y new-d `(resized (,d)))]
+         [`(resized . ,old-sizes) (circle x y new-d `(resized ,(cons d old-sizes)))]))
+     (*circles (cons resized (remq old-closest (*circles)))))
+
+   (define (undo)
+     (when (cons? (*circles))
+       (define fst (first (*circles)))
+       (match fst
+         [(circle x y d 'added) (*circles (rest (*circles)))]
+         [(circle x y d `(resized (,r0 . ,sizes)))
+          (*circles (cons (circle x y r0 `(resized (,d))) (rest (*circles))))])
+       (*history (cons fst (*history)))))
+
+   (define (redo)
+     (when (cons? (*history))
+       (define fst (first (*history)))
+       (if (eq? (circle-action fst) 'added)
+           (begin (*circles (cons fst (*circles))) (*history (rest (*history))))
+           (begin (*circles (cons fst (rest (*circles)))) (*history (rest (*history)))))))
+
+   (define (the-closest xm ym (circles (*circles)))
+     (define cdistance (distance xm ym))
+     (define-values (good-circles distance*)
+       (for*/fold ([good-circles '()][distance* '()])
+                  ((c circles) (d (in-value (cdistance c))) #:when (< d (/ (circle-d c) 2)))
+         (values (cons c good-circles) (cons d distance*))))
+     (and (cons? distance*) (first (argmin second (map list good-circles distance*)))))
+
+   (define (is-empty-area xm ym (circles (*circles)))
+     (define dist (distance xm ym))
+     (for/and ((c circles)) (> (dist c) (/ (+ (circle-d c) Default-Diameter) 2))))
+
+   (on (message 'unlock-canvas) (*in-adjuster #f))
+   (on (message 'lock-canvas) (*in-adjuster #t))
+
+   ;; no closest
+   (define (draw!)
+     (send cc draw-circles #f (*circles)))
+
+   (on (message (resize $old-closest $new-d))
+       (resize! old-closest new-d)
+       (draw!))
+
+   (on (message (draw-circles $close $others))
+       (send cc draw-circles close others))
+
+   (on (message (button-press undo-but))
+       (undo)
+       (draw!))
+
+   (on (message (button-press redo-but))
+       (redo)
+       (draw!))
+
+   (on (message (inbound (circle-canvas-event $type $x $y)))
+       (unless (*in-adjuster)
+         (*x x)
+         (*y y)
+         (cond
+           [(eq? 'leave type) (*x #f)]
+           [(eq? 'enter type) (*x 0)]
+           [(and (eq? 'left-down type) (is-empty-area (*x) (*y)))
+            (add-circle! (*x) (*y))
+            (draw!)]
+           [(and (eq? 'right-down type) (the-closest (*x) (*y)))
+            => (λ (tc)
+                 (*in-adjuster #t)
+                 (popup-adjuster tc *circles frame)
+                 (send cc draw-circles tc (*circles)))])))
+   ))
+
+(define (popup-adjuster closest-circle *circles frame)
+  (define pid (gensym 'popup))
+  (send! (popup-menu frame pid "adjuster" 100 100 (list "adjust radius")))
+  (react (stop-when (message (no-popdown-selected pid)) (send! 'unlock-canvas))
+         (stop-when (message (popdown-item-selected pid _)) (adjuster! closest-circle *circles))))
+
+(define (adjuster! closest-circle *circles)
+  (define d0 (circle-d closest-circle))
+  (define frame (spawn-adjuster-dialog closest-circle (remq closest-circle (*circles))))
+  (spawn-adjuster-slider #:parent frame #:init-value d0))
+
+(define adjuster-dialog%
+  (class frame% (init-field closest-circle)
+    (match-define (circle x* y* _d _a) closest-circle)
+
+    (define/augment (on-close)
+      (send-ground-message 'adjuster-closed))
+
+    (super-new [label (format "Adjust radius of circle at (~a,~a)" x* y*)])))
+
+(define (spawn-adjuster-dialog closest-circle others)
+  (match-define (circle x* y* old-d _a) closest-circle)
+  (define dialog
+    (parameterize ((current-eventspace (make-eventspace)))
+      (new adjuster-dialog% [closest-circle closest-circle])))
+  (send dialog show #t)
+  (spawn
+   ;; well, there's only one slider
+   (define/query-value *d old-d (slider@ _ $v) v)
+   (on (message (slider-update _ $v))
+       ;; resize locally while adjusting
+       (send! (draw-circles (circle x* y* (*d) '_dummy_) others)))
+   (on (message (inbound 'adjuster-closed))
+       ;; resize globally
+       (send! 'unlock-canvas)
+       (send! (resize closest-circle (*d)))
+       (stop-current-facet)))
+  (seal dialog))
+
+
+(define (spawn-adjuster-slider #:parent parent
+                               #:init-value init-value)
+  (spawn-slider #:parent parent #:label "" #:min-value 10 #:max-value 100 #:init-value init-value))
+
+;; ---------------------------------------------------------------------------------------------------
+(spawn
+(define frame  (spawn-frame #:label "Circle Drawer" #:width 400))
+(define hpane1 (spawn-horizontal-pane #:parent frame #:min-height 20 #:alignment '(center center)))
+(define undo-but (spawn-button #:label "Undo" #:parent hpane1))
+(define redo-but (spawn-button #:label "Redo" #:parent hpane1))
+(define hpane2 (spawn-horizontal-panel #:parent frame #:min-height 400 #:alignment '(center center)))
+(define canvas (spawn-circle-canvas hpane2 frame undo-but redo-but))
+
+(on (asserted (frame@ frame))
+    (send! (show-frame frame #t)))
+)
diff --git a/racket/syndicate-gui-toolbox/widgets.rkt b/racket/syndicate-gui-toolbox/widgets.rkt
index 257be50..fc44717 100644
--- a/racket/syndicate-gui-toolbox/widgets.rkt
+++ b/racket/syndicate-gui-toolbox/widgets.rkt
@@ -2,6 +2,7 @@
 
 (provide spawn-frame
          spawn-horizontal-pane
+         spawn-horizontal-panel
          spawn-vertical-pane
          spawn-text-field
          spawn-button
@@ -12,6 +13,7 @@
          (struct-out frame@)
          (struct-out show-frame)
          (struct-out horizontal-pane@)
+         (struct-out horizontal-panel@)
          (struct-out vertical-pane@)
          (struct-out text-field@)
          (struct-out set-text-field)
@@ -29,7 +31,10 @@
          (struct-out slider-update)
          (struct-out list-box@)
          (struct-out list-box-selection)
-         (struct-out set-list-box-choices))
+         (struct-out set-list-box-choices)
+         (struct-out popup-menu)
+         (struct-out no-popdown-selected)
+         (struct-out popdown-item-selected))
 
 (require (only-in racket/class
                   new
@@ -44,9 +49,13 @@
 
 (assertion-struct frame@ (id))
 (message-struct show-frame (id value))
+(message-struct popup-menu (parent-id id title x y items))
+(message-struct no-popdown-selected (id))
+(message-struct popdown-item-selected (id item))
 
 (assertion-struct horizontal-pane@ (id))
 (assertion-struct vertical-pane@ (id))
+(assertion-struct horizontal-panel@ (id))
 
 (assertion-struct text-field@ (id value))
 (message-struct set-text-field (id value))
@@ -75,25 +84,44 @@
       (send self enable val)))
 
 ;; String -> ID
-(define (spawn-frame #:label label)
+(define (spawn-frame #:label label
+                     #:width [width #f])
   (define frame
     (parameterize ((current-eventspace (make-eventspace)))
-      (new frame% [label label])))
+      (new frame%
+           [label label]
+           [width width])))
   (define id (seal frame))
+
+  (define ((on-popdown! pid) self evt)
+    (when (eq? (send evt get-event-type) 'menu-popdown-none)
+      (send-ground-message (no-popdown-selected pid))))
+  (define ((popdown-item! pid i) . _x)
+    (send-ground-message (popdown-item-selected pid i)))
+
   (spawn
    (assert (frame@ id))
    (on (message (show-frame id $val))
-       (send frame show val)))
+       (send frame show val))
+   (on (message (popup-menu id $pid $title $x $y $items))
+       (define pm (new popup-menu% [title title] [popdown-callback (on-popdown! pid)]))
+       (for ([i (in-list items)])
+         (new menu-item% [parent pm] [label i] [callback (popdown-item! pid i)]))
+       (send frame popup-menu pm x y)
+       (react (stop-when (message (inbound (no-popdown-selected pid))) (send! (no-popdown-selected pid)))
+              (stop-when (message (inbound (popdown-item-selected pid $i))) (send! (popdown-item-selected pid i))))))
   id)
 
-;; ID -> ID
+;; ID ... -> ID
 (define (spawn-horizontal-pane #:parent parent
                                #:border [border 0]
+                               #:min-height [min-height #f]
                                #:alignment [alignment '(left center)])
   (define parent-component (seal-contents parent))
   (define pane (new horizontal-pane%
                     [parent parent-component]
                     [border border]
+                    [min-height min-height]
                     [alignment alignment]))
   (define id (seal pane))
 
@@ -102,6 +130,24 @@
 
   id)
 
+;; ID ... -> ID
+(define (spawn-horizontal-panel #:parent parent
+                                #:border [border 0]
+                                #:min-height [min-height #f]
+                                #:alignment [alignment '(left center)])
+  (define parent-component (seal-contents parent))
+  (define panel (new horizontal-panel%
+                     [parent parent-component]
+                     [border border]
+                     [min-height min-height]
+                     [alignment alignment]))
+  (define id (seal panel))
+
+  (spawn
+   (assert (horizontal-panel@ id)))
+
+  id)
+
 ;; ID Alignment -> ID
 (define (spawn-vertical-pane #:parent parent
                              #:alignment [alignment '(center top)])
@@ -224,8 +270,9 @@
 ;; ID String Nat Nat -> ID
 (define (spawn-slider #:parent parent
                       #:label label
-                      #:min-value [min-value 0]
-                      #:max-value [max-value 100])
+                      #:min-value min-value
+                      #:max-value max-value
+                      #:init-value [init-value min-value])
   (define (inject-slider-event! self evt)
     (send-ground-message (slider-update id (get))))
 
@@ -235,6 +282,7 @@
                  [label label]
                  [min-value min-value]
                  [max-value max-value]
+                 [init-value init-value]
                  [callback inject-slider-event!]))
   (define id (seal s))