├── .gitignore ├── PrimitiveMVC ├── README.md └── task-1.rkt ├── Typed ├── gregor.rkt ├── task-7-view.rkt ├── from-string.rkt ├── task-1.rkt ├── task-7-exp.rkt ├── canvas-double-click.rkt ├── sub-canvas.rkt ├── sub-frame.rkt ├── task-4.rkt ├── task-2.rkt ├── task-3.rkt ├── sub.rkt ├── task-5.rkt ├── task-7.rkt ├── task-6.rkt └── README.md ├── LICENCE.md ├── Macros ├── task-1.rkt ├── task-2.rkt ├── task-4.rkt ├── task-3.rkt ├── 7state.rkt ├── task-5.rkt ├── README.md ├── task-7.rkt ├── 7guis.rkt └── task-6.rkt ├── info.rkt ├── task-1.rkt ├── UnitMVC ├── README.md └── task-1.rkt ├── should-be-racket.rkt ├── canvas-double-click.rkt ├── task-4.rkt ├── task-2.rkt ├── task-3.rkt ├── task-7-view.rkt ├── task-7-exp.rkt ├── task-5.rkt ├── task-7.rkt ├── README.md └── task-6.rkt /.gitignore: -------------------------------------------------------------------------------- 1 | compiled 2 | -------------------------------------------------------------------------------- /PrimitiveMVC/README.md: -------------------------------------------------------------------------------- 1 | 2 | ### Adding Primitive MVC 3 | 4 | These files add primitive MVC setup to the ones in the home directory. 5 | The idea is to think of the DrRacket REPL as a second Control access 6 | point and to make sure that changes to the model propagate to the view. 7 | 8 | -------------------------------------------------------------------------------- /Typed/gregor.rkt: -------------------------------------------------------------------------------- 1 | #lang typed/racket 2 | 3 | (provide Date parse-date date<=? today) 4 | 5 | (require/typed gregor 6 | [#:opaque Date date?] 7 | [parse-date (-> String String Date)] 8 | [date<=? (-> Date Date Boolean)] 9 | [today (-> Date)]) -------------------------------------------------------------------------------- /LICENCE.md: -------------------------------------------------------------------------------- 1 | This code is licenced under the same terms as Racket: 2 | 3 | > Racket is distributed under the MIT license and the Apache version 2.0 4 | license, at your option. 5 | 6 | https://github.com/racket/racket/blob/master/LICENSE.txt 7 | 8 | 9 | Licencing under the same terms as Racket is required for contributions. 10 | -------------------------------------------------------------------------------- /Macros/task-1.rkt: -------------------------------------------------------------------------------- 1 | #! /usr/bin/env gracket 2 | #lang racket/gui 3 | 4 | (require 7GUI/Macros/7guis 7GUI/Macros/7state) 5 | 6 | (define-state *count 0 (lambda (x) (send display set-value (~a x)))) 7 | 8 | (gui "Counter" 9 | ((#:id display text-field% [label ""][init-value "0"][enabled #f][min-width 100]) 10 | (button% #:change *count (just add1) [label "Count"]))) 11 | -------------------------------------------------------------------------------- /Typed/task-7-view.rkt: -------------------------------------------------------------------------------- 1 | #lang typed/racket/gui 2 | 3 | (provide WIDTH HEIGHT paint-grid xy->A0) 4 | 5 | (require (only-in 7GUI/Typed/task-7-exp Content Ref)) 6 | 7 | (require/typed 7GUI/task-7-view 8 | [WIDTH Natural] 9 | [HEIGHT Natural] 10 | [paint-grid (-> (Instance DC<%>) Content Void)] 11 | [xy->A0 (-> Natural Natural Ref)]) 12 | 13 | 14 | 15 | -------------------------------------------------------------------------------- /Typed/from-string.rkt: -------------------------------------------------------------------------------- 1 | #lang typed/racket 2 | 3 | (provide string->er) 4 | 5 | ;; Racket should have an `exact-rational?` predicate so that it matches Typed Racket's Exact-Rational. 6 | 7 | (: string->er (String -> (U Exact-Rational False))) 8 | ;; convert string to exact rational if needed 9 | (define (string->er s) 10 | (define r (parameterize ([read-decimal-as-inexact #f]) (string->number s))) 11 | (and (rational? r) (exact? r) (ann r Exact-Rational))) -------------------------------------------------------------------------------- /info.rkt: -------------------------------------------------------------------------------- 1 | #lang info 2 | 3 | (define collection "7GUI") 4 | 5 | (define deps 6 | '( 7 | "base" 8 | "racket/gui" 9 | "gui-lib" 10 | "at-exp-lib" 11 | "htdp-lib" 12 | "typed-racket-lib" 13 | "typed-racket-more" 14 | "rackunit-lib" 15 | "gregor" 16 | "rackunit-lib" 17 | )) 18 | 19 | ;; https://github.com/jsmaniac/type-expander 20 | (define pkg-desc "Sources for 7GUI") 21 | 22 | (define pkg-authors '(matthias)) 23 | -------------------------------------------------------------------------------- /task-1.rkt: -------------------------------------------------------------------------------- 1 | #! /usr/bin/env gracket 2 | #lang racket/gui 3 | 4 | ;; a mouse-click counter 5 | 6 | (define *counter 0) 7 | 8 | (define (count! . x) 9 | (set! *counter (if (empty? x) 0 (+ *counter 1))) 10 | (send view set-value (~a *counter))) 11 | 12 | (define frame (new frame% [label "Counter"])) 13 | (define pane (new horizontal-pane% [parent frame])) 14 | (define view (new text-field% [parent pane][label ""][init-value "0"][enabled #f][min-width 100])) 15 | (define _but (new button% [parent pane] [label "Count"] [callback count!])) 16 | 17 | (count!) 18 | (send frame show #t) -------------------------------------------------------------------------------- /Typed/task-1.rkt: -------------------------------------------------------------------------------- 1 | #! /usr/bin/env gracket 2 | #lang typed/racket/gui 3 | 4 | ;; a mouse-click counter 5 | 6 | (define *counter 0) 7 | 8 | (: count! (-> Any * Void)) 9 | (define (count! . x) 10 | (set! *counter (if (empty? x) 0 (+ *counter 1))) 11 | (send view set-value (~a *counter))) 12 | 13 | (define frame (new frame% [label "Counter"])) 14 | (define pane (new horizontal-pane% [parent frame])) 15 | (define view (new text-field% [parent pane][label ""][init-value "0"][enabled #f][min-width 100])) 16 | (define _but (new button% [parent pane] [label "Count"] [callback count!])) 17 | 18 | (count!) 19 | (send frame show #t) 20 | -------------------------------------------------------------------------------- /UnitMVC/README.md: -------------------------------------------------------------------------------- 1 | 2 | ### Adding Primitive MVC 3 | 4 | These files add a unit-based MVC setup to the ones in the home directory. 5 | Each file specifies 6 | 7 | - a signature-based agreement between model and view 8 | - a model unit 9 | - a view unit 10 | - at least one setup for linking the two 11 | 12 | That is, the files set up mutually recursive, statically linked view and 13 | model units. It is thus possible to link any view to the model as long as 14 | it satisfies the signature and vice versa. See 15 | 16 | - task-1.rkt for a demo of how to abstract functionally over a view unit 17 | and generate two distinct views for the counter model 18 | 19 | 20 | -------------------------------------------------------------------------------- /Typed/task-7-exp.rkt: -------------------------------------------------------------------------------- 1 | #lang typed/racket 2 | 3 | (provide Exp Content Ref Letter LETTERS valid-content string->exp* exp*->string depends-on evaluate) 4 | 5 | (define-type Letter Char 6 | #; 7 | (U #\A #\B #\C #\D #\E #\F #\G #\H #\I #\J #\K #\L #\M 8 | #\N #\O #\P #\Q #\R #\S #\T #\U #\V #\W #\X #\Y #\Z)) 9 | 10 | (define-type Ref (List Letter Index)) 11 | (define-type Exp (U Integer Ref (List Symbol Exp Exp))) 12 | (define-type Content (Immutable-HashTable Ref Integer)) 13 | 14 | (require/typed 7GUI/task-7-exp 15 | [LETTERS String] 16 | [valid-content (-> String (U Integer False))] 17 | [string->exp* (-> String Exp)] 18 | [exp*->string (-> Exp String)] 19 | [depends-on (-> Exp (Setof Ref))] 20 | [evaluate (-> Exp Content Integer)]) 21 | -------------------------------------------------------------------------------- /Typed/canvas-double-click.rkt: -------------------------------------------------------------------------------- 1 | #lang typed/racket/gui 2 | 3 | (provide canvas-double-click%) 4 | 5 | (require 7GUI/Typed/sub-canvas) 6 | 7 | (define-type-canvas Canvas-Double-Click% 8 | ;; missing method types from supported Canvas% Class type 9 | (vert-margin (->* () (Integer) Void)) 10 | (horiz-margin (->* () (Integer) Void)) 11 | (get-scaled-client-size (-> (Values Integer Integer))) 12 | (get-gl-client-size (-> (Values Integer Integer))) 13 | 14 | ;; make new methods public: 15 | (on-click Click-Callback) 16 | (on-double-click Click-Callback) 17 | 18 | ;; allow augmentation 19 | [augment (on-click Click-Callback)] 20 | [augment (on-double-click Click-Callback)] 21 | 22 | ;; also allow augmentation for on-event, which is already public 23 | [augment (on-event (-> (Instance Mouse-Event%) Void))]) 24 | 25 | (define-type Click-Callback (-> Natural Natural Void)) 26 | 27 | (require/typed 7GUI/canvas-double-click [canvas-double-click% Canvas-Double-Click%]) 28 | -------------------------------------------------------------------------------- /PrimitiveMVC/task-1.rkt: -------------------------------------------------------------------------------- 1 | #! /usr/bin/env gracket 2 | #lang racket/gui 3 | 4 | ;; a mouse-click counter; use (count!) or (count! 'x) at REPL and thus change the state of the model 5 | 6 | ;; --------------------------------------------------------------------------------------------------- 7 | (define count! ;; depends on on-change-to-model 8 | (let ([*counter 0]) 9 | (λ x 10 | (set! *counter (if (empty? x) 0 (+ *counter 1))) 11 | (on-change-to-model *counter)))) 12 | 13 | ;; --------------------------------------------------------------------------------------------------- 14 | (define frame (new frame% [label "Counter"])) 15 | (define pane (new horizontal-pane% [parent frame])) 16 | (define view (new text-field% [parent pane][label ""][init-value "0"][enabled #f][min-width 100])) 17 | (define _but (new button% [parent pane] [label "Count"] [callback count!])) 18 | 19 | (define (on-change-to-model c) (send view set-value (~a c))) 20 | 21 | ;; --------------------------------------------------------------------------------------------------- 22 | (count!) 23 | (send frame show #t) -------------------------------------------------------------------------------- /Macros/task-2.rkt: -------------------------------------------------------------------------------- 1 | #! /usr/bin/env gracket 2 | #lang racket/gui 3 | 4 | ;; a bi-directional temperature converter (Fahrenheit vs Celsius) 5 | 6 | (require 7GUI/Macros/7guis 7GUI/Macros/7state) 7 | 8 | (define-syntax-rule (propagate-to state f field) 9 | (λ (new-value-of-origin) 10 | (set! state (stop (f new-value-of-origin))) 11 | (send field set-field-background (make-object color% "white")) 12 | (send field set-value (~r state #:precision 4)))) 13 | 14 | (define-state *C 0 (propagate-to *F (λ (c) (+ (* c 9/5) 32)) F-field)) 15 | (define-state *F 32 (propagate-to *C (λ (f) (* (- f 32) 5/9)) C-field)) 16 | 17 | (define (string->number* str) 18 | (define n (string->number str)) 19 | (values n (and n (string-ref str (- (string-length str) 1))))) 20 | 21 | (define flow 22 | (with (values field:num last) #:post string->number* 23 | (send self set-field-background (make-object color% "white")) 24 | (cond 25 | [(and field:num (rational? field:num)) (* #i1.0 field:num)] 26 | [else (send self set-field-background (make-object color% "red")) none]))) 27 | 28 | (define temp-field% (class text-field% (super-new [min-width 200]))) 29 | 30 | (gui "Temperature Converter" 31 | ((#:id F-field temp-field% #:change *F flow [init-value "32"][label "fahrenheit:"]) 32 | (#:id C-field temp-field% #:change *C flow [init-value "0"][label "celsius:"]))) 33 | -------------------------------------------------------------------------------- /should-be-racket.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (provide 4 | => 5 | when* 6 | unless* 7 | and*) 8 | 9 | ;; TODO make them more like the real thing 10 | 11 | ;; --------------------------------------------------------------------------------------------------- 12 | (require syntax/parse/define (for-syntax syntax/parse)) 13 | (module+ test (require rackunit)) 14 | 15 | ;; --------------------------------------------------------------------------------------------------- 16 | (define-syntax => (lambda (stx) (raise-syntax-error '=> "used out of context"))) 17 | 18 | (define-simple-macro 19 | (when* condition:expr (~literal =>) body:expr) 20 | (let ([it condition]) (when it (body it)))) 21 | 22 | (define-simple-macro 23 | (unless* condition:expr (~literal =>) body:expr) 24 | (let ([it condition]) (unless it (body it)))) 25 | 26 | (define-syntax (and* stx) 27 | (syntax-parse stx 28 | [(_) #'(and)] 29 | [(_ e1:expr) #'(and e1)] 30 | [(_ e1:expr (~literal =>) e-next:expr e2:expr ...) 31 | #'(let ([it e1]) (and* it (e-next it) e2 ...))] 32 | [(_ e1:expr e2:expr ...) #'(and e1 (and* e2 ...))])) 33 | 34 | (module+ test 35 | (check-equal? (when* (sin (/ pi 2)) => (λ (it) (- it 1.0))) 0.0) ;; ok ok 36 | (check-equal? (unless* (sin (/ pi 2)) => (λ (it) (- it 1.0))) (void)) 37 | 38 | (check-true (and*)) 39 | (check-true (and* #t)) 40 | (check-true (and* (+ 1 1) => (λ (it) (> 3 it)))) 41 | (check-false (and* (+ 1 1) => (λ (it) (> 3 it)) #f))) 42 | -------------------------------------------------------------------------------- /Macros/task-4.rkt: -------------------------------------------------------------------------------- 1 | #! /usr/bin/env gracket 2 | #lang at-exp racket/gui 3 | 4 | ;; a timer that permits the continuous setting of a new interval, plus 5 | ;; a gauge and a text field that display the fraction of the elapsed time 6 | ;; a reset button that sends the elapsed time back to 0 7 | 8 | (require 7GUI/Macros/7guis 7GUI/Macros/7state) 9 | 10 | (define INTERVAL 100) 11 | 12 | (define (duration-cb . x) 13 | (if (>= *elapsed *duration) 14 | (set! *elapsed *duration) ;; to trigger the *elapsed callback for redraw 15 | (set! *elapsed (+ *elapsed 1)))) 16 | (define timer (new timer% [notify-callback duration-cb])) 17 | 18 | (define (elapsed-cb . x) 19 | (send timer start INTERVAL) 20 | (send text set-value (format "elapsed ~a" *elapsed)) 21 | (define r (if (zero? *duration) 0 (quotient (* 100 *elapsed) *duration))) 22 | (send elapsed set-value r)) 23 | 24 | {define-state *elapsed 0 elapsed-cb} ;; INTERVAL/1000 ms accumulated elapsed time 25 | [define-state *duration 0 duration-cb] ;; INTERVAL/1000 ms set duration interval 26 | (define set-duration (with nu (if (= nu *duration) none [begin (send timer stop) nu]))) 27 | 28 | (gui "Timer" 29 | (#:id elapsed gauge% [label "elapsed"][enabled #f][range 100]) 30 | (#:id text text-field% [init-value "0"][label ""]) 31 | (slider% #:change *duration set-duration [label "duration"][min-value 0][max-value 100]) 32 | (button% #:change *elapsed (just (λ _ (send timer stop) (begin0 0 (duration-cb)))) [label "reset"])) 33 | -------------------------------------------------------------------------------- /Typed/sub-canvas.rkt: -------------------------------------------------------------------------------- 1 | #lang typed/racket/gui 2 | 3 | (provide 4 | ;; SYNTAX 5 | #; (define-type-canvas TypeName% [#:minus-init (init-param:id)] method-spec ...) 6 | #; {method-spec = name+type || (augment . name+type)} 7 | ;; creates a sub-type Class specification for a canvas, 8 | ;; -- subtracting init-paameters as init-param ... from those in Canva% 9 | ;; -- adding method specifications method-spec ... 10 | 11 | define-type-canvas) 12 | 13 | ;; --------------------------------------------------------------------------------------------------- 14 | (require 7GUI/Typed/sub) 15 | 16 | ;; --------------------------------------------------------------------------------------------------- 17 | (define-sub-type define-type-canvas Canvas% 18 | (parent (Instance Area-Container<%>)) 19 | (style Style* #:optional) 20 | (paint-callback (-> (Instance Canvas%) (Instance DC<%>) Any) #:optional) 21 | (label MaybeString #:optional) 22 | (gl-config Any #:optional) 23 | (enabled Any #:optional) 24 | (vert-margin Nonnegative-Integer #:optional) 25 | (horiz-margin Nonnegative-Integer #:optional) 26 | (min-width MaybeN #:optional) 27 | (min-height MaybeN #:optional) 28 | (stretchable-width Any #:optional) 29 | (stretchable-height Any #:optional)) 30 | 31 | (define-type Style 32 | (U 'combo 33 | 'border 'control-border 'gl 'hscroll 'vscroll 'resize-corner 34 | 'deleted 'no-autoclear 'no-focus 35 | 'transparent)) 36 | 37 | (define-type Style* (Listof Style)) -------------------------------------------------------------------------------- /Typed/sub-frame.rkt: -------------------------------------------------------------------------------- 1 | #lang at-exp typed/racket/gui 2 | 3 | (provide define-type-frame) 4 | 5 | ;; --------------------------------------------------------------------------------------------------- 6 | (require 7GUI/Typed/sub) 7 | 8 | ;; --------------------------------------------------------------------------------------------------- 9 | (define-sub-type define-type-frame Frame% 10 | (parent (U (Instance Frame%) False) #:optional) 11 | (label String) 12 | ;; if I bring this line in, I get a weird error message: 13 | #; 14 | (width (U False Natural) #:optional) 15 | ;; Type Checker: type mismatch; 16 | ;; wrong type for init `width' 17 | ;; expected: temp9 18 | ;; given: temp6 19 | (width MaybeInt #:optional) 20 | (height MaybeInt #:optional) 21 | (x MaybeInt #:optional) 22 | (y MaybeInt #:optional) 23 | (style Style* #:optional) 24 | (enabled Any #:optional) 25 | (border Nonnegative-Integer #:optional) 26 | (spacing Nonnegative-Integer #:optional) 27 | (alignment Alignment #:optional) 28 | (min-width MaybeN #:optional) 29 | (min-height MaybeN #:optional) 30 | (stretchable-width Any #:optional) 31 | (stretchable-height Any #:optional)) 32 | 33 | (define-type Alignment (List (U 'center 'left 'right) (U 'bottom 'center 'top))) 34 | 35 | (define-type Style 36 | (U 'float 'toolbar-button 'fullscreen-aux 'fullscreen-button 'hide-menu-bar 37 | 'metal 'no-caption 'no-resize-border 'no-system-menu)) 38 | 39 | (define-type Style* (Listof Style)) -------------------------------------------------------------------------------- /canvas-double-click.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/gui 2 | 3 | (provide 4 | ;; a class extension for canvas$ that deals with single- and double-clicks 5 | ;; augment on-click and on-double-click to add the respective functionality 6 | ;; each calls on-paint afterwards 7 | 8 | canvas-double-click%) 9 | 10 | (require 7GUI/Macros/7state) ;; it improves readability 11 | 12 | (define DOUBLE-CLICK-INTERVAL (send (new keymap%) get-double-click-interval)) 13 | 14 | (define canvas-double-click% 15 | (class canvas% 16 | 17 | (inherit on-paint) 18 | 19 | (define/pubment (on-click x y) 20 | (inner (void) on-click x y) 21 | (on-paint)) 22 | 23 | (define/pubment (on-double-click x y) 24 | (inner (void) on-double-click x y) 25 | (on-paint)) 26 | 27 | (define-state *single-click? #f 28 | (λ (pdc) (if pdc (send timer start DOUBLE-CLICK-INTERVAL) (send timer stop)))) 29 | 30 | (define *evt 0) 31 | (define (call f) (f (send *evt get-x) (send *evt get-y))) 32 | 33 | (define (timer-cb) 34 | (when *single-click? (call (λ x (on-click . x)))) 35 | (set! *single-click? #f)) 36 | (define timer (new timer% [notify-callback timer-cb])) 37 | 38 | (define/overment (on-event evt) 39 | (cond 40 | [(eq? (send evt get-event-type) 'left-down) 41 | (set! *evt evt) 42 | (set! *single-click? (not *single-click?)) 43 | (unless *single-click? (call (λ x (on-double-click . x))))] 44 | [else (inner (void) on-event evt)])) 45 | 46 | (super-new))) 47 | -------------------------------------------------------------------------------- /task-4.rkt: -------------------------------------------------------------------------------- 1 | #! /usr/bin/env gracket 2 | #lang at-exp racket/gui 3 | 4 | ;; a timer that permits the continuous setting of a new interval, plus 5 | ;; a gauge and a text field that display the fraction of the elapsed time 6 | ;; a reset button that sends the elapsed time back to 0 7 | 8 | (define INTERVAL 100) 9 | 10 | (define *elapsed 0) ;; INTERVAL/1000 ms accumulated elapsed time 11 | (define *duration 0) ;; INTERVAL/1000 ms set duration interval 12 | 13 | (define (timer-cb) 14 | (unless (>= *elapsed *duration) 15 | (set! *elapsed (+ *elapsed 1)) 16 | (send timer start INTERVAL) 17 | (elapsed-cb))) 18 | (define timer (new timer% [notify-callback timer-cb])) 19 | 20 | (define (elapsed-cb) 21 | (send text set-value (format "elapsed ~a" *elapsed)) 22 | (unless (zero? *duration) 23 | (define r (quotient (* 100 *elapsed) *duration)) 24 | (send elapsed set-value r))) 25 | 26 | (define (reset-cb . x) 27 | (send timer stop) 28 | (set! *elapsed 0) 29 | (timer-cb)) 30 | 31 | (define (duration-cb self _evt) 32 | (define new-duration (send self get-value)) 33 | (unless (= new-duration *duration) 34 | (send timer stop) 35 | (set! *duration new-duration) 36 | (timer-cb))) 37 | 38 | (define frame (new frame% [label "timer"])) 39 | (define elapsed (new gauge% [label "elapsed"][parent frame][enabled #f][range 100])) 40 | (define text (new text-field% [parent frame][init-value "0"][label ""])) 41 | (new slider% [label "duration"][parent frame][min-value 0][max-value 100][callback duration-cb]) 42 | (new button% [label "reset"][parent frame][callback reset-cb]) 43 | 44 | (elapsed-cb) 45 | (send frame show #t) -------------------------------------------------------------------------------- /task-2.rkt: -------------------------------------------------------------------------------- 1 | #! /usr/bin/env gracket 2 | #lang racket/gui 3 | 4 | ;; a bi-directional temperature converter (Fahrenheit vs Celsius) 5 | 6 | (define *C 0) 7 | (define *F 0) 8 | 9 | (define ((callback setter) field _evt) 10 | (define-values (field:num last) (string->number* (send field get-value))) 11 | (cond 12 | [(and field:num (rational? field:num)) 13 | (define inexact-n (* #i1.0 field:num)) 14 | (setter inexact-n) 15 | (render field inexact-n last)] 16 | [else (send field set-field-background (make-object color% "red"))])) 17 | 18 | (define (string->number* str) 19 | (define n (string->number str)) 20 | (values n (and n (string-ref str (- (string-length str) 1))))) 21 | 22 | (define-syntax-rule (flow *from --> *to to-field) 23 | (λ (x) 24 | (set!-values (*from *to) (values x (--> x))) 25 | (render to-field *to ""))) 26 | 27 | (define (render to-field *to last) 28 | (send to-field set-field-background (make-object color% "white")) 29 | (send to-field set-value (~a (~r *to #:precision 4) (if (eq? #\. last) "." "")))) 30 | 31 | (define celsius->fahrenheit (callback (flow *C (λ (c) (+ (* c 9/5) 32)) *F F-field))) 32 | (define fahrenheit->celsius (callback (flow *F (λ (f) (* (- f 32) 5/9)) *C C-field))) 33 | 34 | (define frame (new frame% [label "temperature converter"])) 35 | (define pane (new horizontal-pane% [parent frame])) 36 | (define (field v0 lbl cb) 37 | (new text-field% [parent pane][min-width 199][label lbl][init-value v0][callback cb])) 38 | (define C-field (field "0" "celsius:" celsius->fahrenheit)) 39 | (define F-field (field "0" " = fahrenheit:" fahrenheit->celsius)) 40 | 41 | (celsius->fahrenheit C-field 'start-me-up) 42 | (send frame show #t) 43 | -------------------------------------------------------------------------------- /Typed/task-4.rkt: -------------------------------------------------------------------------------- 1 | #! /usr/bin/env gracket 2 | #lang typed/racket/gui 3 | 4 | ;; a timer that permits the continuous setting of a new interval, plus 5 | ;; a gauge and a text field that display the fraction of the elapsed time 6 | ;; a reset button that sends the elapsed time back to 0 7 | 8 | (define INTERVAL 100) 9 | 10 | (define *elapsed 0) ;; INTERVAL/1000 ms accumulated elapsed time 11 | (define *duration 0) ;; INTERVAL/1000 ms set duration interval 12 | 13 | (define (timer-cb) 14 | (unless (>= *elapsed *duration) 15 | (set! *elapsed (+ *elapsed 1)) 16 | (send timer start INTERVAL) 17 | (elapsed-cb))) 18 | (define timer : (Instance Timer%) (new timer% [notify-callback timer-cb])) 19 | 20 | (: elapsed-cb (-> Void)) 21 | (define (elapsed-cb) 22 | (send text set-value (format "elapsed ~a" *elapsed)) 23 | (unless (zero? *duration) 24 | (define r (quotient (* 100 *elapsed) *duration)) 25 | (send elapsed set-value r))) 26 | 27 | (: reset-cb (-> Any Any Void)) 28 | (define (reset-cb _self _evt) 29 | (send timer stop) 30 | (set! *elapsed 0) 31 | (timer-cb)) 32 | 33 | (: duration-cb (-> (Instance Slider%) Any Void)) 34 | (define (duration-cb self _evt) 35 | (define new-duration (send self get-value)) 36 | (unless (= new-duration *duration) 37 | (send timer stop) 38 | (set! *duration new-duration) 39 | (timer-cb))) 40 | 41 | (define frame (new frame% [label "timer"])) 42 | (define elapsed (new gauge% [label "elapsed"][parent frame][enabled #f][range 100])) 43 | (define text (new text-field% [parent frame][init-value "0"][label ""])) 44 | (new slider% [label "duration"][parent frame][min-value 0][max-value 100][callback duration-cb]) 45 | (new button% [label "reset"][parent frame][callback reset-cb]) 46 | 47 | (elapsed-cb) 48 | (send frame show #t) -------------------------------------------------------------------------------- /Macros/task-3.rkt: -------------------------------------------------------------------------------- 1 | #! /usr/bin/env gracket 2 | #lang racket/gui 3 | 4 | ;; a flight booker that allows a choice between one-way and return bookings 5 | ;; and, depending on the choice, a start date or a start date and an end date. 6 | 7 | ;; --------------------------------------------------------------------------------------------------- 8 | (require 7GUI/Macros/7guis 7GUI/Macros/7state) 9 | (require gregor) 10 | 11 | ;; gregor should not raise an exception when parsing fails, but return #f 12 | (define (to-date d) (with-handlers ([exn? (λ (_) #f)]) (parse-date d "d.M.y"))) 13 | 14 | ;; --------------------------------------------------------------------------------------------------- 15 | (define DATE0 "27.03.2014") 16 | (define ONE "one-way flight") 17 | (define RETURN "return flight") 18 | (define CHOICES `(,ONE ,RETURN)) 19 | (define RED (make-object color% "red")) 20 | (define WHITE (make-object color% "white")) 21 | 22 | (define (enable-book . _) 23 | (send book enable #f) 24 | (when (and *start:date (date<=? (today) *start:date) 25 | (or (and (string=? ONE *kind)) 26 | (and *return:date (date<=? *start:date *return:date)))) 27 | (send book enable #t))) 28 | 29 | (define-state *kind ONE (λ (kf) (send return-date enable (string=? RETURN kf)) (enable-book))) 30 | (define-state *start:date (to-date DATE0) enable-book) 31 | (define-state *return:date (to-date DATE0) enable-book) 32 | 33 | (define date-field% (class text-field% (init e) (super-new [label ""][init-value DATE0][enabled e]))) 34 | 35 | (define check-date 36 | (with date #:post to-date 37 | (cond 38 | [date (send self set-field-background WHITE) date] 39 | [else (send self set-field-background RED) (send book enable #f) none]))) 40 | 41 | (define set-kind (with x #:post (curry list-ref CHOICES) #:method get-selection x)) 42 | 43 | (gui "Flight Booker" 44 | (choice% #:change *kind set-kind [label ""][choices CHOICES]) 45 | (date-field% #:change *start:date check-date (e #t)) 46 | (#:id return-date date-field% #:change *return:date check-date (e #f)) 47 | (#:id book button% [label "Book"][enabled #f][callback (λ _ (displayln "confirmed"))])) 48 | -------------------------------------------------------------------------------- /UnitMVC/task-1.rkt: -------------------------------------------------------------------------------- 1 | #! /usr/bin/env gracket 2 | #lang racket/gui 3 | 4 | ;; a mouse-click counter 5 | 6 | ;; --------------------------------------------------------------------------------------------------- 7 | ;; the agreement between model and view 8 | 9 | (define-signature count^ (count!)) 10 | (define-signature run^ (run on-change-to-model)) 11 | 12 | ;; --------------------------------------------------------------------------------------------------- 13 | ;; the model 14 | 15 | (define count@ 16 | (unit 17 | (import run^) 18 | (export count^) 19 | [define *counter 0] 20 | (define (count! . _) 21 | (set! *counter (+ *counter 1)) 22 | (on-change-to-model *counter)))) 23 | 24 | ;; --------------------------------------------------------------------------------------------------- 25 | ;; a function for generating two views 26 | 27 | (define (view@ R) 28 | (unit 29 | (import count^) 30 | (export run^) 31 | (init-depend count^) 32 | 33 | (define f (new frame% [label "Counter"])) 34 | (define p (new horizontal-pane% [parent f])) 35 | (define v (new text-field% [parent p][label ""][init-value (R 0)][enabled #f][min-width 99])) 36 | (define _ (new button% [parent p] [label "Count"] [callback count!])) 37 | 38 | (define (on-change-to-model c) (send v set-value (R c))) 39 | (define (run) (send f show #t)))) 40 | 41 | ;; --------------------------------------------------------------------------------------------------- 42 | ;; a function for generating a view different and linking it to the model 43 | 44 | (define (run@ rendering) 45 | (compound-unit 46 | (import) 47 | (export view) 48 | (link 49 | (((count : count^)) count@ view) 50 | (((view : run^)) (view@ rendering) count)))) 51 | 52 | ;; --------------------------------------------------------------------------------------------------- 53 | ;; let's run them 54 | 55 | (define (run-a) 56 | (define-values/invoke-unit (run@ ~a) (import) (export run^)) 57 | (run)) 58 | 59 | (define (run-sticks) 60 | (define (nat->sticks n) (make-string n #\|)) 61 | (define-values/invoke-unit (run@ nat->sticks) (import) (export run^)) 62 | (run)) 63 | 64 | (run-a) 65 | (run-sticks) 66 | -------------------------------------------------------------------------------- /Macros/7state.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (provide 4 | 5 | ;; SYNTAX 6 | #; (define-state state:id state0:expr propagate:expr) 7 | ;; -- defines (define state state0) ... 8 | ;; -- re-defines set! for state ... so that any changes to state ... invoke propagate ... 9 | 10 | define-state 11 | 12 | #; (define-state* (state:id state0:expr propagate:expr) ...) 13 | ;; (define-state state state0 propagate) ... 14 | 15 | define-state* 16 | 17 | ;; SYNTAX 18 | #; (set! x (values e0 e ...)) 19 | ;; evaluate e0 and e to a list of values, use e0's value as the new value 20 | ;; for x and propagate all of these values to the propagation function. 21 | 22 | #; (set! x (stop e)) 23 | ;; do not propagate this change to state variable x 24 | stop) 25 | 26 | 27 | ;; --------------------------------------------------------------------------------------------------- 28 | (require (for-syntax syntax/parse)) 29 | 30 | ;; --------------------------------------------------------------------------------------------------- 31 | (define-syntax (define-state* stx) 32 | (syntax-parse stx 33 | [(_ (state:id state0:expr f:expr) ...) #'(begin (define-state state state0 f) ...)])) 34 | 35 | (define-syntax (define-state stx) 36 | (syntax-parse stx 37 | [(_ state:id state0:expr f:expr) 38 | #'(begin 39 | (define g f) 40 | (define state-field state0) 41 | (define-getter/setter (state state-field g)))])) 42 | 43 | (define-syntax (define-getter/setter stx) 44 | (syntax-parse stx 45 | [(_ (state state-field f) ...) 46 | #'(begin (define-syntax state (generate-set-state #'state-field #'f)) ...)])) 47 | 48 | (define-for-syntax (generate-set-state state-field f) 49 | (with-syntax ([state-field state-field][f f]) 50 | (make-set!-transformer 51 | (lambda (stx) 52 | (syntax-parse stx 53 | #:literals (stop values) 54 | [x:id #'state-field] 55 | [(set! x (stop e)) #'(set! state-field e)] 56 | [(set! x (values e0 e ...)) 57 | #'(call-with-values 58 | (λ () (apply values (list e0 e ...))) 59 | (λ (y . r) (set! state-field y) (apply f state-field r)))] 60 | [(set! x e) #'(begin (set! state-field e) (f state-field))]))))) 61 | 62 | (define-syntax (stop stx) (raise-syntax-error #f "used out of context")) 63 | -------------------------------------------------------------------------------- /Typed/task-2.rkt: -------------------------------------------------------------------------------- 1 | #! /usr/bin/env gracket 2 | #lang typed/racket/gui 3 | 4 | ;; a bi-directional temperature converter (Fahrenheit vs Celsius) 5 | 6 | ;; --------------------------------------------------------------------------------------------------- 7 | (require 7GUI/Typed/from-string) 8 | ;; We need something like this in Typed Racket. 9 | 10 | ;; --------------------------------------------------------------------------------------------------- 11 | (define-type Temp Real) 12 | (define-type CB {(Instance Text-Field%) Any -> Void}) 13 | 14 | (define *C : Temp 0) 15 | (define *F : Temp 0) 16 | 17 | (: callback ((Temp -> Void) -> CB)) 18 | (define ((callback setter) field _evt) 19 | (define-values (field:num last) (string->number* (send field get-value))) 20 | (cond 21 | [(and field:num last) ;; occurrence typing doesn't tie together the two 22 | (define inexact-n (* #i1.0 field:num)) 23 | (setter inexact-n) 24 | (render field inexact-n last)] 25 | [else (send field set-field-background (make-object color% "red"))])) 26 | 27 | (define (string->number* {str : String}) 28 | (define n (string->er str)) 29 | (values n (and n (string-ref str (- (string-length str) 1))))) 30 | 31 | (define-syntax-rule (flow *from --> *to to-field) 32 | (λ ({x : Temp}) 33 | (set!-values (*from *to) (values x (--> x))) 34 | (render to-field *to #\-))) 35 | 36 | (define (render {to-field : (Instance Text-Field%)} {*to : Temp} {last : Char}) 37 | (send to-field set-field-background (make-object color% "white")) 38 | (send to-field set-value (~a (~r *to #:precision 4) (if (eq? #\. last) "." "")))) 39 | 40 | (define celsius->fahrenheit : CB (callback (flow *C (λ ({c : Temp}) (+ (* c 9/5) 32)) *F F-field))) 41 | (define fahrenheit->celsius : CB (callback (flow *F (λ ({f : Temp}) (* (- f 32) 5/9)) *C C-field))) 42 | 43 | (define frame (new frame% [label "temperature converter"])) 44 | (define pane (new horizontal-pane% [parent frame])) 45 | (define (field {v0 : String} {lbl : String} (cb : CB)) : (Instance Text-Field%) 46 | (new text-field% [parent pane][min-width 199][label lbl][init-value v0][callback cb])) 47 | (define C-field (field "0" "celsius:" celsius->fahrenheit)) 48 | (define F-field (field "0" " = fahrenheit:" fahrenheit->celsius)) 49 | 50 | (celsius->fahrenheit C-field 'start-me-up) 51 | (send frame show #t) 52 | -------------------------------------------------------------------------------- /task-3.rkt: -------------------------------------------------------------------------------- 1 | #! /usr/bin/env gracket 2 | #lang racket/gui 3 | 4 | ;; a flight booker that allows a choice between one-way and return bookings 5 | ;; and, depending on the choice, a start date or a start date and an end date. 6 | 7 | ;; --------------------------------------------------------------------------------------------------- 8 | (require gregor) 9 | 10 | ;; gregor should not raise an exception when parsing fails, but return #f 11 | (define (to-date d) (with-handlers ([exn? (λ (_) #f)]) (parse-date d "d.M.y"))) 12 | 13 | ;; --------------------------------------------------------------------------------------------------- 14 | (define DATE0 "27.03.2014") 15 | (define ONE "one-way flight") 16 | (define RETURN "return flight") 17 | (define CHOICES `(,ONE ,RETURN)) 18 | (define RED (make-object color% "red")) 19 | (define WHITE (make-object color% "white")) 20 | 21 | (define *kind-flight (list-ref CHOICES 0)) ;; one of the CHOICES 22 | (define *start-date (to-date DATE0)) ;; date 23 | (define *return-date (to-date DATE0)) ;; date 24 | 25 | (define (enable-book (start-date *start-date) (return-date *return-date)) 26 | (send book enable #f) 27 | (when (and start-date (date<=? (today) start-date) 28 | (or (and (string=? ONE *kind-flight)) 29 | (and return-date (date<=? start-date return-date)))) 30 | (send book enable #t))) 31 | 32 | (define (enable-return-book . self+evt) 33 | (set! *kind-flight (list-ref CHOICES (if (null? self+evt) 0 (send (first self+evt) get-selection)))) 34 | (send return-d enable (string=? RETURN *kind-flight)) 35 | (enable-book)) 36 | 37 | (define (field date-setter! enabled) 38 | (define (field-cb self evt) 39 | (define date (to-date (send self get-value))) 40 | (cond 41 | [date (send self set-field-background WHITE) (date-setter! date) (enable-book)] 42 | [else (send self set-field-background RED) (enable-book #f #f)])) 43 | (new text-field% [parent frame][label ""][init-value DATE0][enabled enabled] [callback field-cb])) 44 | 45 | (define frame (new frame% [label "flight booker"])) 46 | (define choice (new choice% [label ""][parent frame][choices CHOICES][callback enable-return-book])) 47 | (define start-d (field (λ (nu) (set! *start-date nu)) #t)) 48 | (define return-d (field (λ (nu) (set! *return-date nu)) #f)) 49 | (define book (new button% [label "Book"][parent frame][callback (λ _ (displayln "confirmed"))])) 50 | 51 | (enable-return-book) 52 | (send frame show #t) -------------------------------------------------------------------------------- /task-7-view.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/gui 2 | 3 | (provide 4 | WIDTH 5 | HEIGHT 6 | 7 | ;; DC [Hashof Ref Number] -> Void 8 | paint-grid 9 | 10 | ;; Natural Natural -> Ref 11 | xy->A0 12 | 13 | ;; Natural -> LETTERS 14 | x->A 15 | 16 | ;; Natural -> INDEX 17 | y->0) 18 | 19 | ;; --------------------------------------------------------------------------------------------------- 20 | (require 7GUI/task-7-exp) 21 | 22 | (define HSIZE 100) 23 | (define VSIZE 30) 24 | 25 | (define X-OFFSET 2) 26 | (define Y-OFFSET 10) 27 | 28 | (define WIDTH (* (+ (string-length LETTERS) 1) HSIZE)) 29 | (define HEIGHT (* 101 VSIZE)) 30 | 31 | (define (A->x letter) 32 | (for/first ((l (in-string LETTERS)) (i (in-naturals)) #:when (equal? l letter)) 33 | (+ (* (+ i 1) HSIZE) X-OFFSET))) 34 | 35 | (define (0->y index) 36 | (+ (* (+ index 1) VSIZE) Y-OFFSET)) 37 | 38 | (define ((finder range SIZE) x0) 39 | (define x (- x0 SIZE)) 40 | (and (positive? x) 41 | (for/first ((r range) (i (in-naturals)) #:when (<= (+ (* i SIZE)) x (+ (* (+ i 1) SIZE)))) r))) 42 | 43 | (define (xy->A0 x y) (list (x->A x) (y->0 y))) 44 | 45 | (define x->A (finder (in-string LETTERS) HSIZE)) 46 | 47 | (define y->0 (finder (in-range 100) VSIZE)) 48 | 49 | (define (paint-grid dc content) 50 | (send dc clear) 51 | (paint-hint dc) 52 | (paint-axes dc) 53 | (paint-cells dc content)) 54 | 55 | (define (paint-hint dc) 56 | (let* ([current-font (send dc get-font)]) 57 | (send dc set-font small-font) 58 | (send dc draw-text "click for content" X-OFFSET 2) 59 | (send dc draw-text "double for formula" X-OFFSET 15) 60 | (send dc set-font current-font))) 61 | 62 | (define (paint-axes dc) 63 | (send dc set-brush solid-gray) 64 | (for ((letter (in-string LETTERS)) (i (in-naturals))) 65 | (define x (* (+ i 1) HSIZE)) 66 | (send dc draw-rectangle x 0 HSIZE VSIZE) 67 | (send dc draw-line x 0 x HEIGHT) 68 | (send dc draw-text (string letter) (A->x letter) Y-OFFSET)) 69 | (for ((i (in-range 100))) 70 | (define y (* (+ i 1) VSIZE)) 71 | (send dc draw-line 0 y WIDTH y) 72 | (send dc draw-text (~a i) X-OFFSET (0->y i)))) 73 | 74 | (define (paint-cells dc content) 75 | (for (((key value) (in-hash content))) 76 | (match-define (list letter index) key) 77 | (define x0 (A->x letter)) 78 | (define y0 (0->y index)) 79 | (send dc draw-text (~a value) x0 y0))) 80 | 81 | (define small-font (make-object font% 12 'roman)) 82 | (define solid-gray (new brush% [color "lightgray"])) 83 | -------------------------------------------------------------------------------- /task-7-exp.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (provide 4 | LETTERS 5 | 6 | #; {String -> {U Integer False}} 7 | valid-content 8 | 9 | #; {String -> Exp* u False} 10 | string->exp* 11 | 12 | #; {Exp* u False -> String} 13 | exp*->string 14 | 15 | #; {Exp* -> (Listof Ref*)} 16 | depends-on 17 | 18 | #;{ Exp* [Hashof Ref* Integer] -> Integer} 19 | evaluate) 20 | 21 | (require 7GUI/should-be-racket) 22 | 23 | (define LETTERS "ABCDEFGHIJKLMNOPQRSTUVWXYZ") 24 | 25 | ;; EXPRESSIONS: EXTERNAL, STRING-BASED REPRESENTATION 26 | #; {Index : N in [0,99]} 27 | #; {Reference is a Letter followed by an Index} 28 | #; {Expression = Reference || Integer || (+ Expression Expression)} 29 | 30 | ;; EXPRESSIONS: INTERNAL 31 | #; {Ref* = (List Letter Index)} 32 | #; {Exp* = Ref* || Integer || (list '+ Exp* Exp*)} 33 | 34 | (define (valid-content x) 35 | (and* (string->number x) => (lambda (n) (and (integer? n) n)))) 36 | 37 | (define (string->exp* x) 38 | (define ip (open-input-string x)) 39 | (define y (read ip)) 40 | (and (eof-object? (read ip)) 41 | (let loop ([y y]) 42 | (match y 43 | [(? valid-cell) (valid-cell y)] 44 | [(? integer?) y] 45 | [(list '+ y1 y2) (list '+ (loop y1) (loop y2))] 46 | [else #f])))) 47 | 48 | (define (exp*->string exp*) 49 | (if (boolean? exp*) 50 | "" 51 | (let render-exp* ((exp* exp*)) 52 | (match exp* 53 | [(? number?) (~a exp*)] 54 | [(list letter index) (~a letter index)] 55 | [(list '+ left right) (format "(+ ~a ~a)" (render-exp* left) (render-exp* right))])))) 56 | 57 | (define (depends-on exp*) 58 | (let loop ([exp* exp*][accumulator (set)]) 59 | (match exp* 60 | [(? number?) accumulator] 61 | [(list L I) (set-add accumulator exp*)] 62 | [(list '+ left right) (loop left (loop right accumulator))]))) 63 | 64 | (define (evaluate exp* global-env) 65 | (let loop ([exp* exp*]) 66 | (match exp* 67 | [(? number?) exp*] 68 | [(list L I) (hash-ref global-env exp* 0)] 69 | [(list '+ left right) (+ (loop left) (loop right))]))) 70 | 71 | #; {Symbol -> (List Letter Index) u False} 72 | (define (valid-cell x:sym) 73 | (and (symbol? x:sym) 74 | (let* ([x:str (symbol->string x:sym)]) 75 | (or (and* (regexp-match #px"([A-Z])(\\d\\d)" x:str) => split) 76 | (and* (regexp-match #px"([A-Z])(\\d)" x:str) => split))))) 77 | 78 | (define (split x) 79 | (match x [(list _ letter index) (list (string-ref letter 0) (string->number index))])) 80 | -------------------------------------------------------------------------------- /Macros/task-5.rkt: -------------------------------------------------------------------------------- 1 | #! /usr/bin/env gracket 2 | #lang at-exp racket/gui 3 | 4 | ;; a create-read-update-deleted MVC implementation 5 | 6 | ;; --------------------------------------------------------------------------------------------------- 7 | (require 7GUI/Macros/7guis 7GUI/Macros/7state) 8 | 9 | ;; --------------------------------------------------------------------------------------------------- 10 | (define (selector! nu) (set! *prefix nu)) 11 | (define (select s) (string-prefix? s *prefix)) 12 | (define (data->selected! _) (set! *selected (if (string=? "" *prefix) *data (filter select *data)))) 13 | 14 | (define-state *data '("Emil, Hans" "Mustermann, Max" "Tisch, Roman") data->selected!) 15 | (define-state *prefix "" data->selected!) 16 | (define-state *selected *data (λ (s) (send lbox set s))) ;; selected = (filter select data) 17 | 18 | (define (Create *data) (append *data (list (get-name)))) 19 | (define (Update i) (if i (operate-on i (curry cons (get-name))) none)) 20 | (define (Delete i) (if i (operate-on i values) none)) 21 | 22 | #; {N [[Listof X] -> [Listof X]] -> [Listof X]} 23 | ;; traverse list to the i-th position of selected in data, then apply operator to rest (efficiency) 24 | ;; ASSUME selected = (filter selector data) 25 | ;; ASSUME i <= (length selected) 26 | (define (operate-on i operator) 27 | (let sync ((i i) (data *data) (selected *selected)) 28 | (if (select (first data)) 29 | (if (zero? i) 30 | (operator (rest data)) 31 | (cons (first data) (sync (sub1 i) (rest data) (rest selected)))) 32 | (cons (first data) (sync i (rest data) selected))))) 33 | 34 | (define (get-name) (string-append (send surname get-value) ", " (send name get-value))) 35 | 36 | ;; --------------------------------------------------------------------------------------------------- 37 | (define (mk-changer p) (with i #:post p #:widget lbox #:method get-selection i)) 38 | (define (name-field% n) (class text-field% (super-new (label n) (init-value "") (min-width 200)))) 39 | 40 | (define-gui frame "CRUD" 41 | (#:horizontal 42 | (#:vertical 43 | (text-field% #:change *prefix (with p p) [label "Filter prefix: "][init-value ""]) 44 | (#:id lbox list-box% [label #f][choices '()][min-width 100][min-height 100])) 45 | (#:vertical (#:id name (name-field% "Name: ")) (#:id surname (name-field% "Surname: ")))) 46 | (#:horizontal 47 | (button% #:change *data (just Create) [label "Create"]) 48 | (button% #:change *data (mk-changer Update) [label "Update"]) 49 | (button% #:change *data (mk-changer Delete) [label "Delete"]))) 50 | 51 | (selector! "") 52 | (send frame show #t) 53 | -------------------------------------------------------------------------------- /Typed/task-3.rkt: -------------------------------------------------------------------------------- 1 | #! /usr/bin/env gracket 2 | #lang typed/racket/gui 3 | 4 | ;; a flight booker that allows a choice between one-way and return bookings 5 | ;; and, depending on the choice, a start date or a start date and an end date. 6 | 7 | ;; --------------------------------------------------------------------------------------------------- 8 | (require 7GUI/Typed/gregor) 9 | 10 | ;; gregor should not raise an exception when parsing fails, but return #f 11 | (define (to-date {d : String}) (with-handlers ([exn:fail? (λ (_) #f)]) (parse-date d "d.M.y"))) 12 | 13 | ;; --------------------------------------------------------------------------------------------------- 14 | (define DATE0 "27.03.2014") 15 | (define ONE "one-way flight") 16 | (define RETURN "return flight") 17 | (define CHOICES `(,ONE ,RETURN)) 18 | (define RED (make-object color% "red")) 19 | (define WHITE (make-object color% "white")) 20 | 21 | (define *kind (list-ref CHOICES 0)) ;; one of the CHOICES 22 | (define *start-date (to-date DATE0)) ;; date 23 | (define *return-date (to-date DATE0)) ;; date 24 | 25 | (: enable-book (->* () ((U Date False) (U Date False)) Void)) 26 | (define (enable-book (start-date *start-date) (return-date *return-date)) 27 | (send book enable #f) 28 | (when (and start-date (date<=? (today) start-date) 29 | (or (and (string=? ONE *kind)) 30 | (and return-date (date<=? start-date return-date)))) 31 | (send book enable #t))) 32 | 33 | (: enable-return-book (->* [] [(Instance Choice%) Any] Void)) 34 | (define (enable-return-book (self #f) (_evt #f)) 35 | (set! *kind (list-ref CHOICES (or (and self (send self get-selection)) 0))) 36 | (send return-d enable (string=? RETURN *kind)) 37 | (enable-book)) 38 | 39 | (: field (-> (-> Date Void) Boolean (Instance Text-Field%))) 40 | (define (field date-setter! enabled) 41 | (: field-cb (-> (Instance Text-Field%) Any Void)) 42 | (define (field-cb self _evt) 43 | (define date (to-date (send self get-value))) 44 | (cond 45 | [date (send self set-field-background WHITE) (date-setter! date) (enable-book)] 46 | [else (send self set-field-background RED) (enable-book #f #f)])) 47 | (new text-field% [parent frame][label ""][init-value DATE0][enabled enabled] [callback field-cb])) 48 | 49 | (define frame (new frame% [label "flight booker"])) 50 | (define choice (new choice% [label ""][parent frame][choices CHOICES][callback enable-return-book])) 51 | (define start-d (field (λ (nu) (set! *start-date nu)) #t)) 52 | (define return-d (field (λ (nu) (set! *return-date nu)) #f)) 53 | (define book (new button% [label "Book"][parent frame][callback (λ _ (displayln "confirmed"))])) 54 | 55 | (enable-return-book) 56 | (send frame show #t) 57 | -------------------------------------------------------------------------------- /Typed/sub.rkt: -------------------------------------------------------------------------------- 1 | #lang typed/racket 2 | 3 | (provide 4 | ;; type 5 | MaybeString 6 | MaybeN 7 | MaybeInt 8 | 9 | ;; SYNTAX 10 | #;(define-sub-type define-type-class init:init-type ...) 11 | ;; defines the macro 12 | #;(define-type-class def-type:id #:minus-init (i:id ...) ctc:clause-type-clause ...) 13 | ;; which can (define-type def-type ...), a Class type with the given init fields init ... 14 | ;; plus the class type clauses ctc ... 15 | ;; minus the fields i ... specified via an initial #:minus-init (s ...) clause 16 | 17 | define-sub-type) 18 | 19 | ;; --------------------------------------------------------------------------------------------------- 20 | (require (for-syntax syntax/parse)) 21 | (require (for-syntax racket/function)) 22 | (require (for-syntax 7GUI/should-be-racket)) 23 | 24 | ;; --------------------------------------------------------------------------------------------------- 25 | (define-type MaybeString (U False String)) 26 | 27 | (define-type MaybeN (U Exact-Nonnegative-Integer False)) 28 | 29 | (define-type MaybeInt (U False Integer)) 30 | 31 | (begin-for-syntax 32 | (define-syntax-class init-type 33 | (pattern (name:id type (~optional #:optional)))) 34 | 35 | (define-syntax-class class-type-clause 36 | #:literals (init init-field init-rest field augment) 37 | (pattern ((~optional (~or init init-field init-rest field augment)) (x:id t) ...) 38 | #:attr name #'(x ...) 39 | #:attr type #'(t ...)) 40 | (pattern (y:id s) 41 | #:attr name #'(y) 42 | #:attr type #'(s)))) 43 | 44 | (define-syntax (define-sub-type stx) 45 | (syntax-parse stx 46 | [(_ def-type:id implements%:id p:init-type ...) 47 | #:with (t ...) (generate-temporaries #'(p ...)) 48 | #`(begin 49 | (define-type t p.type) ... 50 | (define-syntax (def-type stx) (def-type-rhs stx #'implements% #'(p ...) #'(p.name ...))))])) 51 | 52 | (define-for-syntax (def-type-rhs stx implements% init-parameters init-labels) 53 | (define inits0 (syntax->list init-parameters)) 54 | (define label0 (map syntax-e (syntax->list init-labels))) 55 | (with-syntax ((stx stx) (implements% implements%)) 56 | (syntax-parse #'stx 57 | [(_ name-of-type% (~optional (~seq #:minus-init (y:id ...))) ctc:class-type-clause ...) 58 | #:do ((define minuss (syntax->list #'(~? (y ...) ()))) 59 | (define inits- (map syntax-e minuss)) 60 | (define m* (for/first ((i inits-) (m minuss) #:unless (memf (curry eq? i) label0)) m))) 61 | #:fail-when m* (format "cannot subtract ~a from ~a" (syntax-e m*) label0) 62 | #:do ((define inits+ (for/list ([l label0][i inits0] #:unless (memf (curry eq? l) inits-)) i))) 63 | #`(define-type name-of-type% (Class #:implements implements% ctc ... (init #,@inits+)))]))) -------------------------------------------------------------------------------- /Macros/README.md: -------------------------------------------------------------------------------- 1 | ## Using Macros to Simplify the Specification of Views and Models 2 | 3 | This directory re-implements the "7 GUIs" task with the help of Racket's 4 | Macro system. The primitive implementation in the top-level directory make 5 | barely use of macros, but their implementation suggests two repeated ideas 6 | that are not expressible in plain Racket. 7 | 8 | - `7guis`: provides macros for specifying 9 | - the layout of hierarchical GUIs: `gui` and `define-gui` 10 | An auxiliary `#:change` element in `gui` and `define-gui` directly 11 | expressed how a widget affects the state of the model. 12 | 13 | - state variables: `(define-state x"id v:expr pf:expr)`, which propagates a change 14 | to `x` via the propagation function `pf` (to the rest of the model and the view) 15 | 16 | - `task 1`: shrinks to a one-line model and a three-line GUI: see `#:change` and `define-state` for data flow 17 | - `task 2`: the bi-directional change demands a feature for stopping state-change propagation 18 | - `task 3`: is the first task to benefit from one-line class definitions: 19 | ``` 20 | (define stext% (class text-field% (init e) (super-new [label ""][init-value DATE0][enabled e]))) 21 | ``` 22 | - `task 4`: -- 23 | - `task 5`: it could benefit from macros within the DSL of GUIs 24 | - [`task 6`](task-6.rkt) illustrates how a single program can use the gui layout macros in 25 | several places and how state variables show up both in the model and the 26 | view, which of course just means that "model" comes in several layers. 27 | - [`task 7`](task-7.rkt) is an example of a state variable with complex content 28 | (a hash table) and a complex update behavior. A change propagates several 29 | ("many") values when a variable is changed. 30 | 31 | Curiously, the injection of `gui`, `define-gui`, and `define-state` into 32 | the code base has exposed a couple of small logical mistakes in the 33 | original code base because the code's intention have become clearer than 34 | the original ones. 35 | 36 | When I reported this to [Michael Ballantyne](http://mballantyne.net), he 37 | replied with the pithy slogan that 38 | 39 | "you are far more likely to discover bugs by porting a program from plain 40 | JavaScript to React than TypeScript. And the same holds for rewriting from 41 | a recursive-descent parser in a parsing framework than Typed Racket." 42 | 43 | All I can say to this is "take that, Typists!". 44 | 45 | ### To Do 46 | 47 | - task-5 might benefit from macro-expansion inside of `gui` and 48 | `define-gui`, specifically the `option` class 49 | 50 | ``` 51 | (define-syntax-rule (but% f lbl) (button% #:change *data (f lbl) [label (format "~a" 'lbl)])) 52 | ``` 53 | 54 | and then we get the 3 horizontal buttons like this: 55 | 56 | ``` 57 | (but% just Create) (but% mk-changer Update) (but% mk-changer Delete) 58 | ``` 59 | But this could also be overkill. 60 | -------------------------------------------------------------------------------- /task-5.rkt: -------------------------------------------------------------------------------- 1 | #! /usr/bin/env gracket 2 | #lang at-exp racket/gui 3 | 4 | ;; a create-read-update-deleted MVC implementation 5 | 6 | ;; --------------------------------------------------------------------------------------------------- 7 | (define *data '("Emil, Hans" "Mustermann, Max" "Tisch, Roman")) 8 | (define *selector "") 9 | (define *selected *data) ;; selected = (filter select data) 10 | 11 | (define (selector! nu) (set! *selector nu) (data->selected!)) 12 | (define (select s) (string-prefix? s *selector)) 13 | (define (data->selected!) (set! *selected (if (string=? "" *selector) *data (filter select *data)))) 14 | 15 | (define-syntax-rule (def-! (name x ...) exp) (define (name x ...) (set! *data exp) (data->selected!))) 16 | (def-! (create-entry new-entry) (append *data (list new-entry))) 17 | (def-! (update-entry new-entry i) (operate-on i (curry cons new-entry) *data select *selected)) 18 | (def-! (delete-from i) (operate-on i values)) 19 | 20 | #; {N [[Listof X] -> [Listof X]] [Listof X] [X -> Boolean] [Listof X] -> [Listof X]} 21 | ;; traverse list to the i-th position of selected in data, then apply operator to rest (efficiency) 22 | ;; ASSUME selected = (filter selector data) 23 | ;; ASSUME i <= (length selected) 24 | (define (operate-on i operator (data *data) (select select) (selected *selected)) 25 | (let sync ((i i) (data data) (selected selected)) 26 | (if (select (first data)) 27 | (if (zero? i) 28 | (operator (rest data)) 29 | (cons (first data) (sync (sub1 i) (rest data) (rest selected)))) 30 | (cons (first data) (sync i (rest data) selected))))) 31 | 32 | ;; --------------------------------------------------------------------------------------------------- 33 | (define-syntax-rule (def-cb (name x) exp ...) (define (name x _y) exp ... (send lbox set *selected))) 34 | (def-cb (prefix-cb field) (selector! (if (string? field) field (send field get-value)))) 35 | (def-cb (Create-cb _b) (create-entry (retrieve-name))) 36 | (def-cb (Update-cb _b) (common-cb (curry update-entry (retrieve-name)))) 37 | (def-cb (Delete-cb _b) (common-cb delete-from)) 38 | 39 | (require 7GUI/should-be-racket) 40 | (define (common-cb f) (when* (send lbox get-selection) => f)) 41 | (define (retrieve-name) (string-append (send surname get-value) ", " (send name get-value))) 42 | 43 | ;; --------------------------------------------------------------------------------------------------- 44 | (define frame (new frame% [label "CRUD"])) 45 | (define hpane1 (new horizontal-pane% [parent frame][border 10][alignment '(left bottom)])) 46 | (define vpane1 (new vertical-pane% [parent hpane1])) 47 | (new text-field% [parent vpane1][label "Filter prefix: "][init-value ""][callback prefix-cb]) 48 | (define lbox (new list-box% [parent vpane1][label #f][choices '()][min-width 100][min-height 100])) 49 | (define vpane2 (new vertical-pane% [parent hpane1][alignment '(right center)])) 50 | (define name (new text-field% [parent vpane2][label "Name: "][init-value ""][min-width 200])) 51 | (define surname (new text-field% [parent vpane2][label "Surname: "][init-value ""][min-width 200])) 52 | (define hpane2 (new horizontal-pane% [parent frame])) 53 | (new button% [label "Create"][parent hpane2][callback Create-cb]) 54 | (new button% [label "Update"][parent hpane2][callback Update-cb]) 55 | (new button% [label "Delete"][parent hpane2][callback Delete-cb]) 56 | 57 | (prefix-cb "" '***) 58 | (send frame show #t) 59 | -------------------------------------------------------------------------------- /task-7.rkt: -------------------------------------------------------------------------------- 1 | #! /usr/bin/env gracket 2 | #lang at-exp racket/gui 3 | 4 | ;; a simple spreadsheet (will not check for circularities) 5 | 6 | (require 7GUI/task-7-exp) 7 | (require 7GUI/task-7-view) 8 | (require 7GUI/canvas-double-click) 9 | 10 | ;; ----------------------------------------------------------------------------- 11 | (struct formula (formula dependents) #:transparent) 12 | #; {Formula = [formula Exp* || Number || (Setof Ref*)]} 13 | 14 | (define *content (make-immutable-hash)) ;; [Hashof Ref* Integer] 15 | (define *formulas (make-immutable-hash)) ;; [HashOF Ref* Formula] 16 | 17 | (define-syntax-rule (iff selector e default) (let ([v e]) (if v (selector v) default))) 18 | (define (get-exp ref*) (iff formula-formula (hash-ref *formulas ref* #f) 0)) 19 | (define (get-dep ref*) (iff formula-dependents (hash-ref *formulas ref* #f) (set))) 20 | (define (get-content ref*) (hash-ref *content ref* 0)) 21 | 22 | (require 7GUI/should-be-racket) 23 | (define (set-content! ref* vc) 24 | (define current (get-content ref*)) 25 | (set! *content (hash-set *content ref* vc)) 26 | (when (and current (not (= current vc))) 27 | (when* (get-dep ref*) => propagate-to))) 28 | 29 | (define (propagate-to dependents) 30 | (for ((d (in-set dependents))) 31 | (set-content! d (evaluate (get-exp d) *content)))) 32 | 33 | (define (set-formula! ref* exp*) 34 | (define new (formula exp* (or (get-dep ref*) (set)))) 35 | (set! *formulas (hash-set *formulas ref* new)) 36 | (register-with-dependents (depends-on exp*) ref*) 37 | (set-content! ref* (evaluate exp* *content))) 38 | 39 | (define (register-with-dependents dependents ref*) 40 | (for ((d (in-set dependents))) 41 | (set! *formulas (hash-set *formulas d (formula (get-exp d) (set-add (get-dep d) ref*)))))) 42 | 43 | ;; --------------------------------------------------------------------------------------------------- 44 | (define cells-canvas% 45 | (class canvas-double-click% 46 | (define/augment-final (on-click x y) (content-edit x y)) 47 | (define/augment-final (on-double-click x y) (formula-edit x y)) 48 | (super-new [paint-callback (lambda (_self dc) (paint-grid dc *content))]))) 49 | 50 | ;; --------------------------------------------------------------------------------------------------- 51 | ;; cells and contents 52 | (define ((mk-edit title-fmt validator registration source) x y) 53 | (define cell (list (x->A x) (y->0 y))) 54 | (when (and (first cell) (second cell)) 55 | (define value0 (~a (or (source cell) ""))) 56 | (define dialog (new dialog% [style '(close-button)] [label (format title-fmt cell)])) 57 | (new text-field% [parent dialog] [label #f] [min-width 200] [min-height 80] [init-value value0] 58 | [callback (λ (self evt) 59 | (when (eq? (send evt get-event-type) 'text-field-enter) 60 | (when* (validator (send self get-value)) 61 | => (lambda (valid) (registration cell valid) (send dialog show #f)))))]) 62 | (send dialog show #t))) 63 | 64 | (define content-edit (mk-edit "content for cell ~a" valid-content set-content! get-content)) 65 | 66 | (define formula-fmt "a formula for cell ~a") 67 | (define formula-edit (mk-edit formula-fmt string->exp* set-formula! (compose exp*->string get-exp))) 68 | 69 | ;; --------------------------------------------------------------------------------------------------- 70 | (define frame (new frame% [label "Cells"][width (/ WIDTH 2)][height (/ HEIGHT 3)])) 71 | (define canvas (new cells-canvas% [parent frame] [style '(hscroll vscroll)])) 72 | (send canvas init-auto-scrollbars WIDTH HEIGHT 0. 0.) 73 | (send canvas show-scrollbars #t #t) 74 | 75 | (send frame show #t) 76 | -------------------------------------------------------------------------------- /Macros/task-7.rkt: -------------------------------------------------------------------------------- 1 | #! /usr/bin/env gracket 2 | #lang racket/gui 3 | 4 | ;; a simple spreadsheet (will not check for circularities) 5 | 6 | (require 7GUI/should-be-racket) 7 | (require 7GUI/task-7-exp) 8 | (require 7GUI/task-7-view) 9 | (require 7GUI/canvas-double-click) 10 | (require 7GUI/Macros/7guis 7GUI/Macros/7state) 11 | 12 | ;; --------------------------------------------------------------------------------------------------- 13 | (struct formula (formula dependents) #:transparent) 14 | #; {Formula = [formula Exp* || Number || (Setof Ref*)]} 15 | 16 | (define-syntax-rule (iff selector e default) (let ([v e]) (if v (selector v) default))) 17 | (define (get-exp ref*) (iff formula-formula (hash-ref *formulas ref* #f) 0)) 18 | (define (get-dep ref*) (iff formula-dependents (hash-ref *formulas ref* #f) (set))) 19 | (define (get-content ref*) (hash-ref *content ref* 0)) 20 | 21 | (define (set-content! ref* vc) 22 | (when (and* (get-content ref*) => (lambda (current) (not (= current vc)))) 23 | (set! *content (values (hash-set *content ref* vc) ref*)))) 24 | 25 | (define (propagate-content-change _ ref*) 26 | (for ((d (in-set (get-dep ref*)))) 27 | (set-content! d (evaluate (get-exp d) *content)))) 28 | 29 | (define-state *content (make-immutable-hash) propagate-content-change) ;; [Hashof Ref* Integer] 30 | 31 | (define (set-formula! ref* exp*) 32 | (define new (formula exp* (get-dep ref*))) 33 | (set! *formulas (values (hash-set *formulas ref* new) ref* (depends-on exp*))) 34 | (set-content! ref* (evaluate exp* *content))) 35 | 36 | (define (propagate-change-to-formulas _ ref dependents) 37 | (for ((d (in-set dependents))) 38 | (set! *formulas (stop (hash-set *formulas d (formula (get-exp d) (set-add (get-dep d) ref))))))) 39 | 40 | (define-state *formulas (make-immutable-hash) propagate-change-to-formulas) ;; [HashOF Ref* Formula] 41 | 42 | ;; --------------------------------------------------------------------------------------------------- 43 | (define ccanvas% 44 | (class canvas-double-click% 45 | (define/augment-final (on-click x y) (content-edit x y)) 46 | (define/augment-final (on-double-click x y) (formula-edit x y)) 47 | (super-new [paint-callback (lambda (_self dc) (paint-grid dc *content))]))) 48 | 49 | ;; --------------------------------------------------------------------------------------------------- 50 | ;; cells and contents 51 | (define ((mk-edit title-fmt validator setter source) x y) 52 | (define cell (list (x->A x) (y->0 y))) 53 | (when (and (first cell) (second cell)) 54 | (define value0 (~a (or (source cell) ""))) 55 | (gui #:id D #:frame (class dialog% (super-new [style '(close-button)])) (format title-fmt cell) 56 | (text-field% [label #f] [min-width 200] [min-height 80] [init-value value0] 57 | [callback (λ (self evt) 58 | (when (eq? (send evt get-event-type) 'text-field-enter) 59 | (when* (validator (send self get-value)) 60 | => (lambda (valid) (setter cell valid) (send D show #f)))))])))) 61 | 62 | (define content-edit (mk-edit "content for cell ~a" valid-content set-content! get-content)) 63 | 64 | (define formula-fmt "a formula for cell ~a") 65 | (define formula-edit (mk-edit formula-fmt string->exp* set-formula! (compose exp*->string get-exp))) 66 | 67 | ;; --------------------------------------------------------------------------------------------------- 68 | (define-gui frame "Cells" 69 | (#:id canvas ccanvas% (min-width (/ WIDTH 2)) (min-height (/ HEIGHT 3)) [style '(hscroll vscroll)])) 70 | (send canvas init-auto-scrollbars WIDTH HEIGHT 0. 0.) 71 | (send canvas show-scrollbars #t #t) 72 | 73 | (send frame show #t) 74 | -------------------------------------------------------------------------------- /Typed/task-5.rkt: -------------------------------------------------------------------------------- 1 | #! /usr/bin/env gracket 2 | #lang typed/racket/gui 3 | 4 | ;; a create-read-update-deleted MVC implementation 5 | 6 | ;; --------------------------------------------------------------------------------------------------- 7 | (define-type Data [Listof String]) 8 | 9 | (define *data '("Emil, Hans" "Mustermann, Max" "Tisch, Roman")) 10 | (define *selector "") 11 | (define *selected *data) ;; selected = (filter select data) 12 | 13 | (define (selector! {nu : String}) (set! *selector nu) (data->selected!)) 14 | (define (select {s : String}) (string-prefix? s *selector)) 15 | (define (data->selected!) : Void 16 | (set! *selected (if (string=? "" *selector) *data (filter select *data)))) 17 | 18 | (define-syntax-rule (def-! (name x ...) exp) (define (name x ...) (set! *data exp) (data->selected!))) 19 | (def-! (create-entry {new-entry : String}) (append *data (list new-entry))) 20 | (def-! (update-entry {new-entry : String} {i : Natural}) 21 | (operate-on i (λ {{x : Data}} (cons new-entry x)) *data select *selected)) 22 | (def-! (delete-from {i : Natural}) (operate-on i values)) 23 | 24 | (: operate-on (->* (Natural [Data -> Data]) (Data [String -> Boolean] Data) Data)) 25 | ;; traverse list to the i-th position of selected in data, then apply operator to rest (efficiency) 26 | ;; ASSUME selected = (filter selector data) 27 | ;; ASSUME i <= (length selected) 28 | (define (operate-on i operator (data *data) (select select) (selected *selected)) 29 | (let sync ((i i) (data data) (selected selected)) 30 | (if (select (first data)) 31 | (if (zero? i) 32 | (operator (rest data)) 33 | (cons (first data) (sync (sub1 i) (rest data) (rest selected)))) 34 | (cons (first data) (sync i (rest data) selected))))) 35 | 36 | ;; --------------------------------------------------------------------------------------------------- 37 | (define-syntax-rule (def-cb (name {x : T}) exp ...) 38 | (define (name {x : (U String T)} {_y : Any}) : Void exp ... (send lbox set *selected))) 39 | (def-cb (prefix-cb {f : (Instance Text-Field%)}) (selector! (if (string? f) f (send f get-value)))) 40 | (def-cb (Create-cb {_b : Any}) (create-entry (retrieve-name))) 41 | (def-cb (Update-cb {_b : Any}) (common-cb (λ ({x : Natural}) (update-entry (retrieve-name) x)))) 42 | (def-cb (Delete-cb {_b : Any}) (common-cb delete-from)) 43 | 44 | (require 7GUI/should-be-racket) 45 | 46 | (: common-cb (-> (-> Natural Void) Void)) 47 | (define (common-cb f) (when* (send lbox get-selection) => f)) 48 | (: retrieve-name (-> String)) 49 | (define (retrieve-name) (string-append (send surname get-value) ", " (send name get-value))) 50 | 51 | ;; --------------------------------------------------------------------------------------------------- 52 | (define frame (new frame% [label "CRUD"])) 53 | (define hpane1 (new horizontal-pane% [parent frame][border 10][alignment '(left bottom)])) 54 | (define vpane1 (new vertical-pane% [parent hpane1])) 55 | (new text-field% [parent vpane1][label "Filter prefix: "][init-value ""][callback prefix-cb]) 56 | (define lbox (new list-box% [parent vpane1][label #f][choices '()][min-width 100][min-height 100])) 57 | (define vpane2 (new vertical-pane% [parent hpane1][alignment '(right center)])) 58 | (define name (new text-field% [parent vpane2][label "Name: "][init-value ""][min-width 200])) 59 | (define surname (new text-field% [parent vpane2][label "Surname: "][init-value ""][min-width 200])) 60 | (define hpane2 (new horizontal-pane% [parent frame])) 61 | (new button% [label "Create"][parent hpane2][callback Create-cb]) 62 | (new button% [label "Update"][parent hpane2][callback Update-cb]) 63 | (new button% [label "Delete"][parent hpane2][callback Delete-cb]) 64 | 65 | (prefix-cb "" '***) 66 | (send frame show #t) 67 | -------------------------------------------------------------------------------- /Typed/task-7.rkt: -------------------------------------------------------------------------------- 1 | #! /usr/bin/env gracket 2 | #lang at-exp typed/racket/gui 3 | 4 | ;; a simple spreadsheet (will not check for circularities) 5 | 6 | (require 7GUI/Typed/task-7-exp) 7 | (require 7GUI/Typed/task-7-view) 8 | (require 7GUI/Typed/canvas-double-click) 9 | (require 7GUI/should-be-racket) 10 | 11 | ;; --------------------------------------------------------------------------------------------------- 12 | (struct formula ({formula : Exp} {dependents : [Setof Ref]}) #:transparent) 13 | 14 | (: *content Content) 15 | (define *content (make-immutable-hash)) ;; [Hashof Ref* Integer] 16 | (: *formulas (Immutable-HashTable Ref formula)) 17 | (define *formulas (make-immutable-hash)) ;; [HashOF Ref* Formula] 18 | 19 | (define-syntax-rule (define-getr name : ResultType HashType (*source selector default)) 20 | (define (name {ref : Ref}) : ResultType (selector (hash-ref *source ref (λ () default))))) 21 | 22 | (define formula0 (formula 0 (set))) 23 | (define-getr get-exp* : Exp formula (*formulas formula-formula formula0)) 24 | (define-getr get-dependents : [Setof Ref] formula (*formulas formula-dependents formula0)) 25 | (define-getr get-content : Integer Integer (*content values 0)) 26 | 27 | (: set-content! (-> Ref Integer Void)) 28 | (define (set-content! ref* vc) 29 | (define current (get-content ref*)) 30 | (set! *content (hash-set *content ref* vc)) 31 | (when (and current (not (= current vc))) 32 | (when* (get-dependents ref*) => propagate-to))) 33 | 34 | (: propagate-to (-> [Setof Ref] Void)) 35 | (define (propagate-to dependents) 36 | (for ((d : Ref dependents)) 37 | (set-content! d (evaluate (get-exp* d) *content)))) 38 | 39 | (: set-formula! (-> Ref Exp Void)) 40 | (define (set-formula! ref* exp*) 41 | (define new (formula exp* (or (get-dependents ref*) (set)))) 42 | (set! *formulas (hash-set *formulas ref* new)) 43 | (register-with-dependents (depends-on exp*) ref*) 44 | (set-content! ref* (evaluate exp* *content))) 45 | 46 | (: register-with-dependents (-> [Setof Ref] Ref Void)) 47 | (define (register-with-dependents dependents ref*) 48 | (for ((d : Ref (in-set dependents))) 49 | (set! *formulas (hash-set *formulas d (formula (get-exp* d) (set-add (get-dependents d) ref*)))))) 50 | 51 | ;; --------------------------------------------------------------------------------------------------- 52 | (define cells-canvas% 53 | (class canvas-double-click% 54 | (define/augment #;-final (on-click {x : Natural} {y : Natural}) (content-edit x y)) 55 | (define/augment #;-final (on-double-click {x : Natural} {y : Natural}) (formula-edit x y)) 56 | (super-new [paint-callback (lambda (_self dc) (paint-grid dc *content))]))) 57 | 58 | ;; --------------------------------------------------------------------------------------------------- 59 | ;; cells and contents 60 | (define-type Edit% (-> Natural Natural Void)) 61 | 62 | (: mk-edit (All (X Y) (-> String (-> String (U False X)) (-> Ref X Void) (-> Ref Y) Edit%))) 63 | (define ((mk-edit title-fmt validator registration source) x y) 64 | (define ref (xy->A0 x y)) 65 | (when (and (first ref) (second ref)) 66 | (define value0 (~a (or (source ref) ""))) 67 | (define dialog (new dialog% [style '(close-button)] [label (format title-fmt ref)])) 68 | (new text-field% [parent dialog] [label #f] [min-width 200] [min-height 80] [init-value value0] 69 | [callback (λ (self evt) 70 | (when (eq? (send evt get-event-type) 'text-field-enter) 71 | (when* (validator (send self get-value)) => 72 | (lambda (valid) (registration ref valid) (send dialog show #f)))))]) 73 | (send dialog show #t))) 74 | 75 | (define formula-fmt "a formula for cell ~a") 76 | (: formula-edit Edit%) 77 | (define formula-edit (mk-edit formula-fmt string->exp* set-formula! (compose exp*->string get-exp*))) 78 | 79 | (define content-fmt "content for cell ~a") 80 | (define content-edit : Edit% (mk-edit content-fmt valid-content set-content! get-content)) 81 | 82 | ;; --------------------------------------------------------------------------------------------------- 83 | (define frame (new frame% [label "Cells"][width (quotient WIDTH 2)][height (quotient HEIGHT 3)])) 84 | (define canvas (new cells-canvas% [parent frame] [style '(hscroll vscroll)])) 85 | (send canvas init-auto-scrollbars WIDTH HEIGHT 0. 0.) 86 | (send canvas show-scrollbars #t #t) 87 | 88 | (send frame show #t) 89 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | 2 | ## A Racket Implementation of [7 GUIs](https://eugenkiss.github.io/7guis/) 3 | 4 | The purpose of this repository is to use the "seven GUI challenge" to 5 | illustrate basic GUI programming in Racket and, more importantly, explore 6 | program transformations such as the injection of types, macros, or both. 7 | 8 | The top-level of this repository implements the "7 GUIs" task with the bare 9 | minimum that it took me to get things running and make them reflect what I 10 | was doing. (To my surprise, I never had to resort to unit testing.) 11 | 12 | - `task 1`: a mouse-click counter 13 | - `task 2`: a bi-directional temperature converter 14 | - `task 3`: a constrained flight booking choice 15 | - `task 4`: a timer 16 | - `task 5`: a CRUD MVC 17 | - `task 6`: a circle drawer, with undo/redo facility (under-specified) 18 | - `task 7`: a simple spreadsheet 19 | - `task 7-exp`: implement the simplistic Expression language for spreadsheets 20 | - `task-7-view`: draw a grid on to some drawing context, and then add content 21 | - `canvas-double-click`: a canvas with methods for single-click and double-click reactions 22 | [should perhaps be fleshed out and part of the GUI library] 23 | 24 | To install, 25 | ``` 26 | $ raco pkg install https://github.com/mfelleisen/7GUI.git 27 | ``` 28 | 29 | To run in a shell, 30 | ``` 31 | $ ./task-N.rkt 32 | ``` 33 | 34 | *Pasteboard and Snips* 35 | 36 | The basic Racket control and canvas toolkit suffices for the seven GUIs 37 | challenges. Working through these examples provides a good first impression 38 | of its power, though for a thorough explanation I recommend the Racket 39 | documentation. 40 | 41 | For sophisticated GUI applications, Racket supports pasteboard and snip 42 | widgets. Alex Harsányi has written up a [beautiful 43 | introduction](https://alex-hhh.github.io/2018/10/chess-game-using-racket-s-pasteboard.html) 44 | on this topic. 45 | 46 | ### [Macros](Macros/) 47 | 48 | The `Macros/` directory shows how to develop macros that help clarify what's 49 | happening in the primitive implementations. using macros also reduces the 50 | length of the implementation, though by a constant amount. For the small 51 | problems, this reduction looks like a lot; for the larger one it is not 52 | worth mentioning. 53 | 54 | Still, reformulating the implementations with better "notation" uncovered a 55 | couple of small bugs. See [README](Macros/README.md). 56 | 57 | 58 | ### [Types](Types/) 59 | 60 | The `Types/` directory demonstrates what it takes to add types to the 61 | simple implementations. The overhead is small for five of the seven tasks, 62 | non-trivial for the other two. 63 | 64 | The use of macros to define families of type families is a great 65 | illustration of how Racket tools compose in a powerful synthesis. 66 | 67 | The addition of types points to small inconsistencies and revealed one 68 | misconception about a callback. 69 | 70 | It also brought home that we need a guide for program conversions. 71 | 72 | ### TO DO 73 | 74 | - a proper MVC organization 75 | - separate pieces 76 | - propagate REPL changes to model 77 | - a unit-based organization of the MVC code with demos of how to replace 78 | the model or the view 79 | 80 | - a unit-based organization .. with types 81 | 82 | ### Questions To Be Explored 83 | 84 | - is there a framework hidden? 85 | - is there a embedded DSL hidden? 86 | - would Syndicate help? 87 | 88 | ### BUGS 89 | 90 | - the redo for re-size in circle drawer could be a bug but the 91 | specification is underwhelming so I am not sure 92 | 93 | ### Acknowledgments 94 | 95 | [Jun 20, 2019] Will Byrd reported three bugs: 96 | 97 | - [typos](https://github.com/mfelleisen/7GUI/commit/f90261a6790ed34f08afeb42f33e1fa646e7b543) 98 | - [geometry mismanagement](https://github.com/mfelleisen/7GUI/commit/c83ca4ccdbbc8e665019825c3280f9d5c003e146) 99 | - ['reading' numeric information from a text-field$](https://github.com/mfelleisen/7GUI/commit/13f00394789c21ae5dd9dd5bda003d449cdaf1f7) 100 | 101 | Asumu Takikawa explained `Class` again and how `init` works. 102 | 103 | Ben Greenman discovered that `augment` methods also need `public` 104 | specifications in `Class`. 105 | 106 | Sam Tobin-Hochstadt assisted with some non-Class-y aspects. 107 | 108 | 109 | For other small assists, see the [commit 110 | log](https://github.com/mfelleisen/7GUI/commits/master). 111 | -------------------------------------------------------------------------------- /Macros/7guis.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/gui 2 | 3 | (provide 4 | ;; SYNTAX 5 | #; {(define-gui name:id Title:expr [#:frame expr] Title:expr gui-spec)} 6 | ;; -- defines name to be a frame-based GUI according to the optional #:frame and gui-spec 7 | ;; 8 | #; {gui-spec == gui-element ... || (gui-element ...)} 9 | #; {gui-element == ([#:id x:id] w:expr [#:change x:id f:expr] [l:id l0:expr] ...) 10 | || (#:horizontal gui-element ...) 11 | || (#:vertical gui-element ...) } 12 | ;; an atomic gui-element creates a widget using (new w [l l0] ...); 13 | ;; if it comes with a #:id x, it is given the name x with the same scope as name 14 | ;; if it comes with a #:change x f, a change to the state of w triggers (set! x (f old-x this)) 15 | ;; a horizontal | vertical specification creates a horizontal | vertical pane for the nested elements 16 | 17 | #; {(gui [#:id id] [#:frame expr] Title:expr (state:id state:expr propagate:expr) gui-spec)} 18 | ;; like define-gui, but immediately shows the constructed frame 19 | 20 | define-gui 21 | 22 | gui 23 | 24 | ;; #:change comes with a bunch of samll auxiliaries to make it useful: 25 | 26 | ;; SYNTAX 27 | #; (with [#:post p:expr] [#:widget w:id] [#:method m] e ...) 28 | ;; a function uses 29 | ;; -- method m [get-value] to extract a value 30 | ;; -- from a GUI widget w [this] 31 | ;; -- post-processing it with p [identity] 32 | 33 | with 34 | 35 | ;; (All (X) [X -> X] -> [ X Any -> X]) 36 | ;; a wrapper for computing just the new value from the old one 37 | just 38 | 39 | ;; 40 | none) 41 | 42 | ;; --------------------------------------------------------------------------------------------------- 43 | (require (for-syntax syntax/parse)) 44 | 45 | (begin-for-syntax 46 | 47 | (define-syntax-class init 48 | #:description "name and value binding" 49 | (pattern (x:id e:expr))) 50 | 51 | (define-syntax-class gui-element 52 | #:description "gui element specification" 53 | (pattern ((~optional (~seq #:id x:id)) w:expr (~optional (~seq #:change s:id f:expr)) i:init ...)) 54 | (pattern (#:horizontal ge:gui-element ...)) 55 | (pattern (#:vertical ge:gui-element ...))) 56 | 57 | (define-syntax-class gui-spec 58 | #:description "gui specification" 59 | (pattern (ge:gui-element ...)))) 60 | 61 | (define-syntax (gui stx) 62 | (syntax-parse stx 63 | [(_ (~optional (~seq #:id x:id)) (~optional (~seq #:frame f)) T Vs ...) 64 | #'(begin (define-gui (~? x F) (~? (~@ #:frame f) (~@)) T Vs ...) (send (~? x F) show #t))])) 65 | 66 | (define-syntax (define-gui stx) 67 | (syntax-parse stx 68 | [(_ frame-name:id (~optional (~seq #:frame f%:expr)) T:expr Vs:gui-element ...) 69 | #'(begin 70 | (define frame-name (new (~? f% frame%) [label T] [width 200] [height 77])) 71 | (define pane (new vertical-pane% [parent frame-name])) 72 | (setup-visuals pane (Vs)) 73 | ...)] 74 | 75 | [(_ frame-name:id (~optional (~seq #:frame f%:expr)) Title:expr visuals:gui-spec) 76 | #'(begin 77 | (define frame-name (new (~? f% frame%) [label Title] [width 200] [height 77])) 78 | (setup-visuals frame-name visuals))])) 79 | 80 | (define-syntax-rule (setup-visuals container (gui-specs ...)) 81 | (gui-element container (#:horizontal gui-specs ...))) 82 | 83 | (define-syntax (gui-element stx) 84 | (syntax-parse stx 85 | [(_ p (#:horizontal b ...)) 86 | #'(begin (define horizontal (make-horizontal p)) (gui-element horizontal b) ...)] 87 | [(_ p (#:vertical b ...)) 88 | #'(begin (define vertical (make-vertical p)) (gui-element vertical b) ...)] 89 | [(_ p [(~optional (~seq #:id x:id)) w%:expr (~optional (~seq #:change s:id f:expr)) o:init ...]) 90 | #`(begin 91 | (~? (~@ (define g f)) (~@)) 92 | [define (~? x y) (new w% [parent p] 93 | (~? (~@ [callback 94 | (λ (self evt) 95 | (define new (g s self)) 96 | (unless (*none? new) (set! s new)))]) 97 | (~@)) 98 | o ...)])])) 99 | 100 | (define ((just f) old _self) (f old)) 101 | 102 | (define-syntax (with stx) 103 | (syntax-parse stx 104 | [(_ (values x:id ...) 105 | (~optional (~seq #:post f:expr)) 106 | (~optional (~seq #:widget ff:id)) 107 | (~optional (~seq #:method m:id)) 108 | e ...) 109 | #:with self (datum->syntax stx 'self) 110 | #`(let ([g (~? f values)]) 111 | (λ (_old self) 112 | (define-values (x ...) (g (send (~? ff self) (~? m get-value)))) 113 | e ...))] 114 | [(_ x:id 115 | (~optional (~seq #:post f:expr)) 116 | (~optional (~seq #:widget ff:id)) 117 | (~optional (~seq #:method m:id)) 118 | e ...) 119 | #:with self (datum->syntax stx 'self) 120 | #`(let ([g (~? f values)]) 121 | (λ (_old self) 122 | (define x (g (send (~? ff self) (~? m get-value)))) 123 | e ...))])) 124 | 125 | (struct *none ()) 126 | (define none (*none)) 127 | 128 | (define (make-horizontal p) (new horizontal-pane% [parent p][alignment '(center center)])) 129 | (define (make-vertical p) (new vertical-pane% [parent p][alignment '(center center)])) 130 | -------------------------------------------------------------------------------- /Macros/task-6.rkt: -------------------------------------------------------------------------------- 1 | #! /usr/bin/env gracket 2 | #lang at-exp racket/gui 3 | 4 | ;; a circle drawer with undo/redo facilities (unclear spec for resizing) 5 | 6 | ;; --------------------------------------------------------------------------------------------------- 7 | (require 7GUI/Macros/7guis 7GUI/Macros/7state 7GUI/should-be-racket) 8 | 9 | ;; --------------------------------------------------------------------------------------------------- 10 | (define Default-Diameter 20) 11 | 12 | (struct circle (x y d action) #:transparent) 13 | 14 | (define (draw-1-circle dc brush c) 15 | (match-define (circle x y d _a) c) 16 | (send dc set-brush brush) 17 | (define r (/ d 2)) 18 | (send dc draw-ellipse (- x r) (- y r) d d)) 19 | 20 | (define-state *circles '() (lambda (x) (send canvas on-paint))) 21 | 22 | (define-state *history '() (lambda (x) (send canvas on-paint))) 23 | 24 | (define (add-circle! x y) 25 | (define added (circle x y Default-Diameter 'added)) 26 | (set! *circles (cons added *circles))) 27 | 28 | (define (resize! old-closest new-d) 29 | (match-define (circle x y d a) old-closest) 30 | (define resized 31 | (match a 32 | ['added (circle x y new-d `(resized (,d)))] 33 | [`(resized . ,old-sizes) (circle x y new-d `(resized ,(cons d old-sizes)))])) 34 | (set! *circles (cons resized (remq old-closest *circles)))) 35 | 36 | (define (undo) 37 | (when (cons? *circles) 38 | (define fst (first *circles)) 39 | (match fst 40 | [(circle x y d 'added) (set! *circles (rest *circles))] 41 | [(circle x y d `(resized (,r0 . ,sizes))) 42 | (set! *circles (cons (circle x y r0 `(resized (,d))) (rest *circles)))]) 43 | (set! *history (cons fst *history)))) 44 | 45 | (define (redo) 46 | (when (cons? *history) 47 | (define fst (first *history)) 48 | (if (eq? (circle-action fst) 'added) 49 | (set!-values (*circles *history) (values (cons fst *circles) (rest *history))) 50 | (set!-values (*circles *history) (values (cons fst (rest *circles)) (rest *history)))))) 51 | 52 | (define (the-closest xm ym (circles *circles)) 53 | (define cdistance (distance xm ym)) 54 | (define-values (good-circles distance*) 55 | (for*/fold ([good-circles '()][distance* '()]) 56 | ((c circles) (d (in-value (cdistance c))) #:when (< d (/ (circle-d c) 2))) 57 | (values (cons c good-circles) (cons d distance*)))) 58 | (and (cons? distance*) (first (argmin second (map list good-circles distance*))))) 59 | 60 | (define (is-empty-area xm ym (circles *circles)) 61 | (define dist (distance xm ym)) 62 | (for/and ((c circles)) (> (dist c) (/ (+ (circle-d c) Default-Diameter) 2)))) 63 | 64 | ;; N N (Circle -> Real] 65 | (define ((distance xm ym) c) 66 | (match-define (circle xc yc _d _a) c) 67 | (sqrt (+ (expt (- xc xm) 2) (expt (- yc ym) 2)))) 68 | 69 | ;; --------------------------------------------------------------------------------------------------- 70 | (define solid-gray (new brush% [color "gray"])) 71 | (define white-brush (new brush% [color "white"])) 72 | 73 | (define circle-canvas% 74 | (class canvas% 75 | (define *in-adjuster #f) ;; we can get a quasi-modal dialog this way 76 | (define/public (unlock) (set! *in-adjuster #f)) 77 | (define/private (lock) (set! *in-adjuster #t)) 78 | 79 | (define-state *x 0 (λ (x) (send this on-paint))) 80 | (define-state *y 0 values) 81 | 82 | (define/override (on-event evt) 83 | (unless *in-adjuster 84 | (define type (send evt get-event-type)) 85 | (set! *x (send evt get-x)) 86 | (set! *y (send evt get-y)) 87 | (case type 88 | [(leave) (set! *x #f)] 89 | [(enter) (set! *x 0)] 90 | [(left-down) (when (is-empty-area *x *y) (add-circle! *x *y))] 91 | [(right-down) 92 | (when* (the-closest *x *y) => (lambda (it) (lock) (popup-adjuster this it)))]))) 93 | 94 | (define (paint-callback _self _evt) 95 | (cond 96 | [(empty? *circles) (send (send this get-dc) clear)] 97 | [(boolean? *x) (draw-circles #f)] 98 | [else (draw-circles (the-closest *x *y))])) 99 | 100 | (define/public (draw-circles closest (others-without-closest #f)) 101 | (send dc clear) 102 | (for ((c (or others-without-closest *circles))) (draw-1-circle dc white-brush c)) 103 | (when closest (draw-1-circle dc solid-gray closest))) 104 | 105 | (super-new [paint-callback paint-callback]) 106 | 107 | (define dc (send this get-dc)))) 108 | 109 | (define (popup-adjuster canvas closest-circle) 110 | (define (cb _ evt) (when (eq? (send evt get-event-type) 'menu-popdown-none) (send canvas unlock))) 111 | (define pm (new popup-menu% [title "adjuster"][popdown-callback cb])) 112 | (new menu-item% [parent pm] [label "adjust radius"] [callback (adjuster! canvas closest-circle)]) 113 | (send frame popup-menu pm 100 100)) 114 | 115 | (define ((adjuster! canvas closest-circle) . x) 116 | (match-define (circle x0 y0 d0 _a) closest-circle) 117 | (define others (remq closest-circle *circles)) 118 | (define-state *d d0 (λ (d) (send canvas draw-circles (circle x0 y0 d '_ephemeral_) others))) 119 | 120 | (define adjuster-dialog% 121 | (class frame% 122 | (define/augment (on-close) (send canvas unlock) (resize! closest-circle *d)) 123 | (super-new))) 124 | 125 | (define a-slider% (class slider% (super-new [label ""] [min-value 10] [max-value 100]))) 126 | (define title (format "Adjust radius of circle at (~a,~a)" x0 y0)) 127 | (gui #:frame adjuster-dialog% title (a-slider% #:change *d (with id id) [init-value d0]))) 128 | 129 | ;; --------------------------------------------------------------------------------------------------- 130 | (define-gui frame "Circle Drawer" 131 | (#:horizontal 132 | (button% [label "Undo"][callback (λ _ (undo))]) (button% [label "Redo"][callback (λ _ (redo))])) 133 | (#:id canvas circle-canvas% [min-height 400][min-width 400][style '(border)])) 134 | 135 | (send frame show #t) 136 | -------------------------------------------------------------------------------- /task-6.rkt: -------------------------------------------------------------------------------- 1 | #! /usr/bin/env gracket 2 | #lang at-exp racket/gui 3 | 4 | ;; a circle drawer with undo/redo facilities (unclear spec for resizing) 5 | 6 | ;; --------------------------------------------------------------------------------------------------- 7 | (define Default-Diameter 20) 8 | 9 | (struct circle (x y d action) #:transparent) 10 | 11 | (define (draw-1-circle dc brush c) 12 | (match-define (circle x y d _a) c) 13 | (send dc set-brush brush) 14 | (define r (/ d 2)) 15 | (send dc draw-ellipse (- x r) (- y r) d d)) 16 | 17 | (define *circles '()) 18 | 19 | (define *history '()) 20 | 21 | (define (add-circle! x y) 22 | (define added (circle x y Default-Diameter 'added)) 23 | (set! *circles (cons added *circles))) 24 | 25 | (define (resize! old-closest new-d) 26 | (match-define (circle x y d a) old-closest) 27 | (define resized 28 | (match a 29 | ['added (circle x y new-d `(resized (,d)))] 30 | [`(resized . ,old-sizes) (circle x y new-d `(resized ,(cons d old-sizes)))])) 31 | (set! *circles (cons resized (remq old-closest *circles)))) 32 | 33 | (define (undo) 34 | (when (cons? *circles) 35 | (define fst (first *circles)) 36 | (match fst 37 | [(circle x y d 'added) (set! *circles (rest *circles))] 38 | [(circle x y d `(resized (,r0 . ,sizes))) 39 | (set! *circles (cons (circle x y r0 `(resized (,d))) (rest *circles)))]) 40 | (set! *history (cons fst *history)))) 41 | 42 | (define (redo) 43 | (when (cons? *history) 44 | (define fst (first *history)) 45 | (if (eq? (circle-action fst) 'added) 46 | (set!-values (*circles *history) (values (cons fst *circles) (rest *history))) 47 | (set!-values (*circles *history) (values (cons fst (rest *circles)) (rest *history)))))) 48 | 49 | (define (the-closest xm ym (circles *circles)) 50 | (define cdistance (distance xm ym)) 51 | (define-values (good-circles distance*) 52 | (for*/fold ([good-circles '()][distance* '()]) 53 | ((c circles) (d (in-value (cdistance c))) #:when (< d (/ (circle-d c) 2))) 54 | (values (cons c good-circles) (cons d distance*)))) 55 | (and (cons? distance*) (first (argmin second (map list good-circles distance*))))) 56 | 57 | (define (is-empty-area xm ym (circles *circles)) 58 | (define dist (distance xm ym)) 59 | (for/and ((c circles)) (> (dist c) (/ (+ (circle-d c) Default-Diameter) 2)))) 60 | 61 | ;; N N (Circle -> Real] 62 | (define ((distance xm ym) c) 63 | (match-define (circle xc yc _d _a) c) 64 | (sqrt (+ (expt (- xc xm) 2) (expt (- yc ym) 2)))) 65 | 66 | ;; --------------------------------------------------------------------------------------------------- 67 | (define solid-gray (new brush% [color "gray"])) 68 | (define white-brush (new brush% [color "white"])) 69 | 70 | (define circle-canvas% 71 | (class canvas% 72 | (inherit on-paint get-dc) 73 | 74 | (define *in-adjuster #f) ;; we can get a quasi-modal dialog this way 75 | (define/public (unlock) (set! *in-adjuster #f)) 76 | (define/private (lock) (set! *in-adjuster #t)) 77 | 78 | (define *x 0) 79 | (define *y 0) 80 | 81 | (define/override (on-event evt) 82 | (unless *in-adjuster 83 | (define type (send evt get-event-type)) 84 | (set! *x (send evt get-x)) 85 | (set! *y (send evt get-y)) 86 | (cond 87 | [(eq? 'leave type) (set! *x #f)] 88 | [(eq? 'enter type) (set! *x 0)] 89 | [(and (eq? 'left-down type) (is-empty-area *x *y)) (add-circle! *x *y)] 90 | [(and (eq? 'right-down type) (the-closest *x *y)) => (λ (tc) (lock) (popup-adjuster tc))]) 91 | (paint-callback this 'y))) 92 | 93 | (define (paint-callback _self _evt) 94 | (cond 95 | [(empty? *circles) (send (send this get-dc) clear)] 96 | [(boolean? *x) (draw-circles #f)] 97 | [else (draw-circles (the-closest *x *y))])) 98 | 99 | (define/public (draw-circles closest (others-without-closest #f)) 100 | (define dc (get-dc)) 101 | (send dc clear) 102 | (for ((c (or others-without-closest *circles))) (draw-1-circle dc white-brush c)) 103 | (when closest (draw-1-circle dc solid-gray closest))) 104 | 105 | (super-new [paint-callback paint-callback]))) 106 | 107 | (define (popup-adjuster closest-circle) 108 | (define (cb _ evt)(when (eq? (send evt get-event-type) 'menu-popdown-none) (send canvas unlock))) 109 | (define pm (new popup-menu% [title "adjuster"][popdown-callback cb])) 110 | (new menu-item% [parent pm] [label "adjust radius"] [callback (adjuster! closest-circle)]) 111 | (send frame popup-menu pm 100 100)) 112 | 113 | (define ((adjuster! closest-circle) . x) 114 | (define d0 (circle-d closest-circle)) 115 | (define frame (new adjuster-dialog% [closest-circle closest-circle])) 116 | (new adjuster-slider% [parent frame][init-value d0][update (λ (x) (send frame continuous x))]) 117 | (send frame show #t)) 118 | 119 | (define adjuster-dialog% 120 | (class frame% (init-field closest-circle) 121 | (match-define (circle x* y* *d _a) closest-circle) 122 | (define others (remq closest-circle *circles)) 123 | 124 | (define/public (continuous new-d) ;; resize locally while adjusting 125 | (set! *d new-d) 126 | (send canvas draw-circles (circle x* y* *d '_dummy_) others)) 127 | 128 | (define/augment (on-close) ;; resize globally 129 | (send canvas unlock) 130 | (resize! closest-circle *d)) 131 | 132 | (super-new [label (format "Adjust radius of circle at (~a,~a)" x* y*)]))) 133 | 134 | (define adjuster-slider% 135 | (class slider% (init-field update) 136 | (inherit get-value) 137 | (super-new [label ""][min-value 10][max-value 100][callback (λ _ (update (get-value)))]))) 138 | 139 | ;; --------------------------------------------------------------------------------------------------- 140 | (define frame (new frame% [label "Circle Drawer"][width 400])) 141 | (define hpane1 (new horizontal-pane% [parent frame][min-height 20][alignment '(center center)])) 142 | (new button% [label "Undo"][parent hpane1][callback (λ _ (undo) (send canvas on-paint))]) 143 | (new button% [label "Redo"][parent hpane1][callback (λ _ (redo) (send canvas on-paint))]) 144 | (define hpane2 (new horizontal-panel% [parent frame][min-height 400][alignment '(center center)])) 145 | (define canvas (new circle-canvas% [parent hpane2][style '(border)])) 146 | 147 | (send frame show #t) 148 | -------------------------------------------------------------------------------- /Typed/task-6.rkt: -------------------------------------------------------------------------------- 1 | #! /usr/bin/env gracket 2 | #lang typed/racket/gui 3 | 4 | ;; a circle drawer with undo/redo facilities (unclear spec for resizing) 5 | 6 | ;; --------------------------------------------------------------------------------------------------- 7 | (require 7GUI/Typed/sub-frame 7GUI/Typed/sub-canvas) 8 | 9 | ;; --------------------------------------------------------------------------------------------------- 10 | (define Default-Diameter 20) 11 | 12 | (define-type Action (U Symbol [List Symbol [Listof Natural]])) 13 | (struct circle ({x : Integer} {y : Integer} {d : Natural} {action : Action}) #:transparent) 14 | 15 | (: draw-1-circle (-> (Instance DC<%>) (Instance Brush%) circle Void)) 16 | (define (draw-1-circle dc brush c) 17 | (match-define (circle x y d _a) c) 18 | (send dc set-brush brush) 19 | (define r (/ d 2)) 20 | (send dc draw-ellipse (- x r) (- y r) r r)) 21 | 22 | (: *circles [Listof circle]) 23 | (define *circles '()) 24 | 25 | (: *history [Listof circle]) 26 | (define *history '()) 27 | 28 | (: add-circle! (-> Integer Integer Void)) 29 | (define (add-circle! x y) 30 | (define added (circle x y Default-Diameter 'added)) 31 | (set! *circles (cons added *circles))) 32 | 33 | (: resize! (-> circle Natural Void)) 34 | (define (resize! old-closest new-d) 35 | (match-define (circle x y d a) old-closest) 36 | (define resized 37 | (match a 38 | ['added (circle x y new-d `(resized (,d)))] 39 | [`(resized ,old-sizes) (circle x y new-d `(resized ,(cons d old-sizes)))])) 40 | (set! *circles (cons resized (remq old-closest *circles)))) 41 | 42 | (define (undo) : Void 43 | (when (cons? *circles) 44 | (define fst (first *circles)) 45 | (match fst 46 | [(circle x y d 'added) (set! *circles (rest *circles))] 47 | [(circle x y d `(resized (,r0 . ,sizes))) 48 | (set! *circles (cons (circle x y r0 'added) (rest *circles)))]) 49 | (set! *history (cons fst *history)))) 50 | 51 | (define (redo) : Void 52 | (when (cons? *history) 53 | (define fst (first *history)) 54 | (if (eq? (circle-action fst) 'added) 55 | (set!-values (*circles *history) (values (cons fst *circles) (rest *history))) 56 | (set!-values (*circles *history) (values (cons fst (rest *circles)) (rest *history)))))) 57 | 58 | (: the-closest (->* (Integer Integer) ([Listof circle]) (U False circle))) 59 | (define (the-closest xm ym (c* *circles)) 60 | (define cdistance (distance xm ym)) 61 | (define-values (good-circles distance*) 62 | (for*/fold ([good-circles : [Listof circle] '()][distance* : [Listof Real] '()]) 63 | ((c : circle c*) (d : Real (in-value (cdistance c))) #:when (< d (/ (circle-d c) 2))) 64 | (values (cons c good-circles) (cons d distance*)))) 65 | (and (cons? distance*) (first (&argmin second (&map &list good-circles distance*))))) 66 | (define &argmin (inst argmin (List circle Real))) 67 | (define &map (inst map (List circle Real) circle Real)) 68 | (define &list (λ ({c : circle} {r : Real}) (list c r))) 69 | 70 | (: is-empty-area (->* (Integer Integer) ([Listof circle]) Boolean)) 71 | (define (is-empty-area xm ym (circles *circles)) 72 | (define dist (distance xm ym)) 73 | (for/and ((c circles)) (> (dist c) (/ (+ (circle-d c) Default-Diameter) 2)))) 74 | 75 | (: distance (-> Integer Integer (-> circle Real))) 76 | (define ((distance xm ym) c) 77 | (match-define (circle xc yc _d _a) c) 78 | (sqrt (+ (sqr (- xc xm)) (sqr (- yc ym))))) 79 | 80 | ;; --------------------------------------------------------------------------------------------------- 81 | (define GRAY (new brush% [color "gray"])) 82 | (define WHITE (new brush% [color "white"])) 83 | 84 | (define-type-canvas Circle-Canvas% 85 | #:minus-init (paint-callback) 86 | (unlock (-> Void)) 87 | (draw-circles (->* ( {U False circle} ) ( [U False (Listof circle)]) Void))) 88 | 89 | (define circle-canvas% : Circle-Canvas% 90 | (class canvas% 91 | (define *in-adjuster : Boolean #f) ;; we can get a quasi-modal dialog this way 92 | (define/public (unlock) : Void (set! *in-adjuster #f)) 93 | (define/private (lock) : Void (set! *in-adjuster #t)) 94 | 95 | (define inside : Boolean #t) 96 | (define *x 0) 97 | (define *y 0) 98 | 99 | (define/override (on-event evt) : Void 100 | (unless *in-adjuster 101 | (define type (send evt get-event-type)) 102 | (set! *x (send evt get-x)) 103 | (set! *y (send evt get-y)) 104 | (cond 105 | [(eq? 'leave type) (set! inside #f)] 106 | [(eq? 'enter type) (set! inside #t)] 107 | [(and (eq? 'left-down type) (is-empty-area *x *y)) (add-circle! *x *y)] 108 | [(and (eq? 'right-down type) (the-closest *x *y)) => (λ (tc) (lock) (popup-adjuster tc))]) 109 | (send this on-paint))) 110 | 111 | (define/public (draw-circles closest (others-without-closest #f)) 112 | (define dc : (Instance DC<%>) (send (cast this (Instance Canvas%)) get-dc)) 113 | (send dc clear) 114 | (for ((c : circle (in-list (or others-without-closest *circles)))) (draw-1-circle dc WHITE c)) 115 | (when closest (draw-1-circle dc GRAY closest))) 116 | 117 | (define (paint-callback {_self : (Instance Canvas%)} {dc : (Instance DC<%>)}) : Any 118 | (if (empty? *circles) (send dc clear) (draw-circles (and inside (the-closest *x *y))))) 119 | 120 | (super-new [paint-callback paint-callback]))) 121 | 122 | (: popup-adjuster (-> circle Void)) 123 | (define (popup-adjuster closest-circle) 124 | (define (cb {_ : Any} {evt : (Instance Control-Event%)}) : Void 125 | (when (eq? (send evt get-event-type) 'menu-popdown-none) (send canvas unlock))) 126 | (define pm (new popup-menu% [title "adjuster"][popdown-callback cb])) 127 | (new menu-item% [parent pm] [label "adjust radius"] [callback (adjuster! closest-circle)]) 128 | (send frame popup-menu pm 100 100)) 129 | 130 | (: adjuster! (-> circle (->* () () #:rest Any Void))) 131 | (define ((adjuster! closest-circle) . x) 132 | (define d0 (circle-d closest-circle)) 133 | (define frame (new adjuster-dialog% [closest-circle closest-circle])) 134 | (define adjcb (λ (x) (send frame continuous (cast x Natural)))) 135 | (define slide (new adjuster-slider% [parent frame][init-value d0][update adjcb])) 136 | (send frame show #t)) 137 | 138 | (define-type-frame Adjuster-Dialog% 139 | #:minus-init (label) 140 | (init-field {closest-circle circle}) 141 | (continuous (-> Natural Void))) 142 | 143 | (define adjuster-dialog% : Adjuster-Dialog% 144 | (class frame% (init-field closest-circle) 145 | ;; the next 3 are needed to get rid of error that says missing type for closest-circle 146 | (: x* Integer) 147 | (: y* Integer) 148 | (: *d Natural) 149 | (match-define (circle x* y* *d _) closest-circle) 150 | 151 | (: others (Listof circle)) 152 | (define others (remq closest-circle *circles)) 153 | 154 | (define/public (continuous new-d) ;; resize locally while adjusting 155 | (set! *d new-d) 156 | (send canvas draw-circles (circle x* y* *d '_dummy_) others)) 157 | 158 | (define/augment (on-close) ;; resize globally 159 | (send canvas unlock) 160 | (resize! closest-circle *d)) 161 | 162 | (super-new [label (format "Adjust radius of circle at (~a,~a)" x* y*)]))) 163 | 164 | (define adjuster-slider% 165 | (class slider% (init-field (update : (-> Any Void))) 166 | (inherit get-value) 167 | (super-new [label ""][min-value 10][max-value 100][callback (λ _ (update (get-value)))]))) 168 | 169 | ;; --------------------------------------------------------------------------------------------------- 170 | (define frame (new frame% [label "Circle Drawer"][width 400])) 171 | (define hpane1 (new horizontal-pane% [parent frame][min-height 20][alignment '(center center)])) 172 | (new button% [label "Undo"][parent hpane1][callback (λ _ (undo) (send canvas on-paint))]) 173 | (new button% [label "Redo"][parent hpane1][callback (λ _ (redo) (send canvas on-paint))]) 174 | (define hpane2 (new horizontal-panel% [parent frame][min-height 400][alignment '(center center)])) 175 | (define canvas (new circle-canvas% [parent hpane2][style '(border)])) 176 | 177 | (send frame show #t) 178 | -------------------------------------------------------------------------------- /Typed/README.md: -------------------------------------------------------------------------------- 1 | ## Adding Types to the Primitive GUI Solution 2 | 3 | The files in this directory re-implement the "7 GUIs" task in Typed Racket, 4 | using the power of *migratory* typing. 5 | 6 | - `task 1`: a single type annotation for a callback function suffices 7 | - `task 2`: needs some type definitions and types for a widget element generator 8 | - `from-string`: needs a simple string to exact integer converter module, 9 | which Typed Racket should just provide 10 | - `task 3`: like task 2 11 | - `gregor`: needs an adapter module for a library (whose code we don't want to re-write) 12 | - `task 4`: `timer%` needs a type surprisingly 13 | - `task 5`: a macro generates typed functions! 14 | 15 | So far so good. 16 | 17 | - `task 6`: needs two new modules: 18 | - `sub-frame`: a module that abstracts over the type of `frame%` for sub-typing the class 19 | - `sub-canvas`: a module that abstracts over the type of `canvas%` for sub-typing the class 20 | - `task 7`: needs the two new modules plus the adapter modules for 21 | - `task-7-exp`: TODO I think I should be able to eliminate Letter 22 | - `task-7-view`: showcases the simplicity of writing adapters 23 | - `canvas-double-click`: Typed Racket deals well with augmentation! (see below) 24 | 25 | It is because of the type system's expressive power that we just need type 26 | adapter modules for these three files (which are inessential to the tasks 27 | or should have been provided by Racket's base library). 28 | 29 | ## The Experience 30 | 31 | From the design perspective, adding types was less useful than exploiting 32 | more of Racket's macro power. See [Macros/README](../Macros/README.md). But 33 | it wasn't useless. 34 | 35 | From the "gradual typing" perspective, the experience started at amazing 36 | high points but eventually deteriorated into one of pure pain for a number 37 | of reasons. 38 | 39 | ### DESIGN Issues With My Original Code 40 | 41 | Two small issues showed up during the conversion so far: 42 | 43 | 1. The type checker could not figure out that my flight-booker program 44 | (task 3) guarantees the existence of a selection in the `*kind` choice 45 | field. Since this isn't always the case, the probe for a selection may 46 | produce `#f` and the types for this method exposed the problem: 47 | 48 | ``` 49 | ((inst list-ref String) CHOICES (if self (or (send self get-selection) 0) 0))) 50 | ``` 51 | 52 | 2. Using a variable to record both "the mouse is inside some area and this 53 | is its x coordinate" works well in Untyped code but for Types you're better 54 | off with splitting this into two variables. (It added a variable 55 | declaration and simplified a method, a lot.) 56 | 57 | 3. Adding types made me discover that the paint callback in a canvas 58 | receives the drawing context as the second argument, so there's no need to 59 | retrieve it with a `send`. The code wasn't wrong to say the second argument 60 | is `Any`, but figuring out what it was was a "good thing". 61 | 62 | 4. I could not figure out how to get an `Exact-Rational` from a string so I 63 | used a `cast`: 64 | 65 | ``` 66 | (and r (if (real? r) (cast r Exact-Rational) #f) 67 | ``` 68 | I'll have to dig into this. ~~ **Thanks to Sam TH for helping me fix 69 | this.** 70 | 71 | Working on this problem (see `from-string`) also made me realize that my 72 | untyped Celsius converter had no problem dealing with `Complex` Celsius 73 | degrees. And they seem to come out as `Complex` Fahrenheit degrees. Now I 74 | don't know about you, but I have no problems with `Complex` Celsius. But my 75 | types did; so I switched to `Real`. 76 | 77 | ### GRADUAL TYPING: Easy Type Injections 78 | 79 | Injection types into tasks 1 through 5 is easy. 80 | 81 | The addition of types typically requires 82 | 83 | - a change to the language line of the module 84 | - a small number of type annotations 85 | 86 | Even though, the type checker is of little help with the conversion. When 87 | the #lang line is changed to typed/racket/gui, the type checker tends to 88 | request type information about the gui elements, defined at the bottom of 89 | the program. As the converted programs show, however, adding types to the 90 | callback functions suffices to make the type checker happy ... and this 91 | doesn't seem to take more effort than a handful of lines. 92 | 93 | I encountered two exceptions to this rule: 94 | 95 | 1. I introduced a typed adapter module for `gregor`, which is not 96 | surprising for a library. 97 | 98 | 2. I added another adapter module, `from-string`, for converting strings to 99 | "rational" numbers. We should probably have more of those for Typed Racket. 100 | 101 | ### GRADUAL TYPING: Non-trivial Type Injection 102 | 103 | Converting `task-6` and `task-7` demonstrate in many ways that type 104 | injection is **really truly hard**. The Typed Racket documentation is much 105 | less helpful than the Racket one: 106 | 107 | - it lacks the definitions of types 108 | - it lacks signature definitions for functions 109 | 110 | Use `(:type f)` instead to figure out the type of `f` and work with 111 | this. It isn't a perfect replacement for documented type signatures. 112 | 113 | - It lacks explanations of unusual ideas about types (say, that a Class 114 | type is really a sub-classing specification). 115 | 116 | *Note* A Class type is a specification for sub-classing. So when a Class 117 | type includes an `init` specification for, say, `label` it cannot be used 118 | with `super-new` --- because that makes it unavailable to its sub-class. 119 | 120 | ### Two Important Ideas That Help With Adding Types 121 | 122 | When it came to porting `task-6` and `task-7`, I wasn't particularly clever 123 | about my work. The ease of porting `task-1` to `task-5` had lulled me into 124 | thinking that it was going to be a breeze. 125 | 126 | So, the very moment when you change `typed/racket/gui' and `drracket` says 127 | "you have 35 type errors", switch to "clever working mode", and here are 128 | two important hints for this. 129 | 130 | #### Move Self-Contained Pieces of Code to a Separate Buffer 131 | 132 | Moving from Racket to Typed Racket demands the conversion of entire 133 | modules. But, due to various factors, expansion plus type checking is 134 | relatively slow. At the same time, it may take many rounds of 135 | experimentation to get the types right for some expression. 136 | 137 | [[ In the research world, I'd say Typed Racket's "macro" gradual typing 138 | becomes inconvenient for certain tasks. "Micro" gradual typing is clearly 139 | superior for the conversion task, except that it is easy to end up with 140 | types that express much less than the programmer has in mind. ]] 141 | 142 | Break out self-contained pieces of code and deal with them in a separate, 143 | temporary file. 144 | 145 | Here is an example from `task-7` that took me forever to get right: 146 | 147 | ``` 148 | (define-syntax-rule (define-getr name : ResultType HashType (*source selector default)) 149 | (begin 150 | (: name (-> Letter Index ResultType)) 151 | (define (name letter index) ; (source *source) (result->type selector)) 152 | (define f ((inst hash-ref Ref HashType) *source (list letter index) #f)) 153 | (if f (selector f) default)))) 154 | ``` 155 | 156 | This macro comes with several uses at distinct types, and getting 157 | `hash-ref` to work properly here took quite some work. For example, you 158 | might think that `#f` could be replaced with a proper value of type 159 | `HashType` so that the last line could be replaced with 160 | 161 | ``` 162 | (selector f) 163 | ``` 164 | 165 | but I did not get this to work (in Typed-land. See Macro-land for how to do 166 | this properly.) 167 | 168 | So to get this to work, I copied the macro, its uses, its free variables, 169 | the `#lang` line and all the `require` lines into a separate window. This 170 | sped up the fixing project tremendously. 171 | 172 | #### How to Develop a Class Type for Classes Derived from Racket GUI Classes 173 | 174 | When you derive a class from one of Racket's built-in classes and you need 175 | a type for this derived class, things get complicated. They get especially 176 | complicated for GUI widget classes, because they come with dozens of 177 | `init' parameters, fields, and methods. 178 | 179 | For adding types to `task-6`, I discovered the need for `Class` types for 180 | `circle-canvas%` and `adjuster-dialog%`, the classes derived from `canvas%` 181 | and `frame%`, respectively. Take a look at the result: 182 | 183 | - [sub-frame](sub-frame.rkt), which exports a macro for a defining a Class 184 | type for sub-classes of `frame%` 185 | 186 | - [sub-canvas](sub-canvas.rkt), which exports a macro for a defining a Class 187 | type for sub-classes of `canvas%` 188 | 189 | Here is what you need to know. A Class type specifies the interface for 190 | sub-classing. While the `#:implements` clause takes care of inherited 191 | methods (and fields), initial parameters and initial fields need to be 192 | specified again. See Asumu's comment in [sub-canvas](sub-canvas.rkt) for 193 | an explanation. 194 | 195 | Eventually I figured out a good way to produce this `Class` type. 196 | 197 | - first, use `:type` to retrieve the specifications of the super-class: 198 | 199 | ``` 200 | > (:type frame%) 201 | (Class ...) 202 | ``` 203 | 204 | - second, copy and paste the init parts of the type into `drracket` 205 | 206 | - third, subtract the init parameters and init fields that your derived 207 | class supplies via `super-new` because they are no longer available for 208 | configuration from outside the class (well, ...) 209 | 210 | - fourth, add type specifications for the newly introduced public methods 211 | (and fields). 212 | 213 | If you anticipate to re-use this type again, abstract over it with a 214 | macro. And after some reflection I had to do just this: 215 | 216 | - [sub](sub.rkt) is a macro that generates a macro for abstracting over 217 | sub-Class type definitions. Think of it as a family of type families. 218 | 219 | - [sub-canvas](sub-canvas.rkt) uses this macro to define a family of 220 | sub-types from which clients can subtract init fields and add method 221 | specifications. 222 | 223 | - [rask 6](task-6.rkt) instantiates this type family with a subtraction of 224 | the `paint-callback` `init` field {see line 85} and the addition of two 225 | method specifications. 226 | 227 | - [canvas-double-click](canvas-double-click.rkt) instantiates this type 228 | family again, with the addition of four missing types for `Canvas%` 229 | (which slipped in after the creation of Class types for Racket's GUI 230 | widgets; see below), the addition of two augmentable methods and the 231 | addition of an augmentation specification for `on-event`. It does *not* 232 | subtract any `init` fields, in particular because the derivation of 233 | `cells-canvas%` in [task 7](task-7.rkt) {line 52} must supply this `init` 234 | parameter. 235 | 236 | - [sub-frame](sub-frame.rkt) uses the instantiates the family of 237 | type-families again, for `Frame%`. 238 | 239 | This macro-generating type-generating macro has thus far been the highlight 240 | of the Typed Racket development. 241 | 242 | ### Issues With Typed Racket 243 | 244 | 1. Our `match-define` does not deal with type annotations on pattern 245 | variables. I opened an issue on this (#829). 246 | 247 | 2. Typed Racket's compose can't deal with multiple argument functions: 248 | 249 | ``` 250 | ((inst compose Number Number Number) add1 (λ (x y) (+ x y))) 251 | ``` 252 | 253 | 3. It turns out that adding augmentable method (see above) to the `canvas%` 254 | class uncovered missing method type specifications: 255 | ``` 256 | (define-type-canvas Canvas-Double-Click% 257 | (vert-margin (->* () (Integer) Void)) 258 | (horiz-margin (->* () (Integer) Void)) 259 | (get-scaled-client-size (-> (Values Integer Integer))) 260 | (get-gl-client-size (-> (Values Integer Integer))) 261 | ...) 262 | ``` 263 | 264 | [augment (on-event (-> (Instance Mouse-Event%) Void))] 265 | 266 | 267 | 4. A small issue came up when I expanded on the gradual approach to typing: 268 | It turns out that Typed Racket demands a duplicate specification of `pubment` methods: 269 | 270 | ``` 271 | (define-type-canvas Canvas-Double-Click% 272 | (on-click (-> Natural Natural Void)) 273 | (on-double-click (-> Natural Natural Void)) 274 | 275 | [augment (on-click (-> Natural Natural Void))] 276 | [augment (on-double-click (-> Natural Natural Void))]) 277 | ``` 278 | 279 | See [canvas-double-click](canvas-double-click.rkt) for details. We should 280 | have macros that expand inside Typed Racket's types so that we could build 281 | an abstraction over this ourselves. 282 | 283 | ### An Additional Insight About Typed Racket 284 | 285 | It is pretty cool how macros inside of a to-be-converted module can be made 286 | to work with types: 287 | 288 | ``` 289 | (define-syntax-rule (def-cb (name {x : T}) exp ...) 290 | (define (name {x : (U String T)} {_y : Any}) : Void exp ... (send lbox set *selected))) 291 | ``` 292 | 293 | ### TODO 294 | 295 | - explore the use of [type expander](https://github.com/jsmaniac/type-expander) 296 | --------------------------------------------------------------------------------