#lang racket/base (require (for-syntax racket/base) slideshow/pict slideshow/base racket/gui/base racket/class racket/match) (struct pict+var (main-pict click-resps)) (struct click-resp (pict resp)) (define bindings (make-hash)) (define binding-types (make-hash)) (define whens '()) (define pict+vars '()) (define pict-frame #f) (define pict-canvas #f) (define-syntax (decl stx) (syntax-case stx () [(_ type id init) #'(begin (define-syntax (id stx) (syntax-case stx () [x (identifier? #'x) #'(hash-ref bindings 'id)] [(x . rest) #'(#%app (hash-ref bindings 'id) . rest)])) (do-decl 'type 'id init))])) (define (do-decl type id init) (hash-set! binding-types id (normalize-type type)) (hash-set! bindings id init)) (define (normalize-type type) (match type [`(or ,a ... (or ,b ...) ,c ...) (normalize-type `(or ,@a ,@b ,@c))] [`(or ,a ...) `(or ,@(sort a string<=? #:key symbol->string))] [else type])) (module+ test (require rackunit) (check-equal? (normalize-type '(or Boolean Integer)) '(or Boolean Integer)) (check-equal? (normalize-type 'Boolean) 'Boolean) (check-equal? (normalize-type '(or (or (or A B) C) D)) '(or A B C D)) (check-equal? (normalize-type '(or D (or C (or A B)))) '(or A B C D))) (define-syntax (-when stx) (syntax-case stx () [(_ condition statements ...) #'(add-when (letrec ([me (λ () (when condition (remove-me me) statements ...))]) me))])) (define (add-when when) (set! whens (cons when whens))) (define (remove-me me) (set! whens (remq me whens))) (define (handle-clicked which) (set! pict+vars (filter values (for/list ([a-pict+var (in-list pict+vars)]) (define clicked-on? (for/or ([a-click-resp (in-list (pict+var-click-resps a-pict+var))]) (cond [(eq? (click-resp-pict a-click-resp) which) ((click-resp-resp a-click-resp)) #t] [else #f]))) (cond [clicked-on? #f] [else a-pict+var])))) (for ([when-proc (in-list whens)]) (when-proc)) (picts-changed)) (define combined-picts (blank 10 10)) (define pict-canvas% (class canvas% (inherit get-dc get-client-size refresh) (define scaled #f) (define/public (something-changed) (set! scaled #f) (refresh)) (define/override (on-size w h) (set! scaled #f) (refresh)) (define/override (on-paint) (unless scaled (define-values (w h) (get-client-size)) (set! scaled (scale-to-fit combined-picts w h))) (define dc (get-dc)) (draw-pict scaled dc 0 0)) (define/override (on-event evt) (when (and scaled (send evt button-down?)) (define x (send evt get-x)) (define y (send evt get-y)) (define clicked-on (for/or ([a-pict+var (in-list pict+vars)]) (for/or ([a-click-resp (pict+var-click-resps a-pict+var)]) (define pict (click-resp-pict a-click-resp)) (define-values (l t) (lt-find scaled pict)) (define-values (r b) (rb-find scaled pict)) (cond [(and (<= l x r) (<= t y b)) pict] [else #f])))) (when clicked-on (handle-clicked clicked-on)))) (super-new))) (define-syntax-rule (prompt color var str-expr) (begin var (prompt/proc 'color 'var str-expr))) (define (prompt/proc color var str) (unless pict-frame (set! pict-frame (new frame% [width 600] [height 800] [label "POP-PL"])) (set! pict-canvas (new pict-canvas% [parent pict-frame])) (send pict-frame show #t)) (set! pict+vars (cons (mk-one-pict (symbol->string color) str var) pict+vars)) (picts-changed)) (define (picts-changed) (define width (inexact->exact (ceiling (sqrt (length pict+vars))))) (set! combined-picts (cond [(null? pict+vars) (blank 10 10)] [else (inset (table width (append (map pict+var-main-pict pict+vars) (build-list (- width (modulo (length pict+vars) width)) (λ (x) (blank)))) cc-superimpose cc-superimpose 10 10) 10 10)])) (send pict-canvas something-changed)) (define (mk-one-pict color str var) (define type (hash-ref binding-types var)) (match type ['Boolean (define pict (colored-background (txt->pict str) color)) (pict+var pict (list (click-resp pict (λ () (hash-set! bindings var #t)))))] ['(Or Boolean Unknown) (define top (txt->pict str)) (define yes (rounded-white-background (t "Yes"))) (define no (rounded-white-background (t "No"))) (define bottom (hc-append 20 yes no)) (pict+var (colored-background (vc-append top (scale bottom (/ (pict-width top) (pict-width bottom)))) color) (list (click-resp yes (λ () (hash-set! bindings var #t))) (click-resp no (λ () (hash-set! bindings var #f)))))] [else (eprintf "skipping: ~a\n" type) (pict+var (blank) '())])) (define (rounded-white-background p) (cc-superimpose (colorize (filled-rounded-rectangle (+ (pict-width p) 10) (+ (pict-height p) 10)) "white") p)) (define (colored-background p color) (define bkg (colorize (filled-rectangle (+ (pict-width p) 20) (+ (pict-height p) 20)) color)) (cc-superimpose bkg p)) (define (txt->pict str) (colorize (para #:width 200 #:fill? #f str) "white")) (define true #t) (define false #f) (define-values (unknown unknown?) (let () (struct unknown ()) (values (unknown) unknown?))) (define (known? x) (not (unknown? x))) (define-values (n/a n/a?) (let () (struct n/a ()) (values (n/a) unknown?))) (define-syntax-rule (bang! id expr) (hash-set! bindings 'id expr)) (provide #%module-begin decl prompt true false #%datum (rename-out [-when when]) if or #%top-interaction #%app known? unknown? unknown n/a n/a? begin bang! not) (define (not x) (and (boolean? x) (if x #f #t)))