7-GUIS port task 7
This commit is contained in:
parent
ce9d563d8c
commit
7af6782ea8
|
@ -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)))))
|
|
@ -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))
|
||||
|
|
|
@ -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))))))
|
||||
|
|
|
@ -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))))
|
||||
)
|
||||
|
|
|
@ -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))))
|
||||
|
||||
)
|
||||
|
|
|
@ -69,6 +69,6 @@
|
|||
(define (retrieve-name) (string-append (*surname) ", " (*name)))
|
||||
|
||||
(on-start (prefix-cb "")
|
||||
(send! (show-frame frame #t))))
|
||||
(send! (show frame #t))))
|
||||
|
||||
)
|
||||
|
|
|
@ -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)))
|
||||
)
|
||||
|
|
|
@ -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)))
|
||||
)
|
|
@ -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)
|
||||
|
|
Loading…
Reference in New Issue