syndicate-lang
/
syndicate-2017
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

7-GUIS port task 6

This commit is contained in:
Sam Caldwell 2019-07-15 14:24:58 -04:00
parent cdca416d21
commit a259153470
2 changed files with 261 additions and 7 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

206
racket/syndicate-gui-toolbox/examples/7-GUIS/task-6.rkt Normal file
View File

@ -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)))
)

62
racket/syndicate-gui-toolbox/widgets.rkt
View File

@ -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))