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

7-GUIS port task 5

This commit is contained in:
Sam Caldwell 2019-07-12 13:01:39 -04:00
parent de1fab2cb5
commit cdca416d21
2 changed files with 141 additions and 4 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -0,0 +1,74 @@
#lang syndicate
(require "../../widgets.rkt")
(require (only-in racket/string string-prefix?))
(require (only-in racket/function curry))
(require (only-in racket/list first rest))
;; a create-read-update-deleted MVC implementation
;; ---------------------------------------------------------------------------------------------------
(spawn
(define frame (spawn-frame #:label "CRUD"))
(define hpane1 (spawn-horizontal-pane #:parent frame #:border 10 #:alignment '(left bottom)))
(define vpane1 (spawn-vertical-pane #:parent hpane1))
(define filter-tf (spawn-text-field #:parent vpane1 #:label "Filter prefix: " #:init-value ""))
(define lbox (spawn-list-box #:parent vpane1 #:label #f #:choices '() #:min-width 100 #:min-height 100))
(define vpane2 (spawn-vertical-pane #:parent hpane1 #:alignment '(right center)))
(define name (spawn-text-field #:parent vpane2 #:label "Name: " #:init-value "" #:min-width 200))
(define surname (spawn-text-field #:parent vpane2 #:label "Surname: " #:init-value "" #:min-width 200))
(define hpane2 (spawn-horizontal-pane #:parent frame))
(define create-but (spawn-button #:label "Create" #:parent hpane2))
(define update-but (spawn-button #:label "Update" #:parent hpane2))
(define delete-but (spawn-button #:label "Delete" #:parent hpane2))
(spawn
(field [*data '("Emil, Hans" "Mustermann, Max" "Tisch, Roman")]
[*selector ""]
[*selected (*data)]) ;; selected = (filter select data)
;; ---------------------------------------------------------------------------------------------------
(define (selector! nu) (*selector nu) (data->selected!))
(define (select s) (string-prefix? s (*selector)))
(define (data->selected!) (*selected (if (string=? "" (*selector)) (*data) (filter select (*data)))))
(define-syntax-rule (def-! (name x ...) exp) (define (name x ...) (*data exp) (data->selected!)))
(def-! (create-entry new-entry) (append (*data) (list new-entry)))
(def-! (update-entry new-entry i) (operate-on i (curry cons new-entry) (*data) select (*selected)))
(def-! (delete-from i) (operate-on i values))
#; {N [[Listof X] -> [Listof X]] [Listof X] [X -> Boolean] [Listof X] -> [Listof X]}
;; traverse list to the i-th position of selected in data, then apply operator to rest (efficiency)
;; ASSUME selected = (filter selector data)
;; ASSUME i <= (length selected)
(define (operate-on i operator [data (*data)] [select select] [selected (*selected)])
(let sync ((i i) (data data) (selected selected))
(if (select (first data))
(if (zero? i)
(operator (rest data))
(cons (first data) (sync (sub1 i) (rest data) (rest selected))))
(cons (first data) (sync i (rest data) selected)))))
;; ---------------------------------------------------------------------------------------------------
(define-syntax-rule (def-cb (name x) exp ...) (define (name x) exp ... (send! (set-list-box-choices lbox (*selected)))))
(def-cb (prefix-cb prefix) (selector! prefix))
(def-cb (Create-cb _b) (create-entry (retrieve-name)))
(def-cb (Update-cb _b) (common-cb (curry update-entry (retrieve-name))))
(def-cb (Delete-cb _b) (common-cb delete-from))
(on (message (text-field-update filter-tf $prefix)) (prefix-cb prefix))
(on (message (button-press create-but)) (Create-cb create-but))
(on (message (button-press update-but)) (Update-cb update-but))
(on (message (button-press delete-but)) (Delete-cb delete-but))
(define/query-value current-selection #f (list-box@ lbox $selection) selection)
(define/query-value *surname "" (text-field@ surname $val) val)
(define/query-value *name "" (text-field@ name $val) val)
(local-require 7GUI/should-be-racket)
(define (common-cb f) (when* (current-selection) => f))
(define (retrieve-name) (string-append (*surname) ", " (*name)))
(on-start (prefix-cb "")
(send! (show-frame frame #t))))
)

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

@ -2,14 +2,17 @@
(provide spawn-frame
spawn-horizontal-pane
spawn-vertical-pane
spawn-text-field
spawn-button
spawn-choice
spawn-gauge
spawn-slider
spawn-list-box
(struct-out frame@)
(struct-out show-frame)
(struct-out horizontal-pane@)
(struct-out vertical-pane@)
(struct-out text-field@)
(struct-out set-text-field)
(struct-out button@)
@ -23,7 +26,10 @@
(struct-out gauge@)
(struct-out set-gauge-value)
(struct-out slider@)
(struct-out slider-update))
(struct-out slider-update)
(struct-out list-box@)
(struct-out list-box-selection)
(struct-out set-list-box-choices))
(require (only-in racket/class
new
@ -32,6 +38,7 @@
(require racket/gui/base)
;; an ID is a (Sealof Any)
;; an Alignment is a (List (U 'left 'center 'right) (U 'top 'center 'bottom))
(message-struct enable (id val))
@ -39,6 +46,7 @@
(message-struct show-frame (id value))
(assertion-struct horizontal-pane@ (id))
(assertion-struct vertical-pane@ (id))
(assertion-struct text-field@ (id value))
(message-struct set-text-field (id value))
@ -58,6 +66,10 @@
(assertion-struct slider@ (id value))
(message-struct slider-update (id value))
(assertion-struct list-box@ (id idx))
(message-struct list-box-selection (id idx))
(message-struct set-list-box-choices (id choices))
(define (enable/disable-handler self my-id)
(on (message (enable my-id $val))
(send self enable val)))
@ -75,9 +87,14 @@
id)
;; ID -> ID
(define (spawn-horizontal-pane #:parent parent)
(define (spawn-horizontal-pane #:parent parent
#:border [border 0]
#:alignment [alignment '(left center)])
(define parent-component (seal-contents parent))
(define pane (new horizontal-pane% [parent parent-component]))
(define pane (new horizontal-pane%
[parent parent-component]
[border border]
[alignment alignment]))
(define id (seal pane))
(spawn
@ -85,12 +102,26 @@
id)
;; ID Alignment -> ID
(define (spawn-vertical-pane #:parent parent
#:alignment [alignment '(center top)])
(define parent-component (seal-contents parent))
(define pane (new vertical-pane%
[parent parent-component]
[alignment alignment]))
(define id (seal pane))
(spawn
(assert (vertical-pane@ id)))
id)
; ID String String Bool Nat -> ID
(define (spawn-text-field #:parent parent
#:label label
#:init-value init
#:enabled [enabled? #t]
#:min-width [min-width 1])
#:min-width [min-width #f])
(define parent-component (seal-contents parent))
(define (inject-text-field-update! _ evt)
@ -217,3 +248,35 @@
(send! (slider-update id val))))
id)
;; ID (U String #f) (Listof String) ... -> ID
(define (spawn-list-box #:parent parent
#:label label
#:choices choices
#:min-width [min-width #f]
#:min-height [min-height #f])
(define (inject-list-box-selection! self evt)
(send-ground-message (list-box-selection id (get))))
(define parent-component (seal-contents parent))
(define lb (new list-box%
[parent parent-component]
[label label]
[choices choices]
[min-width min-width]
[min-height min-height]
[callback inject-list-box-selection!]))
(define id (seal lb))
(define (get)
(send lb get-selection))
(spawn
(field [selection (get)])
(assert (list-box@ id (selection)))
(on (message (inbound (list-box-selection id $val)))
(selection val)
(send! (list-box-selection id val)))
(on (message (set-list-box-choices id $val))
(send lb set val)
(selection (get))))
id)