7-GUIS port task 6
This commit is contained in:
parent
cdca416d21
commit
a259153470
|
@ -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)))
|
||||
)
|
|
@ -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))
|
||||
|
||||
|
|
Loading…
Reference in New Issue