suzanne.soy/gui
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

many udates over the course of the weeks. commited to support profjBoxes

Browse Source 
original commit: a4f6353f786b0be874aa8344a155d15f30d7bc47
This commit is contained in:
Mike MacHenry 2004-09-10 20:03:36 +00:00
parent f9f2f82b26
commit 1561814fc2
7 changed files with 176 additions and 33 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
collects/embedded-gui/embedded-gui.ss
View File

@ -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"))
)

13
collects/embedded-gui/private/aligned-pasteboard.ss
View File

@ -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.

45
collects/embedded-gui/private/alignment-helpers.ss
View File

@ -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))
|#
)

39
collects/embedded-gui/private/button-snip.ss
View File

@ -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))
|#
)

31
collects/embedded-gui/private/interface.ss
View File

@ -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
))

13
collects/embedded-gui/private/snip-wrapper.ss
View File

@ -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?)

60
collects/embedded-gui/private/verthoriz-alignment.ss
View File

@ -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))))
)