7-GUIS port task 5
This commit is contained in:
parent
de1fab2cb5
commit
cdca416d21
|
@ -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))))
|
||||||
|
|
||||||
|
)
|
|
@ -2,14 +2,17 @@
|
||||||
|
|
||||||
(provide spawn-frame
|
(provide spawn-frame
|
||||||
spawn-horizontal-pane
|
spawn-horizontal-pane
|
||||||
|
spawn-vertical-pane
|
||||||
spawn-text-field
|
spawn-text-field
|
||||||
spawn-button
|
spawn-button
|
||||||
spawn-choice
|
spawn-choice
|
||||||
spawn-gauge
|
spawn-gauge
|
||||||
spawn-slider
|
spawn-slider
|
||||||
|
spawn-list-box
|
||||||
(struct-out frame@)
|
(struct-out frame@)
|
||||||
(struct-out show-frame)
|
(struct-out show-frame)
|
||||||
(struct-out horizontal-pane@)
|
(struct-out horizontal-pane@)
|
||||||
|
(struct-out vertical-pane@)
|
||||||
(struct-out text-field@)
|
(struct-out text-field@)
|
||||||
(struct-out set-text-field)
|
(struct-out set-text-field)
|
||||||
(struct-out button@)
|
(struct-out button@)
|
||||||
|
@ -23,7 +26,10 @@
|
||||||
(struct-out gauge@)
|
(struct-out gauge@)
|
||||||
(struct-out set-gauge-value)
|
(struct-out set-gauge-value)
|
||||||
(struct-out slider@)
|
(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
|
(require (only-in racket/class
|
||||||
new
|
new
|
||||||
|
@ -32,6 +38,7 @@
|
||||||
(require racket/gui/base)
|
(require racket/gui/base)
|
||||||
|
|
||||||
;; an ID is a (Sealof Any)
|
;; an ID is a (Sealof Any)
|
||||||
|
;; an Alignment is a (List (U 'left 'center 'right) (U 'top 'center 'bottom))
|
||||||
|
|
||||||
(message-struct enable (id val))
|
(message-struct enable (id val))
|
||||||
|
|
||||||
|
@ -39,6 +46,7 @@
|
||||||
(message-struct show-frame (id value))
|
(message-struct show-frame (id value))
|
||||||
|
|
||||||
(assertion-struct horizontal-pane@ (id))
|
(assertion-struct horizontal-pane@ (id))
|
||||||
|
(assertion-struct vertical-pane@ (id))
|
||||||
|
|
||||||
(assertion-struct text-field@ (id value))
|
(assertion-struct text-field@ (id value))
|
||||||
(message-struct set-text-field (id value))
|
(message-struct set-text-field (id value))
|
||||||
|
@ -58,6 +66,10 @@
|
||||||
(assertion-struct slider@ (id value))
|
(assertion-struct slider@ (id value))
|
||||||
(message-struct slider-update (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)
|
(define (enable/disable-handler self my-id)
|
||||||
(on (message (enable my-id $val))
|
(on (message (enable my-id $val))
|
||||||
(send self enable val)))
|
(send self enable val)))
|
||||||
|
@ -75,9 +87,14 @@
|
||||||
id)
|
id)
|
||||||
|
|
||||||
;; ID -> 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 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))
|
(define id (seal pane))
|
||||||
|
|
||||||
(spawn
|
(spawn
|
||||||
|
@ -85,12 +102,26 @@
|
||||||
|
|
||||||
id)
|
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
|
; ID String String Bool Nat -> ID
|
||||||
(define (spawn-text-field #:parent parent
|
(define (spawn-text-field #:parent parent
|
||||||
#:label label
|
#:label label
|
||||||
#:init-value init
|
#:init-value init
|
||||||
#:enabled [enabled? #t]
|
#:enabled [enabled? #t]
|
||||||
#:min-width [min-width 1])
|
#:min-width [min-width #f])
|
||||||
(define parent-component (seal-contents parent))
|
(define parent-component (seal-contents parent))
|
||||||
|
|
||||||
(define (inject-text-field-update! _ evt)
|
(define (inject-text-field-update! _ evt)
|
||||||
|
@ -217,3 +248,35 @@
|
||||||
(send! (slider-update id val))))
|
(send! (slider-update id val))))
|
||||||
|
|
||||||
id)
|
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)
|
||||||
|
|
Loading…
Reference in New Issue