From cdca416d21f561b265b32f6c30023f6aadaffcf4 Mon Sep 17 00:00:00 2001 From: Sam Caldwell Date: Fri, 12 Jul 2019 13:01:39 -0400 Subject: [PATCH] 7-GUIS port task 5 --- .../examples/7-GUIS/task-5.rkt | 74 +++++++++++++++++++ racket/syndicate-gui-toolbox/widgets.rkt | 71 +++++++++++++++++- 2 files changed, 141 insertions(+), 4 deletions(-) create mode 100644 racket/syndicate-gui-toolbox/examples/7-GUIS/task-5.rkt diff --git a/racket/syndicate-gui-toolbox/examples/7-GUIS/task-5.rkt b/racket/syndicate-gui-toolbox/examples/7-GUIS/task-5.rkt new file mode 100644 index 0000000..60cbfe3 --- /dev/null +++ b/racket/syndicate-gui-toolbox/examples/7-GUIS/task-5.rkt @@ -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)))) + +) diff --git a/racket/syndicate-gui-toolbox/widgets.rkt b/racket/syndicate-gui-toolbox/widgets.rkt index 4bd94bf..257be50 100644 --- a/racket/syndicate-gui-toolbox/widgets.rkt +++ b/racket/syndicate-gui-toolbox/widgets.rkt @@ -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)