diff --git a/collects/embedded-gui/embedded-gui.ss b/collects/embedded-gui/embedded-gui.ss index 1d6a723c..0cc7f0a8 100644 --- a/collects/embedded-gui/embedded-gui.ss +++ b/collects/embedded-gui/embedded-gui.ss @@ -11,7 +11,9 @@ "private/fixed-width-label-snip.ss" "private/grey-editor.ss" "private/verthoriz-alignment.ss" - "private/snip-wrapper.ss") + "private/snip-wrapper.ss" + "private/single-line-text.ss" + "private/embedded-message.ss") (provide (all-from "private/grid-alignment.ss") @@ -24,5 +26,7 @@ (all-from "private/fixed-width-label-snip.ss") (all-from "private/grey-editor.ss") (all-from "private/verthoriz-alignment.ss") - (all-from "private/snip-wrapper.ss")) + (all-from "private/snip-wrapper.ss") + (all-from "private/single-line-text.ss") + (all-from "private/embedded-message.ss")) ) diff --git a/collects/embedded-gui/private/aligned-pasteboard.ss b/collects/embedded-gui/private/aligned-pasteboard.ss index f57e167d..db689d34 100644 --- a/collects/embedded-gui/private/aligned-pasteboard.ss +++ b/collects/embedded-gui/private/aligned-pasteboard.ss @@ -49,6 +49,19 @@ (error 'add-child "There may be only one alignment<%> of a pasteboard") (set! alignment child))) + #;((is-a?/c alignment<%>) . -> . void?) + ;; Deletes a child from the the alignments + (define/public (delete-child child) + (if alignment + (if (eq? child alignment) + (set! alignment false) + (error 'delete-child "Child not found")) + (error 'delete-child "No children"))) + + #;(-> (listof (is-a?/c alignment<%>))) + ;; A list of the children of this alignment parent + (define/public (get-children) (list alignment)) + #;(-> boolean?) ;; True if the alignment is being shown (accounting for its parent being shown) ;; NOTE: Pasteboards are always shown and have no show/hide state. diff --git a/collects/embedded-gui/private/alignment-helpers.ss b/collects/embedded-gui/private/alignment-helpers.ss index 90bfa72f..4d670b79 100644 --- a/collects/embedded-gui/private/alignment-helpers.ss +++ b/collects/embedded-gui/private/alignment-helpers.ss @@ -12,13 +12,23 @@ (provide/contract (vacuous-max (() (listof number?) . ->* . (number?))) (child-height ((union (is-a?/c alignment<%>) (is-a?/c snip%)) . -> . number?)) - (child-width ((union (is-a?/c alignment<%>) (is-a?/c snip%)) . -> . number?))) + (child-width ((union (is-a?/c alignment<%>) (is-a?/c snip%)) . -> . number?)) + (insert-before (any? (listof any?) any? . -> . (listof any?))) + (insert-after (any? (listof any?) any? . -> . (listof any?)))) (define (vacuous-max . n) (if (empty? n) 0 (apply max n))) + #| + (equal? (vacuous-max 5 2) 5) + (equal? (vacuous-max) 0) + (equal? (vacuous-max -2 6) 6) + (equal? (vacuous-max -3 -5) -3) + (equal? (vacuous-max -2 0) 0) + |# + (define (child-height item) (cond [(is-a? item snip%) (snip-min-height item)] @@ -28,4 +38,37 @@ (cond [(is-a? item snip%) (snip-min-width item)] [(is-a? item alignment<%>) (send item get-min-width)])) + + (define ((insert how) item alist reference) + (cond + [(empty? alist) (error 'insert "Could not find item in list")] + [(cons? alist) + (if (equal? (first alist) reference) + (how item (first alist) (rest alist)) + (cons (first alist) + ((insert how) item (rest alist) reference)))])) + + (define insert-before + (insert (lambda (item the-first the-rest) + (cons item + (cons the-first the-rest))))) + + (define insert-after + (insert (lambda (item the-first the-rest) + (cons the-first + (cons item the-rest))))) + #| + (equal? (insert-before 1 '(3 4 2 5) 2) + '(3 4 1 2 5)) + (equal? (insert-before 1 '(1) 1) + '(1 1)) + (equal? (insert-before 0 '(5 -5 6 -5) -5) + '(5 0 -5 6 -5)) + (equal? (insert-after 1 '(3 4 2 5) 2) + '(3 4 2 1 5)) + (equal? (insert-after 1 '(1) 1) + '(1 1)) + (equal? (insert-after 0 '(5 -5 6 -5) -5) + '(5 -5 0 6 -5)) + |# ) \ No newline at end of file diff --git a/collects/embedded-gui/private/button-snip.ss b/collects/embedded-gui/private/button-snip.ss index ecfd9759..9662b3ee 100644 --- a/collects/embedded-gui/private/button-snip.ss +++ b/collects/embedded-gui/private/button-snip.ss @@ -5,12 +5,43 @@ (require (lib "mred.ss" "mred") (lib "class.ss") - (lib "etc.ss")) + (lib "etc.ss") + "snip-wrapper.ss") (provide text-button-snip% button-snip% - toggle-button-snip%) + toggle-button-snip% + embedded-button% + embedded-text-button% + embedded-toggle-button%) + + (define embedded-button% + (class snip-wrapper% + (init images callback) + (super-new + (snip (new button-snip% + (images images) + (callback callback)))))) + + (define embedded-text-button% + (class snip-wrapper% + (init label callback) + (super-new + (snip (new text-button-snip% + (label label) + (callback callback)))))) + + (define embedded-toggle-button% + (class snip-wrapper% + (init images-off images-on turn-off turn-on (state 'on)) + (super-new + (snip (new toggle-button-snip% + (images-off images-off) + (images-on images-on) + (turn-off turn-off) + (turn-on turn-on) + (state state)))))) ;; a snip of a button that can be pushed to invoke a given callback (define button-snip% @@ -121,7 +152,7 @@ ;;;;;;;;;; ;; tests - + #| (require (lib "locked-pasteboard.ss" "mrlib" "private" "aligned-pasteboard") (lib "click-forwarding-editor.ss" "mrlib")) @@ -161,5 +192,5 @@ (send e insert es 50 0) (send e insert b) (send f show #t)) - + |# ) \ No newline at end of file diff --git a/collects/embedded-gui/private/interface.ss b/collects/embedded-gui/private/interface.ss index f8edb116..5739f840 100644 --- a/collects/embedded-gui/private/interface.ss +++ b/collects/embedded-gui/private/interface.ss @@ -8,6 +8,11 @@ (define alignment<%> (interface () + + #;(-> alignment-parent<%>) + ;; The parent of this alignment + get-parent + #;(-> void?) ;; Tells the alignment that its sizes should be calculated set-min-sizes @@ -24,13 +29,13 @@ ;; The minimum height this alignment must be get-min-height - #;(-> boolean?) + #;(case-> (-> boolean?) (boolean? . -> . void?)) ;; True if the alignment can be stretched in the x dimension - stretchable-width? + stretchable-width - #;(-> boolean?) + #;(case-> (-> boolean?) (boolean? . -> . void?)) ;; True if the alignment can be stretched in the y dimension - stretchable-height? + stretchable-height #;(boolean? . -> . void) ;; Tells the alignment to show or hide its children @@ -52,6 +57,14 @@ ;; Add the given alignment as a child add-child + #;((is-a?/c alignment<%>) . -> . void?) + ;; Deletes a child from the the alignments + delete-child + + #;(-> (listof (is-a?/c alignment<%>))) + ;; A list of the children of this alignment parent + get-children + #;(-> boolean?) ;; True if the alignment is being shown (accounting for its parent being shown) is-shown? @@ -65,23 +78,23 @@ |# (define stretchable-snip<%> (interface () - ;; (positive? positive? . -> . void?) + #;(positive? positive? . -> . void?) ;; called by the parent editor to stretch the snip to an specific size stretch - ;; get-aligned-min-width (-> positive?) + #;(-> positive?) ;; get the minimum width of the snip get-aligned-min-width - ;; get-aligned-min-height (-> positive?) + #;(-> positive?) ;; get the minmum height of the snip get-aligned-min-height - ;; stretchable-width (case-> (boolean . -> . void?) (-> boolean?)) + #;(case-> (boolean . -> . void?) (-> boolean?)) ;; get or set the stretchablity of the pasteboards width stretchable-width - ;; stretchable-height (case-> (boolean . -> . void?) (-> boolean?)) + #;(case-> (boolean . -> . void?) (-> boolean?)) ;; get or set the stretchablity of the pasteboards height stretchable-height )) diff --git a/collects/embedded-gui/private/snip-wrapper.ss b/collects/embedded-gui/private/snip-wrapper.ss index 3c77d1b4..cda0ffa8 100644 --- a/collects/embedded-gui/private/snip-wrapper.ss +++ b/collects/embedded-gui/private/snip-wrapper.ss @@ -20,6 +20,10 @@ ;;;;;;;;;; ;; alignment<%> + #;(-> alignment-parent<%>) + ;; The parent of this alignment + (define/public (get-parent) parent) + #;(-> void?) ;; Tells the alignment that its sizes should be calculated (define/public (set-min-sizes) @@ -31,7 +35,6 @@ #;(nonnegative? nonnegative? nonnegative? nonnegative? . -> . void?) ;; Tells the alignment to align its children on the pasteboard in the given rectangle - ;; STATUS: I don't currently handle stretchability (define/public (align x y w h) (send pasteboard move-to snip x y) (when (is-a? snip stretchable-snip<%>) @@ -45,14 +48,14 @@ ;; The minimum height this alignment must be. (define/public (get-min-height) min-height) - #;(-> boolean?) + #;(case-> (-> boolean?) (boolean? . -> . void?)) ;; True if the alignment can be stretched in the x dimension - (define/public (stretchable-width?) + (define/public (stretchable-width) (sl:stretchable-width? snip)) - #;(-> boolean?) + #;(case-> (-> boolean?) (boolean? . -> . void?)) ;; True if the alignment can be stretched in the y dimension - (define/public (stretchable-height?) + (define/public (stretchable-height) (sl:stretchable-height? snip)) #;(boolean? . -> . void?) diff --git a/collects/embedded-gui/private/verthoriz-alignment.ss b/collects/embedded-gui/private/verthoriz-alignment.ss index 3bc7c61d..cf8e967e 100644 --- a/collects/embedded-gui/private/verthoriz-alignment.ss +++ b/collects/embedded-gui/private/verthoriz-alignment.ss @@ -2,13 +2,10 @@ (require (lib "class.ss") - (lib "mred.ss" "mred") (lib "etc.ss") (lib "list.ss") (lib "match.ss") (prefix a: "alignment.ss") - - "snip-lib.ss" "interface.ss" "alignment-helpers.ss") @@ -20,16 +17,24 @@ (class* object% (alignment<%> alignment-parent<%>) (init-field parent [show? true]) + (init [stretchable-width true] + [stretchable-height true]) (field [pasteboard (send parent get-pasteboard)] [children empty] [min-width 0] - [min-height 0]) + [min-height 0] + [stretchable-width? stretchable-width] + [stretchable-height? stretchable-height]) ;;;;;;;;;; ;; alignment<%> + #;(-> alignment-parent<%>) + ;; The parent of this alignment + (define/public (get-parent) parent) + #;(-> void?) ;; Tells the alignment that its sizes should be calculated (define/public (set-min-sizes) @@ -79,13 +84,21 @@ (define/public (get-min-height) (if (is-shown?) min-height 0)) - #;(-> boolean?) + #;(case-> (-> boolean?) (boolean? . -> . void?)) ;; True if the alignment can be stretched in the x dimension - (define/public (stretchable-width?) true) + (public [stretchable-width-method stretchable-width]) + (define stretchable-width-method + (case-lambda + [() stretchable-width?] + [(value) (set! stretchable-width? value)])) - #;(-> boolean?) + #;(case-> (-> boolean?) (boolean? . -> . void?)) ;; True if the alignment can be stretched in the y dimension - (define/public (stretchable-height?) true) + (public [stretchable-height-method stretchable-height]) + (define stretchable-height-method + (case-lambda + [() stretchable-height?] + [(value) (set! stretchable-height? value)])) #;(boolean? . -> . void) ;; Tells the alignment to show or hide its children @@ -107,11 +120,34 @@ ;; The pasteboard that this alignment is being displayed to (define/public (get-pasteboard) pasteboard) - #;((is-a?/c alignment<%>) . -> . void?) - ;; Add the given alignment as a child + #;(((is-a?/c alignment<%>)) ((is-a?/c alignment<%>)) . opt-> . void?) + ;; Add the given alignment as a child before the existing child (define/public (add-child child) (set! children (append children (list child)))) + #;((is-a?/c alignment<%>) . -> . void?) + ;; Deletes a child from the the alignments + (define/public (delete-child child) + (send child show/hide false) + (set! children (filter (lambda (c) (not (eq? child c))) + children))) + + #;(-> (listof (is-a?/c alignment<%>))) + ;; A list of the children of this alignment parent + (define/public (get-children) children) + + #;((is-a?/c alignment<%>) (is-a?/c alignment<%>) . -> . void?) + ;; Moves a snip to a position after the other + (define/public (move-after child reference) + (let ([r (remove child children)]) + (set! children (insert-after child r reference)))) + + #;((is-a?/c alignment<%>) (is-a?/c alignment<%>) . -> . void?) + ;; Moves a snip to a position before the other + (define/public (move-before child reference) + (let ([r (remove child children)]) + (set! children (insert-before child r reference)))) + #;(-> boolean?) ;; True if the alignment is being shown (accounting for its parent being shown) (define/public (is-shown?) @@ -137,6 +173,6 @@ ;; makes a new default rect out of a snip (define (build-rect item) (a:make-rect - (a:make-dim 0 (send item get-min-width) (send item stretchable-width?)) - (a:make-dim 0 (send item get-min-height) (send item stretchable-height?)))) + (a:make-dim 0 (send item get-min-width) (send item stretchable-width)) + (a:make-dim 0 (send item get-min-height) (send item stretchable-height)))) )