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

7-GUIS port task 7

This commit is contained in:
Sam Caldwell 2019-07-17 10:31:27 -04:00
parent a259153470
commit ded2629296
9 changed files with 224 additions and 26 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

44
racket/syndicate-gui-toolbox/examples/7-GUIS/cells-canvas.rkt Normal file
View File

@ -0,0 +1,44 @@
#lang syndicate
;; actor adapter for canvas-double-click% and cells-canvas%
(require 7GUI/canvas-double-click)
(require 7GUI/task-7-view)
(require (only-in "../../widgets.rkt" qc))
(provide spawn-cells-canvas
(struct-out single-click)
(struct-out double-click)
(struct-out update-grid))
(require racket/gui/base
(except-in racket/class field))
(message-struct single-click (x y))
(message-struct double-click (x y))
(message-struct update-grid (cells))
;; ---------------------------------------------------------------------------------------------------
(define cells-canvas%
(class canvas-double-click%
(define/augment-final (on-click x y) (send-ground-message (single-click x y)))
(define/augment-final (on-double-click x y) (send-ground-message (double-click x y)))
(define *content #f)
(define/public (update-grid cells)
(set! *content cells)
(qc (define dc (send this get-dc))
(paint-grid dc *content)))
(super-new [paint-callback (lambda (_self dc) (when *content (paint-grid dc *content)))])))
(define (spawn-cells-canvas parent width height)
(define parent-component (seal-contents parent))
(define canvas (new cells-canvas% [parent parent-component] [style '(hscroll vscroll)]))
(qc (send canvas init-auto-scrollbars width height 0. 0.)
(send canvas show-scrollbars #t #t))
(spawn
(on (message (update-grid $cells))
(qc (send canvas update-grid cells)))
(on (message (inbound (single-click $x $y)))
(send! (single-click x y)))
(on (message (inbound (double-click $x $y)))
(send! (double-click x y)))))

2
racket/syndicate-gui-toolbox/examples/7-GUIS/task-1.rkt
View File

@ -19,7 +19,7 @@
(counter (add1 (counter)))
(send! (set-text-field view (~a (counter)))))
(on-start
(send! (show-frame frame #t))))))
(send! (show frame #t))))))
(module+ main
(void))

2
racket/syndicate-gui-toolbox/examples/7-GUIS/task-2.rkt
View File

@ -58,4 +58,4 @@
(on (message (text-field-update F-field $val))
(fahrenheit->celsius F-field val))
(on-start
(send! (show-frame frame #t))))))
(send! (show frame #t))))))

2
racket/syndicate-gui-toolbox/examples/7-GUIS/task-3.rkt
View File

@ -64,6 +64,6 @@
(on (message (button-press book))
(displayln "confirmed"))
(on-start (send! (show-frame frame #t))
(on-start (send! (show frame #t))
(enable-return-book (*kind-flight))))
)

2
racket/syndicate-gui-toolbox/examples/7-GUIS/task-4.rkt
View File

@ -57,6 +57,6 @@
(on (message (slider-update slider $val))
(duration-cb val))
(on-start (elapsed-cb)
(send! (show-frame frame #t))))
(send! (show frame #t))))
)

2
racket/syndicate-gui-toolbox/examples/7-GUIS/task-5.rkt
View File

@ -69,6 +69,6 @@
(define (retrieve-name) (string-append (*surname) ", " (*name)))
(on-start (prefix-cb "")
(send! (show-frame frame #t))))
(send! (show frame #t))))
)

2
racket/syndicate-gui-toolbox/examples/7-GUIS/task-6.rkt
View File

@ -202,5 +202,5 @@
(define canvas (spawn-circle-canvas hpane2 frame undo-but redo-but))
(on (asserted (frame@ frame))
(send! (show-frame frame #t)))
(send! (show frame #t)))
)

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

@ -0,0 +1,96 @@
#lang syndicate
(require "../../widgets.rkt")
(require "cells-canvas.rkt")
(require racket/set racket/list racket/format)
;; a simple spreadsheet (will not check for circularities)
(require 7GUI/task-7-exp)
(require 7GUI/task-7-view)
;; -----------------------------------------------------------------------------
(struct formula (formula dependents) #:transparent)
#; {Formula = [formula Exp* || Number || (Setof Ref*)]}
(define (spawn-control frame)
(spawn
(field [*content (make-immutable-hash)] ;; [Hashof Ref* Integer]
[*formulas (make-immutable-hash)] ;; [Hashof Ref* Formula]
)
(define-syntax-rule (iff selector e default) (let ([v e]) (if v (selector v) default)))
(define (get-exp ref*) (iff formula-formula (hash-ref (*formulas) ref* #f) 0))
(define (get-dep ref*) (iff formula-dependents (hash-ref (*formulas) ref* #f) (set)))
(define (get-content ref*) (hash-ref (*content) ref* 0))
(local-require 7GUI/should-be-racket)
(define (set-content! ref* vc)
(define current (get-content ref*))
(*content (hash-set (*content) ref* vc))
(when (and current (not (= current vc)))
(when* (get-dep ref*) => propagate-to)))
(define (propagate-to dependents)
(for ((d (in-set dependents)))
(set-content! d (evaluate (get-exp d) (*content)))))
(define (set-formula! ref* exp*)
(define new (formula exp* (or (get-dep ref*) (set))))
(*formulas (hash-set (*formulas) ref* new))
(register-with-dependents (depends-on exp*) ref*)
(set-content! ref* (evaluate exp* (*content))))
(define (register-with-dependents dependents ref*)
(for ((d (in-set dependents)))
(*formulas (hash-set (*formulas) d (formula (get-exp d) (set-add (get-dep d) ref*))))))
;; ---------------------------------------------------------------------------------------------------
;; cells and contents
(define ((mk-edit title-fmt validator registration source frame) x y)
(define cell (list (x->A x) (y->0 y)))
(when (and (first cell) (second cell))
(react
(define value0 (~a (or (source cell) "")))
;; maybe need to make use of queue-callback ?
(define dialog (spawn-dialog #:parent #f
#:style '(close-button)
#:label (format title-fmt cell)))
(define tf (spawn-text-field #:parent dialog
#:label #f
#:min-width 200
#:min-height 80
#:init-value value0))
(on (message (text-field-enter tf $contents))
(when* (validator contents)
=> (lambda (valid)
(stop-current-facet
(send! (show dialog #f))
(registration cell valid)
(send! (update-grid (*content)))))))
(on (asserted (dialog@ dialog))
(send! (show dialog #t))))))
(define content-edit (mk-edit "content for cell ~a" valid-content set-content! get-content frame))
(define formula-fmt "a formula for cell ~a")
(define formula-edit (mk-edit formula-fmt string->exp* set-formula! (compose exp*->string get-exp) frame))
;; ---------------------------------------------------------------------------------------------------
(on (message (single-click $x $y))
(content-edit x y))
(on (message (double-click $x $y))
(formula-edit x y))
(on-start (send! (update-grid (*content))))
))
;; ---------------------------------------------------------------------------------------------------
(spawn
(define frame (spawn-frame #:label "Cells" #:width (/ WIDTH 2) #:height (/ HEIGHT 3)))
(define canvas (spawn-cells-canvas frame WIDTH HEIGHT))
(spawn-control frame)
(on (asserted (frame@ frame))
(send! (show frame #t)))
)

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

@ -1,6 +1,9 @@
#lang syndicate
(provide spawn-frame
(provide gui-eventspace
gui-callback
qc
spawn-frame
spawn-horizontal-pane
spawn-horizontal-panel
spawn-vertical-pane
@ -10,8 +13,9 @@
spawn-gauge
spawn-slider
spawn-list-box
spawn-dialog
(struct-out frame@)
(struct-out show-frame)
(struct-out show)
(struct-out horizontal-pane@)
(struct-out horizontal-panel@)
(struct-out vertical-pane@)
@ -21,6 +25,7 @@
(struct-out button-press)
(struct-out set-text-field-background)
(struct-out text-field-update)
(struct-out text-field-enter)
(struct-out choice@)
(struct-out choice-selection)
(struct-out set-selection)
@ -34,7 +39,8 @@
(struct-out set-list-box-choices)
(struct-out popup-menu)
(struct-out no-popdown-selected)
(struct-out popdown-item-selected))
(struct-out popdown-item-selected)
(struct-out dialog@))
(require (only-in racket/class
new
@ -42,13 +48,27 @@
make-object))
(require racket/gui/base)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Eventspace Shennanigans
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define gui-eventspace (make-parameter (make-eventspace)))
(define (gui-callback thnk)
(parameterize ([current-eventspace (gui-eventspace)])
(queue-callback thnk)))
(define-syntax-rule (qc expr ...)
(gui-callback (lambda () expr ...)))
;; an ID is a (Sealof Any)
;; an Alignment is a (List (U 'left 'center 'right) (U 'top 'center 'bottom))
(message-struct enable (id val))
(assertion-struct frame@ (id))
(message-struct show-frame (id value))
(message-struct show (id value))
(message-struct popup-menu (parent-id id title x y items))
(message-struct no-popdown-selected (id))
(message-struct popdown-item-selected (id item))
@ -61,6 +81,7 @@
(message-struct set-text-field (id value))
(message-struct set-text-field-background (id color))
(message-struct text-field-update (id value))
(message-struct text-field-enter (id value))
(assertion-struct button@ (id))
(message-struct button-press (id))
@ -79,18 +100,22 @@
(message-struct list-box-selection (id idx))
(message-struct set-list-box-choices (id choices))
(assertion-struct dialog@ (id))
(define (enable/disable-handler self my-id)
(on (message (enable my-id $val))
(send self enable val)))
(qc (send self enable val))))
;; String -> ID
(define (spawn-frame #:label label
#:width [width #f])
#:width [width #f]
#:height [height #f])
(define frame
(parameterize ((current-eventspace (make-eventspace)))
(parameterize ((current-eventspace (gui-eventspace)))
(new frame%
[label label]
[width width])))
[width width]
[height height])))
(define id (seal frame))
(define ((on-popdown! pid) self evt)
@ -101,13 +126,13 @@
(spawn
(assert (frame@ id))
(on (message (show-frame id $val))
(send frame show val))
(on (message (show id $val))
(qc (send frame show val)))
(on (message (popup-menu id $pid $title $x $y $items))
(define pm (new popup-menu% [title title] [popdown-callback (on-popdown! pid)]))
(for ([i (in-list items)])
(new menu-item% [parent pm] [label i] [callback (popdown-item! pid i)]))
(send frame popup-menu pm x y)
(qc (send frame popup-menu pm x y))
(react (stop-when (message (inbound (no-popdown-selected pid))) (send! (no-popdown-selected pid)))
(stop-when (message (inbound (popdown-item-selected pid $i))) (send! (popdown-item-selected pid i))))))
id)
@ -167,11 +192,17 @@
#:label label
#:init-value init
#:enabled [enabled? #t]
#:min-width [min-width #f])
#:min-width [min-width #f]
#:min-height [min-height #f])
(define parent-component (seal-contents parent))
(define (inject-text-field-update! _ evt)
(send-ground-message (text-field-update id (send tf get-value))))
(printf "inject-text-field-update!\n")
(case (send evt get-event-type)
[(text-field)
(send-ground-message (text-field-update id (send tf get-value)))]
[(text-field-enter)
(send-ground-message (text-field-enter id (send tf get-value)))]))
(define tf (new text-field%
[parent parent-component]
@ -179,6 +210,7 @@
[init-value init]
[enabled enabled?]
[min-width min-width]
[min-height min-height]
[callback inject-text-field-update!]))
(define id (seal tf))
@ -187,14 +219,17 @@
(assert (text-field@ id (val)))
(enable/disable-handler tf id)
(on (message (set-text-field id $value))
(send tf set-value value)
(qc (send tf set-value value))
(val value))
(on (message (set-text-field-background id $color))
(define c (make-object color% color))
(send tf set-field-background c))
(qc (send tf set-field-background c)))
(on (message (inbound (text-field-update id $value)))
(val (send tf get-value))
(send! (text-field-update id (val)))))
(val value)
(send! (text-field-update id value)))
(on (message (inbound (text-field-enter id $value)))
(val value)
(send! (text-field-enter id value))))
id)
@ -242,7 +277,7 @@
(selection val)
(send! (choice-selection id val)))
(on (message (set-selection id $idx))
(send ch set-selection idx)
(qc (send ch set-selection idx))
(selection (send ch get-string-selection))))
id)
@ -263,7 +298,7 @@
(spawn
(assert (gauge@ id))
(on (message (set-gauge-value id $v))
(send g set-value v)))
(qc (send g set-value v))))
id)
@ -324,7 +359,30 @@
(selection val)
(send! (list-box-selection id val)))
(on (message (set-list-box-choices id $val))
(send lb set val)
(qc (send lb set val))
(selection (get))))
id)
(define (spawn-dialog #:label label
#:parent [parent #f]
#:style [style null])
(define parent-component (and parent (seal-contents parent)))
(define evt-spc (if parent-component
(send parent-component get-eventspace)
(make-eventspace) #;(gui-eventspace)))
(define d (parameterize ((current-eventspace evt-spc))
(new dialog%
[label label]
[parent parent-component]
[style style])))
(define id (seal d))
(spawn
(assert (dialog@ id))
(on (message (show id $show?))
(qc (send d show show?))
(unless show? (stop-current-facet))))
id)