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

...

Browse Source 
original commit: 6fa4a2f4674a89f38760bceacd0420aad6a57d6c
This commit is contained in:
Mike MacHenry 2004-07-15 18:04:33 +00:00
parent 9672a78b02
commit 6b1a9bfdb9
21 changed files with 1594 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

26
collects/embedded-gui/embedded-gui.ss Normal file
View File

@ -0,0 +1,26 @@
(module embedded-gui mzscheme
(require
"private/grid-alignment.ss"
"private/aligned-pasteboard.ss"
"private/interface.ss"
"private/snip-lib.ss"
"private/button-snip.ss"
"private/stretchable-editor-snip.ss"
"private/tabbable-text.ss"
"private/fixed-width-label-snip.ss"
"private/grey-editor.ss"
"private/verthoriz-alignment.ss")
(provide
(all-from "private/grid-alignment.ss")
(all-from "private/aligned-pasteboard.ss")
(all-from "private/interface.ss")
(all-from "private/snip-lib.ss")
(all-from "private/button-snip.ss")
(all-from "private/stretchable-editor-snip.ss")
(all-from "private/tabbable-text.ss")
(all-from "private/fixed-width-label-snip.ss")
(all-from "private/grey-editor.ss")
(all-from "private/verthoriz-alignment.ss"))
)

85
collects/embedded-gui/private/aligned-pasteboard.ss Normal file
View File

@ -0,0 +1,85 @@
(module aligned-pasteboard mzscheme
(provide aligned-pasteboard%)
(require
(lib "class.ss")
(lib "mred.ss" "mred")
(lib "etc.ss")
(lib "list.ss")
(lib "match.ss")
(prefix a: "alignment.ss")
(lib "click-forwarding-editor.ss" "mrlib")
"on-show-pasteboard.ss"
"really-resized-pasteboard.ss"
"interface.ss"
"snip-lib.ss"
"verthoriz-alignment.ss")
(define aligned-pasteboard%
(class (click-forwarding-editor-mixin
(on-show-pasteboard-mixin
(really-resized-pasteboard-mixin pasteboard%)))
(inherit begin-edit-sequence end-edit-sequence get-max-view-size refresh-delayed?)
(field
[alignment (new vertical-alignment%)]
[lock-alignment? false]
[needs-alignment? false])
(define/public (add i) (send alignment add i))
#|
snip : snip% object
before : snip% object or #f
x : real number
y : real number
|#
(rename [super-after-insert after-insert])
(define/override (after-insert snip before x y)
(super-after-insert snip before x y)
(realign))
#|
snip : snip% object
|#
(rename [super-after-delete after-delete])
(define/override (after-delete snip)
(super-after-delete snip)
(realign))
#|
snip : snip% object
|#
(rename [super-really-resized really-resized])
(define/override (really-resized snip)
(super-really-resized snip)
(realign))
(rename [super-on-show on-show])
(define/override (on-show)
(realign)
(super-on-show))
(define/public (lock-alignment lock?)
(set! lock-alignment? lock?)
(when (and needs-alignment? (not lock-alignment?))
(realign))
(if lock?
(begin-edit-sequence)
(end-edit-sequence)))
(define/public (realign)
(if lock-alignment?
(set! needs-alignment? true)
(fluid-let ([lock-alignment? true])
(send alignment set-min-sizes)
(let ([width (send alignment get-min-width)]
[height (send alignment get-min-height)])
(unless (or (zero? width) (zero? height))
(send alignment align 0 0 width height)
(set! needs-alignment? false))))))
(super-new)
(send alignment set-pasteboard this)))
)

29
collects/embedded-gui/private/alignment-helpers.ss Normal file
View File

@ -0,0 +1,29 @@
(module alignment-helpers mzscheme
(require
(lib "list.ss")
(lib "class.ss")
(lib "mred.ss" "mred")
"interface.ss"
"snip-lib.ss")
(provide vacuous-max
child-height
child-width)
(define (vacuous-max . n)
(if (empty? n)
0
(apply max n)))
(define (child-height item)
(cond
[(is-a? item snip%) (snip-min-height item)]
[(is-a? item alignment<%>) (send item get-min-height)]))
(define (child-width item)
(cond
[(is-a? item snip%) (snip-min-width item)]
[(is-a? item alignment<%>) (send item get-min-width)]))
)

164
collects/embedded-gui/private/alignment.ss Normal file
View File

@ -0,0 +1,164 @@
#|
This code computes the sizes for the rectangles in the space using the on dimention
off dimention method of referencing sizes. This means for example instead of saying
width we say off dimention for vertical alignment. Inorder to consume and return
the values in terms of width and height manipulation had to be done. I chose to create
a struct abs-rect (abstract rectangle) and have code map horizontal and vertical rect
stucts on to them. This code is a bit long but more readable than the other two options
I came up with.
1) define all functions to be letrec bound functions inside align. align then take
accessors for the rect struct. The caller of align swaps the order of ondimention
and off dimention accessors for vertical or horizontal code. This method does not
allow the use of the readable, short, consis pattern matching code. As some of the
matching code is easily removed this may be a good option but a large letrec
is harder to write tests for.
2) define a pattern matcher syntax that will match the struct rect but swap the fields
based on wich on is the on or off dimention. This would have been shorter but much
more confusing.
The current implementation requires align to map over the rects and allocate new stucts
for each one on both passing into and returning from stretch-to-fit; This is not a bottle
neck and it is the most readable solution.
|#
(module alignment mzscheme
(require
(lib "match.ss")
(lib "contract.ss")
(lib "etc.ss")
(lib "list.ss"))
(define-struct rect (x y) (make-inspector))
(define-struct abs-rect (ondim offdim) (make-inspector))
(define-struct dim (pos size stretchable?) (make-inspector))
(define (nonnegative? n)
(and (number? n)
(or (positive? n)
(zero? n))))
(provide/contract
(struct rect ((x dim?) (y dim?)))
(struct abs-rect ((ondim dim?) (offdim dim?)))
(struct dim ((pos nonnegative?) (size nonnegative?) (stretchable? boolean?)))
(align ((symbols 'horizontal 'vertical)
positive? positive? (listof rect?)
. -> . (listof rect?)))
(rect-print ((listof rect?) . -> . void?)))
;; align the rectangles within the given space
(define (align type width height rects)
(cond
[(symbol=? type 'horizontal)
(map abs->horiz (stretch-to-fit width height (map horiz->abs rects)))]
[(symbol=? type 'vertical)
(map abs->vert (stretch-to-fit height width (map vert->abs rects)))]))
#;(abs-rect? . -> . rect?)
;; convert an abstract rect to a horizontal rect
(define abs->horiz
(match-lambda
[($ abs-rect ondim offdim)
(make-rect ondim offdim)]))
#;(abs-rect? . -> . rect?)
;; convert an abstract rect to a vertical rect
(define abs->vert
(match-lambda
[($ abs-rect ondim offdim)
(make-rect offdim ondim)]))
#;(rect? . -> . abs-rect?)
;; convert a horizontal rect to an abstract rect
(define horiz->abs
(match-lambda
[($ rect x y)
(make-abs-rect x y)]))
#;(rect? . -> . abs-rect?)
;; convert a vertical rect to an abstract rect
(define vert->abs
(match-lambda
[($ rect x y)
(make-abs-rect y x)]))
#;(positive? positive? (listof abs-rect?) . -> . (listof abs-rect?))
;; stretch the rectangles to fit with the given space
(define (stretch-to-fit onsize offsize rects)
(let-values ([(total-unstretchable-size stretchable-sizes)
(get-onsizes rects)])
(let-values ([(extra-div extra-mod)
(get-extra/rect
(- onsize total-unstretchable-size)
(quicksort stretchable-sizes >))])
(allocate-evenly/position extra-div extra-mod offsize rects))))
#;(((listof rect?)) . ->* . (nonnegative? (listof nonnegative?)))
;; gets the unstretchable total size and a list of the stretchable sizes
(define (get-onsizes init-rects)
(let loop ([extra 0]
[stretchables empty]
[rects init-rects])
(match rects
[() (values extra stretchables)]
[(($ abs-rect ($ dim _ onsize #f) _) rest-rects ...)
(loop (+ onsize extra) stretchables rest-rects)]
[(($ abs-rect ($ dim _ onsize #t) _) rest-rects ...)
(loop extra (cons onsize stretchables) rest-rects)])))
#;((nonnegative? (listof nonnegative?)) . ->* . (nonnegative? nonnegative?))
;; get the space that each stretchable snip will have
(define (get-extra/rect init-extra init-sizes)
(let loop ([sizes init-sizes]
[extra init-extra]
[count (length init-sizes)])
(cond
[(empty? sizes) (values 0 0)]
[else
(let ([extra/rect (quotient (floor extra) count)]
[onsize (first sizes)])
(if (> onsize extra/rect)
(loop (rest sizes) (- extra onsize) (sub1 count))
(values extra/rect (modulo (floor extra) count))))])))
#;((cons/p nonnegative? nonnegative?) positive? (listof abs-rect?) . -> .
(listof abs->rect?))
;; allocate the extra per rectangle to the stretchable rects and move them to their positions
(define (allocate-evenly/position extra-div extra-mod offsize init-rects)
(let ([mod (waner extra-mod)])
(let loop ([rects init-rects]
[onpos 0])
(match rects
[() empty]
[(($ abs-rect ($ dim _ min-onsize onstretch?)
($ dim _ min-offsize offstretch?)) rest-rects ...)
(let ([onsize (if (and onstretch?
(< min-onsize extra-div))
(+ extra-div (mod)) min-onsize)]
[offsize (if offstretch? offsize min-offsize)])
(cons (make-abs-rect (make-dim onpos onsize onstretch?)
(make-dim 0 offsize offstretch?))
(loop rest-rects (+ onpos onsize))))]))))
#;(natural-number? . -> . (-> (union 1 0)))
;; makes a thunk that returns 1 for it's first n applications, zero otherwise
(define (waner n)
(lambda ()
(if (zero? n)
0
(begin
(set! n (sub1 n))
1))))
(define rect-print
(match-lambda
[() (void)]
[(($ rect
($ dim x width stretchable-width?)
($ dim y height stretchable-height?))
others ...)
(printf "(make-rect (make-dim ~s ~s ~s) (make-dim ~s ~s ~s))~n"
x width stretchable-width?
y height stretchable-height?)
(rect-print others)]))
)

148
collects/embedded-gui/private/button-snip.ss Normal file
View File

@ -0,0 +1,148 @@
(module button-snip mzscheme
(require
(lib "mred.ss" "mred")
(lib "class.ss")
(lib "etc.ss"))
(provide
text-button-snip%
button-snip%
toggle-button-snip%)
;; a snip of a button that can be pushed to invoke a given callback
(define button-snip%
(class image-snip%
(inherit load-file)
(init images)
(init-field callback)
(field
[got-click? false]
[inside? false]
[image (car images)]
[depressed (cdr images)])
;; (string? . -> . void?)
;; set the image to be displayed on the button when it is not clicked
(define/public (set-images i)
(set! image (car i))
(set! depressed (cdr i))
(load-file image))
;; Should I be calling super-on-event?
(rename [super-on-event on-event])
(define/override (on-event dc x y editorx editory event)
(case (send event get-event-type)
[(left-down)
(set! got-click? true)
(set! inside? true)
(load-file depressed)]
[(left-up)
(load-file image)
(when (and got-click? inside?)
(callback this event))
(set! got-click? false)
(set! inside? false)]
[(enter)
(set! inside? true)
(when got-click?
(load-file depressed))]
[(leave)
(set! inside? false)
(when got-click?
(load-file image))]
[else (void)]))
(super-new)
(load-file image)))
;; a textual button of the same type
(define text-button-snip%
(class string-snip%
(init label)
(init-field callback)
(field
[got-click? false]
[inside? false])
(rename [super-on-event on-event])
(define/override (on-event dc x y editorx editory event)
(case (send event get-event-type)
[(left-down)
(set! got-click? true)
(set! inside? true)]
[(left-up)
(when (and got-click? inside?)
(callback this event))
(set! got-click? false)
(set! inside? false)]
[(enter)
(set! inside? true)]
[(leave)
(set! inside? false)]
[else (void)]))
(super-make-object label)))
;; a toggle button that displays different images
(define toggle-button-snip%
(class button-snip%
(inherit set-images)
(init-field images1 images2 callback1 callback2 (state 1))
(super-new
(images images1)
(callback
(lambda (b e)
(if (= state 1)
(begin
(set-images images2)
(set! state 2)
(callback1 b e))
(begin
(set-images images1)
(set! state 1)
(callback2 b e))))))))
;;;;;;;;;;
;; tests
(require
(lib "locked-pasteboard.ss" "mrlib" "private" "aligned-pasteboard")
(lib "click-forwarding-editor.ss" "mrlib"))
(define (test)
(define f (new frame% (label "test") (width 200) (height 200)))
(define e (new (locked-pasteboard-mixin
(click-forwarding-editor-mixin pasteboard%))))
(define c (new editor-canvas% (editor e) (parent f)))
(define b (new button-snip%
(images (cons (build-path (collection-path "icons") "turn-up.gif")
(build-path (collection-path "icons") "turn-up-click.gif")))
(callback
(lambda (b e)
(message-box "Test" "Horray!")))))
(send e insert b)
(send f show #t))
(define (test2)
(define f (new frame% (label "test") (width 200) (height 200)))
(define e (new (locked-pasteboard-mixin
(click-forwarding-editor-mixin pasteboard%))))
(define c (new editor-canvas% (editor e) (parent f)))
(define t (new text%))
(define es (new editor-snip% (editor t)))
(define b (new toggle-button-snip%
(images1 (cons (build-path (collection-path "icons") "turn-up.gif")
(build-path (collection-path "icons") "turn-up-click.gif")))
(images2 (cons (build-path (collection-path "icons") "turn-down.gif")
(build-path (collection-path "icons") "turn-down-click.gif")))
(callback1
(lambda (b e)
(send* t (erase) (insert "Up"))))
(callback2
(lambda (b e)
(send* t (erase) (insert "Down"))))))
(send e insert es 50 0)
(send e insert b)
(send f show #t))
)

131
collects/embedded-gui/private/fixed-width-label-snip.ss Normal file
View File

@ -0,0 +1,131 @@
(module fixed-width-label-snip mzscheme
(require
(lib "class.ss")
(lib "list.ss")
(lib "mred.ss" "mred"))
(provide fixed-width-label-snip)
(define (fixed-width-label-snip labels)
(define label-snip%
(class snip%
(inherit set-snipclass)
(init-field
label
(with-border? #f)
(left-margin 5)
(right-margin 5)
(top-margin 5)
(bottom-margin 5)
(left-inset 1)
(top-inset 1)
(right-inset 1)
(bottom-inset 1))
(field [font (make-object font% 10 'roman 'normal 'normal)])
(unless (member label labels)
(error 'fixed-width-label-snip
"Instantiation of label-snip expected one of ~s. Given ~s"
labels
label))
(define (get-string-width dc string)
(let-values ([(width height baseline vspace)
(send dc get-text-extent string font)])
width))
(define (get-string-height dc string)
(let-values ([(width height baseline vspace)
(send dc get-text-extent string font)])
height))
(define (get-max-string-width dc strings)
(foldl
(lambda (str max-width)
(max (get-string-width dc str) max-width))
(get-string-width dc (first strings))
(rest strings)))
(define (get-max-string-height dc strings)
(foldl
(lambda (str max-height)
(max (get-string-height dc str) max-height))
(get-string-height dc (first strings))
(rest strings)))
(define/override (get-extent dc x y w h descent space lspace rspace)
(let ([width (get-max-string-width dc labels)]
[height (get-max-string-height dc labels)])
(when w (set-box! w (+ left-margin width right-margin)))
(when h (set-box! h (+ top-margin height bottom-margin)))))
(rename [super-draw draw])
(define/override (draw dc x y left top right bottom dx dy draw-caret)
(super-draw dc x y left top right bottom dx dy draw-caret)
(let ([max-width (get-max-string-width dc labels)]
[width (get-string-width dc label)]
[max-height (get-max-string-height dc labels)])
(let ([f (send dc get-font)])
(send dc set-font font)
(send dc draw-text label
(+ left-margin x (- max-width width))
(+ y top-margin))
(send dc set-font f))
(when with-border?
(let ((w (+ left-margin max-width right-margin))
(h (+ top-margin max-height bottom-margin)))
(send dc draw-lines
(list (make-object point% left-inset top-inset)
(make-object point% left-inset (- h bottom-inset))
(make-object point% (- w right-inset) (- h bottom-inset))
(make-object point% (- w right-inset) top-inset)
(make-object point% left-inset top-inset))
x
y)))))
;(rename [super-copy copy])
;(define/override (copy)
; (super-copy))
(define/override (resize w h) #f)
;; write ((is-a?/c editor-stream-out%) . -> . void?)
;; write the snip out to the stream
(define/override (write f)
(send f put label))
(super-new)
(set-snipclass (new label-snip-class%))))
(define label-snip-class%
(class snip-class%
;; read ((is-a?/c editor-stream-in%) . -> . snip%)
;; read a snip from the stream
(define/override (read f)
(new label-snip% (label (send f get-string))))
(super-new)))
(let ([lsc (new label-snip-class%)])
(send lsc set-classname "...")
(send lsc set-version 1)
(send (get-the-snip-class-list) add lsc))
label-snip%)
;;;;;;;;;;
;; tests
;(define mylabels (list "Call" "Expected" "Actual"))
;(define label% (fixed-width-label-snip mylabels))
;(define align? #t)
;(define f (new frame% (label "test") (width 175) (height 175)))
;(define e (new pasteboard%))
;(define c (new editor-canvas% (editor e) (parent f)))
;(for-each
; (lambda (s)
; (send e insert (new label% (label s))))
; '("Expected"))
;(send f show #t)
)

56
collects/embedded-gui/private/grey-editor.ss Normal file
View File

@ -0,0 +1,56 @@
(module grey-editor mzscheme
(provide grey-editor-snip-mixin grey-editor-mixin)
(require
(lib "mred.ss" "mred")
(lib "class.ss")
(lib "framework.ss" "framework"))
(define *disable-color* (make-object color% 235 235 255))
(define grey-editor-snip-mixin
(mixin ((class->interface editor-snip%)) ()
(rename [super-draw draw])
(inherit get-admin get-inset)
(define/override (draw dc x y left top right bottom dx dy draw-caret)
(let ([old-pen (send dc get-pen)]
[old-brush (send dc get-brush)]
[admin (get-admin)]
[left-inset (box 0)]
[top-inset (box 0)]
[right-inset (box 0)]
[bottom-inset (box 0)]
[xb (box 0)]
[yb (box 0)]
[wb (box 0)]
[hb (box 0)])
(when admin
(send admin get-view xb yb wb hb this)
(get-inset left-inset top-inset right-inset bottom-inset)
(send dc set-pen (send the-pen-list find-or-create-pen *disable-color* 1 'solid))
(send dc set-brush (send the-brush-list find-or-create-brush *disable-color* 'solid))
(send dc draw-rectangle
(+ x (unbox xb) (unbox left-inset))
(+ y (unbox yb) (unbox top-inset))
(max 0 (- (unbox wb) (+ (unbox left-inset) (unbox right-inset))))
(max 0 (- (unbox hb) (+ (unbox top-inset) (unbox bottom-inset)))))
(send dc set-pen old-pen)
(send dc set-brush old-brush)))
(super-draw dc x y left top right bottom dx dy draw-caret))
(super-new)))
(define grey-editor-mixin
(mixin (editor<%>) ()
(rename [super-on-paint on-paint])
(define/override (on-paint before? dc left top right bottom dx dy draw-caret)
(when before?
(let ([old-pen (send dc get-pen)]
[old-brush (send dc get-brush)])
(send dc set-pen (send the-pen-list find-or-create-pen *disable-color* 1 'solid))
(send dc set-brush (send the-brush-list find-or-create-brush *disable-color* 'solid))
(send dc draw-rectangle (+ left dx) (+ top dy) (+ right dx) (+ bottom dy))
(send dc set-pen old-pen)
(send dc set-brush old-brush)))
(super-on-paint before? dc left top right bottom dx dy draw-caret))
(super-new))))

135
collects/embedded-gui/private/grid-alignment.ss Normal file
View File

@ -0,0 +1,135 @@
(module grid-alignment mzscheme
(require
(lib "class.ss")
(lib "mred.ss" "mred")
(lib "etc.ss")
(lib "list.ss")
(lib "match.ss")
(prefix a: "alignment.ss")
(lib "click-forwarding-editor.ss" "mrlib")
"on-show-pasteboard.ss"
"really-resized-pasteboard.ss"
"interface.ss"
"snip-lib.ss"
"alignment-helpers.ss")
(provide grid-alignment%)
(define grid-alignment%
(class* object% (alignment<%>)
(init-field
columns
(parent false))
(field
[pasteboard false]
[rows empty]
[row-heights 0]
[column-widths 0]
[show? true])
;; need base class for this method
(define (show/hide-child child show?)
(if (is-a? child alignment<%>)
(send child show show?)
(if show?
(send pasteboard insert child)
(send pasteboard release-snip child))))
(define/public (add row)
(set! rows (append rows (list row)))
(unless (= (vector-length row) columns)
(error 'add "Invalid number of rows"))
(send pasteboard lock-alignment true)
(let loop ([column 0])
(unless (>= column columns)
(let ([child (vector-ref row column)])
(cond
[(is-a? child snip%)
(when show?
(send pasteboard insert child false))]
[(is-a? child alignment<%>)
(send child set-pasteboard pasteboard)])
(loop (add1 column)))))
(send pasteboard lock-alignment false))
(define/public (set-min-sizes)
(set! column-widths
(map
(lambda (column)
(apply vacuous-max
(map (lambda (row)
(child-width
(vector-ref row column)))
rows)))
(build-list columns identity)))
(set! row-heights
(map
(lambda (row)
(apply vacuous-max
(map (lambda (column)
(child-height
(vector-ref row column)))
(build-list columns identity))))
rows)))
;; STATUS: This function currently doesn't stretch snips.
(define/public (align x-offset y-offset width height)
(define (align-row row init-x y)
(let xloop ([x init-x]
[column 0]
[widths column-widths])
(unless (or (>= column columns) (empty? widths))
(move-child (vector-ref row column) pasteboard x y)
(xloop (+ x (first widths))
(add1 column)
(rest widths)))))
(when show?
(let yloop ([y y-offset]
[the-rows rows]
[heights row-heights])
(unless (or (empty? the-rows) (empty? heights))
(align-row (first the-rows) x-offset y)
(yloop (+ y (first heights))
(rest the-rows)
(rest heights))))))
(define/public (get-min-width)
(if show?
(apply + column-widths)
0))
(define/public (get-min-height)
(if show?
(apply + row-heights)
0))
(define/public (show bool)
(define (show/hide-row row)
(let loop ([column 0])
(unless (>= column columns)
(let ([child (vector-ref row column)])
(show/hide-child child bool)
(loop (add1 column))))))
(unless (boolean=? bool show?)
(set! show? bool)
(send pasteboard lock-alignment true)
(for-each show/hide-row rows)
(send pasteboard lock-alignment false)))
(define/public (stretchable-width?) false)
(define/public (stretchable-height?) false)
(define/public (set-pasteboard pb) (set! pasteboard pb))
(super-new)
(when parent (send parent add this))))
(define (move-child child pasteboard x y)
(cond
[(is-a? child snip%)
(send pasteboard move-to child x y)]
[(is-a? child alignment<%>)
(send child align x y)]))
)

46
collects/embedded-gui/private/interface.ss Normal file
View File

@ -0,0 +1,46 @@
(module interface mzscheme
(require (lib "class.ss"))
(provide stretchable-snip<%>
alignment<%>)
(define alignment<%>
(interface ()
set-min-sizes
align
get-min-width
get-min-height
stretchable-width?
stretchable-height?
show))
#| the interface that must be implemented by a class to be inserted into an
aligned-pasteboard<%> and be stretched and shrunk according to the geometry managment.
note: any snip may be insert... those
that do not implement stretchable-snip<%> will simply not be stretched.
|#
(define stretchable-snip<%>
(interface ()
;; (positive? positive? . -> . void?)
;; called by the parent editor to stretch the snip to an specific size
stretch
;; get-aligned-min-width (-> positive?)
;; get the minimum width of the snip
get-aligned-min-width
;; get-aligned-min-height (-> positive?)
;; get the minmum height of the snip
get-aligned-min-height
;; stretchable-width (case-> (boolean . -> . void?) (-> boolean?))
;; get or set the stretchablity of the pasteboards width
stretchable-width
;; stretchable-height (case-> (boolean . -> . void?) (-> boolean?))
;; get or set the stretchablity of the pasteboards height
stretchable-height
))
)

43
collects/embedded-gui/private/on-show-pasteboard.ss Normal file
View File

@ -0,0 +1,43 @@
(module on-show-pasteboard mzscheme
(require
(lib "class.ss")
(lib "etc.ss")
(lib "mred.ss" "mred"))
(provide
on-show-pasteboard%
on-show-pasteboard-mixin)
(define (on-show-pasteboard-mixin super%)
(class super%
(field [shown? false])
(rename [super-refresh refresh])
(define/override (refresh x y w h d-c)
(super-refresh x y w h d-c)
(unless shown?
(set! shown? true)
(on-show)))
(define/public (showing?)
shown?)
(define/public (on-show)
(void))
(super-new)))
(define on-show-pasteboard%
(on-show-pasteboard-mixin
pasteboard%))
#|
(define f (new frame% (label "f") (width 400) (height 400)))
(send f show true)
(define e (new pasteboard%))
(define c (new editor-canvas% (editor e) (parent f)))
(define pb (new on-show-pasteboard%))
(define es (new editor-snip% (editor pb)))
(send e insert es)
(send pb showing?)
(send e remove es)
(not (send pb showing?))
|#
)

86
collects/embedded-gui/private/program-editor.ss Normal file
View File

@ -0,0 +1,86 @@
#|
This file contains a mixin that should be used my any embedded editor that contains
code. What is does is tells the drscheme frame that the program has changed and
drscheme can appropriately reset highlighting and display the "save" button. There
is a facility of drscheme to do this but to my knowledge it is not working properly.
|#
#|NOTES:
This code is copied from the test suite tool and the test suite tool should be
rewritten to use this copy of the program. This is not a trivial change since the
alert-of-modify method in test-suite is currently clearing the test cases to reset
them.
This code can be replaced by drscheme:unit:program-editor-mixin when I figure out how
to make the results of the test case boxes be reset when (and only when) highlighting
is being reset.
|#
(module program-editor mzscheme
(require
(lib "mred.ss" "mred")
(lib "etc.ss")
(lib "class.ss")
"snip-lib.ss")
(provide program-editor-mixin)
(define (program-editor-mixin %)
(class %
(inherit get-admin begin-edit-sequence end-edit-sequence)
(rename [super-after-insert after-insert]
[super-after-delete after-delete])
(define (get-frame)
;; gets the top most editor in the tree of snips and editors
(define (editor-root ed)
(let ([parent (editor-parent ed)])
(cond
[(is-a? parent area<%>) parent]
[(is-a? parent snip%)
(editor-root (snip-parent parent))]
[else false])))
;; gets the canvas or snip that the pasteboard is displayed in
;; status: what if there is more than one canvas?
(define (editor-parent ed)
(let ([admin (send ed get-admin)])
(cond
[(is-a? admin editor-snip-editor-admin<%>)
(send admin get-snip)]
[(is-a? admin editor-admin%)
(send ed get-canvas)]
[else false])))
(let ([er (editor-root this)])
(if er
(send er get-top-level-window)
false)))
(define (alert-of-modify)
(let ([frame (get-frame)])
(when frame
(send (send frame get-interactions-text) reset-highlighting)
(send* (send frame get-definitions-text)
(set-modified true)))))
;(rename [super-on-insert on-insert])
;(define/override (on-insert start len)
; (begin-edit-sequence)
; (super-on-insert start len)
; (end-edit-sequence))
(define/override (after-insert start len)
(alert-of-modify)
;(begin-edit-sequence)
(super-after-insert start len)
;(end-edit-sequence)
)
(define/override (after-delete start len)
(alert-of-modify)
(super-after-delete start len))
(super-new)))
)

85
collects/embedded-gui/private/really-resized-pasteboard.ss Normal file
View File

@ -0,0 +1,85 @@
#|
This module provides a really-resized pasteboard that calls the really-resized
method when a snip in the editor is really resized, not when pasteboard says
it's resized. This file was written because sometimes I need to override resized
to adjust my editors layout however the resized method of the pasteboard is
invoked whenever editor snips get focus, lose focus, get text typed into them,
get text deteleted from them, etc.
|#
(module really-resized-pasteboard mzscheme
(require
(lib "etc.ss")
(lib "class.ss")
(lib "mred.ss" "mred"))
(provide
really-resized-pasteboard-mixin
really-resized-pasteboard%)
(define (really-resized-pasteboard-mixin super%)
(class super%
(inherit refresh-delayed? get-snip-location)
(field [snip-cache (make-hash-table)]
[ignore-resizing? false])
;; Called whenever a snip within the editor is resized, just like the
;; resized method but excludes suchs events as when and editor-snip gets
;; focus.
(define/public (really-resized snip) (void))
#|
snip : snip% object
redraw-now? : boolean
|#
(rename [super-resized resized])
(define/override (resized snip redraw-now?)
(super-resized snip redraw-now?)
(unless ignore-resizing?
(let ([size (snip-size snip)])
(unless (equal? size (hash-table-get snip-cache snip))
(hash-table-put! snip-cache snip size)
(really-resized snip)))))
#|
snip : snip% object
before : snip% object or #f
x : real number
y : real number
|#
(rename [super-after-insert after-insert])
(define/override (after-insert snip before x y)
(super-after-insert snip before x y)
(hash-table-put! snip-cache snip (snip-size snip)))
#|
snip : snip% object
|#
(rename [super-after-delete after-delete])
(define/override (after-delete snip)
(super-after-delete snip)
(hash-table-remove! snip-cache snip))
#;((is-a?/c snip%) . -> . (cons/p natural-number? natural-number?))
;; The width and height of the given snip in this pasteboard.
(define (snip-size snip)
(let ([top (box 0)]
[bottom (box 0)]
[left (box 0)]
[right (box 0)])
(fluid-let ([ignore-resizing? true])
(get-snip-location snip left top false)
(get-snip-location snip right bottom true))
(cons (- (unbox right) (unbox left))
(- (unbox bottom) (unbox top)))))
(super-new)
))
(define really-resized-pasteboard%
(really-resized-pasteboard-mixin
pasteboard%))
)

119
collects/embedded-gui/private/snip-lib.ss Normal file
View File

@ -0,0 +1,119 @@
#| WARNING: DUPLICATED FILE |#
(module snip-lib mzscheme
(require
(lib "class.ss")
(lib "etc.ss")
(lib "mred.ss" "mred")
(lib "list.ss")
(lib "contract.ss")
"interface.ss")
;; a snip
(define snip? (is-a?/c snip%))
;; a snip to act as the varying argument to a recursive functions
(define linked-snip? (union snip? false?))
;; a function to act on snips being mapped
(define snip-visitor? any? #;((snip?) (listof any?) . ->* . (void)))
;; the rest of the lists passed to a snip mapping function
(define rest-lists? (listof (listof any?)))
;; a class that contains a snip
(define editor? (is-a?/c editor<%>))
(provide/contract
(snip-width (snip? . -> . number?))
(snip-height (snip? . -> . number?))
(snip-min-width (snip? . -> . number?))
(snip-min-height (snip? . -> . number?))
(snip-parent (snip? . -> . (union editor? false?)))
(fold-snip ((snip? any? . -> . any?) any? linked-snip? . -> . any?))
(for-each-snip any? #;((snip-visitor? linked-snip?) rest-lists? . ->* . (void)))
(map-snip any? #;((snip-visitor? linked-snip?) rest-lists? . ->* . ((listof any?))))
(stretchable-width? (snip? . -> . boolean?))
(stretchable-height? (snip? . -> . boolean?)))
;; the width of a snip in the parent pasteboard
(define (snip-width snip)
(let ([left (box 0)]
[right (box 0)]
[pasteboard (snip-parent snip)])
(send pasteboard get-snip-location snip left (box 0) false)
(send pasteboard get-snip-location snip right (box 0) true)
(- (unbox right) (unbox left))))
;; the height of a snip in the parent pasteboard
(define (snip-height snip)
(let ([top (box 0)]
[bottom (box 0)]
[pasteboard (snip-parent snip)])
(send pasteboard get-snip-location snip (box 0) top false)
(send pasteboard get-snip-location snip (box 0) bottom true)
(- (unbox bottom) (unbox top))))
;; the minimum width of the snip
(define (snip-min-width snip)
(cond
[(is-a? snip stretchable-snip<%>)
(send snip get-aligned-min-width)]
[else (snip-width snip)]))
;; the minimum height of the snip
(define (snip-min-height snip)
(cond
[(is-a? snip stretchable-snip<%>)
(send snip get-aligned-min-height)]
[else (snip-height snip)]))
;; the pasteboard that contains the snip
(define (snip-parent snip)
(let ([admin (send snip get-admin)])
(if admin
(send admin get-editor)
false)))
;; the application of f on all snips from snip to the end in a foldl foldr mannor
(define (fold-snip f init-acc snip)
(let loop ([snip snip]
[acc init-acc])
(cond
[(is-a? snip snip%)
(loop (send snip next) (f snip acc))]
[else acc])))
;; applies the function to all the snips
(define (for-each-snip f first-snip . init-lists)
(let loop ([snip first-snip]
[lists init-lists])
(cond
[(is-a? snip snip%)
(apply f (cons snip (map first lists)))
(loop (send snip next)
(map rest lists))]
[else (void)])))
;; a list of f applied to each snip
(define (map-snip f first-snip . init-lists)
(let loop ([snip first-snip]
[lists init-lists])
(cond
[(is-a? snip snip%)
(cons (apply f (cons snip (map first lists)))
(loop (send snip next)
(map rest lists)))]
[else empty])))
;; true if the snip can be resized in the x dimention
(define (stretchable-width? snip)
(cond
[(is-a? snip stretchable-snip<%>)
(send snip stretchable-width)]
[else false]))
;; true if the snip can be resized in the y dimention
(define (stretchable-height? snip)
(cond
[(is-a? snip stretchable-snip<%>)
(send snip stretchable-height)]
[else false]))
)

119
collects/embedded-gui/private/stretchable-editor-snip.ss Normal file
View File

@ -0,0 +1,119 @@
(module stretchable-editor-snip mzscheme
(provide
stretchable-editor-snip%
stretchable-editor-snip-mixin)
(require
(lib "class.ss")
(lib "mred.ss" "mred")
(lib "etc.ss")
"interface.ss")
(define (stretchable-editor-snip-mixin super%)
(class* super% (stretchable-snip<%>)
(init
(stretchable-width true)
(stretchable-height true))
(field
(aligned-min-width 0)
(aligned-min-height 0)
(stretchable-width-field stretchable-width)
(stretchable-height-field stretchable-height))
(public (stretchable-width-method stretchable-width)
(stretchable-height-method stretchable-height))
;; stretchable-width (case-> (Boolean . -> . (void)) (-> Boolean))
;; get or set the stretchablity of the pasteboards width
(define stretchable-width-method
(case-lambda
[(value) (set! stretchable-width-field value)]
[() stretchable-width-field]))
;; stretchable-height (case-> (Boolean . -> .(void)) (-> Boolean))
;; get or set the stretchablity of the pasteboards height
(define stretchable-height-method
(case-lambda
[(value) (set! stretchable-height-field value)]
[() stretchable-height-field]))
(define/public (get-aligned-min-width) aligned-min-width)
(define/public (get-aligned-min-height) aligned-min-height)
(inherit get-margin get-editor get-admin)
(define/override (resize w h)
(set! aligned-min-width w)
(set! aligned-min-height h)
(super-resize w h))
(define/public (stretch w h)
(super-resize w h))
(rename [super-get-extent get-extent])
(define/override (get-extent dc x y w h descent space lspace rspace)
(super-get-extent dc x y w h descent space lspace rspace)
(when (is-a? (get-editor) text%)
(set-box! w (sub1 (unbox w))))
(go))
(define/override (set-min-width w)
;; account for margin !!!!!!
(send (get-editor) set-min-width w))
(define/override (set-min-height h)
;; account for margin !!!!!!
(send (get-editor) set-min-height h))
;; NOTE: Can I make this not public? I don't think it
;; should be but it's been a while since I wrote this class.
(rename [super-set-min-width set-min-width]
[super-set-min-height set-min-height])
(define/public (super-resize w h)
(let ((top (box 0))
(bot (box 0))
(lef (box 0))
(rit (box 0)))
(get-margin top bot lef rit)
(let ((w (max (- w (unbox lef) (unbox rit)) 0))
(h (max (- h (unbox top) (unbox bot)) 0))
(e (get-editor))
(a (get-admin)))
;; subtracting 1 from W seems to make it act more like the editor-snip
;; because the C code has a hack to sub1 to make it look better. I am not
;; sure if this change here is sound and works for every part of this
;; class.
(if (> w aligned-min-width)
(super-set-min-width w)
(super-set-min-width 'none))
(if (> h aligned-min-height)
(super-set-min-height h)
(super-set-min-height 'none))
(when a (send a resized this #t)))))
;; call this from within get extent and use the values it produces by subtracting the
;; margin instead of calling the editors get-extent and adding the margin.
(define (go)
(let ([w (box 0)]
[h (box 0)]
(top (box 0))
(bot (box 0))
(lef (box 0))
(rit (box 0)))
(get-margin top bot lef rit)
(send (get-editor) get-extent w h)
(set! aligned-min-width (+ (unbox w) (unbox lef) (unbox rit)))
(set! aligned-min-height (+ (unbox h) (unbox top) (unbox rit)))))
(super-new)
(inherit get-min-width get-min-height)
(set-min-width (get-min-width))
(set-min-height (get-min-height))))
(define stretchable-editor-snip%
(stretchable-editor-snip-mixin
editor-snip%))
)

56
collects/embedded-gui/private/tabbable-text.ss Normal file
View File

@ -0,0 +1,56 @@
(module tabbable-text mzscheme
(require
(lib "class.ss")
(lib "list.ss")
(lib "etc.ss")
(lib "framework.ss" "framework")
(lib "mred.ss" "mred")
(lib "contract.ss"))
(define tabbable-text<%> (interface () set-caret-owner))
(provide/contract
(tabbable-text<%> interface?)
(tabbable-text-mixin mixin-contract)
(set-tabbing (() (listof (is-a?/c tabbable-text<%>)) . ->* . (void?))))
(define tabbable-text-mixin
(mixin (editor:keymap<%>) (tabbable-text<%>)
(init-field
[ahead void]
[back void])
;; get-keymaps (-> (listof keymap%))
;; the list of keymaps associated with this text
(rename [super-get-keymaps get-keymaps])
(define/override (get-keymaps)
(let ([keymap (make-object keymap%)])
(send keymap add-function "tab-ahead"
(lambda (ignored event)
(ahead)))
(send keymap map-function ":tab" "tab-ahead")
(send keymap add-function "tab-back"
(lambda (ignored event)
(back)))
(send keymap map-function "s:tab" "tab-back")
(cons keymap (super-get-keymaps))))
(define/public (set-ahead t) (set! ahead t))
(define/public (set-back t) (set! back t))
(super-new)))
;; sets the tabbing of all of the texts in the order of the list
(define (set-tabbing . l)
(cond
[(or (empty? l) (empty? (rest l))) (void)]
[else
(send (first l) set-ahead
(lambda () (send (second l) set-caret-owner false 'global)))
(send (second l) set-back
(lambda () (send (first l) set-caret-owner false 'global)))
(apply set-tabbing (rest l))]))
)

30
collects/embedded-gui/private/tests/alignment-test.ss Normal file
View File

@ -0,0 +1,30 @@
(require
(lib "class.ss")
(lib "etc.ss")
(lib "mred.ss" "mred")
(lib "print-debug.ss" "mike-lib")
"../stretchable-editor-snip.ss"
"../verthoriz-alignment.ss"
"../aligned-pasteboard.ss"
"../grid-alignment.ss")
(define f (new frame% (label "f") (height 500) (width 500)))
(send f show true)
(define a1 (new aligned-pasteboard%))
(define c (new editor-canvas% (editor a1) (parent f)))
(define a2 (new horizontal-alignment% (parent a1)))
(define a3 (new horizontal-alignment% (parent a1)))
(define a4 (new grid-alignment% (parent a1) (columns 4)))
(send a2 add (make-object string-snip% "One"))
(send a2 add (make-object string-snip% "Two"))
(send a3 add (make-object string-snip% "Three"))
(send a3 add (make-object string-snip% "Four"))
(send a4 add (vector (make-object string-snip% "This is really long")
(new editor-snip% (editor (new text%)))
(make-object string-snip% "short")
(make-object string-snip% "meduim")))
(send a4 add (vector (make-object string-snip% "short")
(make-object string-snip% "This is really long")
(new editor-snip% (editor (new text%)))
(make-object string-snip% "meduim")))
(send f show true)

31
collects/embedded-gui/private/tests/not-stetching.ss Normal file
View File

@ -0,0 +1,31 @@
(module not-stetching mzscheme
(require
(lib "debug.ss" "mike-lib")
(lib "class.ss")
(lib "etc.ss")
(lib "mred.ss" "mred")
(lib "aligned-pasteboard.ss" "embedded-gui")
(lib "stretchable-editor-snip.ss" "embedded-gui")
(lib "verthoriz-alignment.ss" "embedded-gui"))
(define traced-ses%
(override/trace stretchable-editor-snip%
(stretch
get-aligned-min-width
get-aligned-min-height
stretchable-width
stretchable-height)))
(define f (new frame% (label "f") (width 400) (height 400)))
(define e (new text%))
(define c (new editor-canvas% (parent f) (editor e)))
(define main (new aligned-pasteboard%))
(define j (new editor-snip% (editor main)))
(define line (new horizontal-alignment% (parent main)))
(define ses (new traced-ses% (editor (new text%))))
(send line add ses)
(send main add (make-object string-snip% "super duper very long snip"))
(send e insert j)
(send f show true)
)

25
collects/embedded-gui/private/tests/peer-stretchables.ss Normal file
View File

@ -0,0 +1,25 @@
(require
(lib "class.ss")
(lib "etc.ss")
(lib "mred.ss" "mred")
"../stretchable-editor-snip.ss"
"../verthoriz-alignment.ss"
"../aligned-pasteboard.ss")
(define f (new frame% (label "f") (width 400) (height 400)))
(define e (new text%))
(define c (new editor-canvas% (parent f) (editor e)))
(define main (new aligned-pasteboard%))
(define horiz (new vertical-alignment% (parent main)))
(define es (new editor-snip% (editor main)))
(define ses1 (new stretchable-editor-snip% (editor (new text%))))
(define ses2 (new stretchable-editor-snip% (editor (new text%))))
(send* horiz (add ses1) (add ses2))
(send e insert es)
(send f show true)
(let ([e (send ses2 get-editor)]
[ses1-mw (send ses1 get-min-width)])
(send e insert "sdflsdfnsknbskdlf")
(send e erase)
(equal? ses1-mw (send ses1 get-min-width)))

30
collects/embedded-gui/private/tests/stretching-in-alignment.ss Normal file
View File

@ -0,0 +1,30 @@
(module stretching-in-alignment mzscheme
(require
(lib "mred.ss" "mred")
(lib "etc.ss")
(lib "class.ss")
(lib "interface.ss" "mrlib" "private" "aligned-pasteboard")
(lib "debug.ss" "mike-lib")
(lib "list.ss")
(lib "match.ss")
(prefix a: "alignment.ss")
(lib "click-forwarding-editor.ss" "mrlib")
(lib "snip-lib.ss" "mrlib" "private" "aligned-pasteboard")
(lib "aligned-pasteboard.ss" "embedded-gui")
(lib "stretchable-editor-snip.ss" "embedded-gui"))
(define f (new frame% (label "f") (width 400) (height 400)))
(define e (new text%))
(define c (new editor-canvas% (editor e) (parent f)))
(define pb (new aligned-pasteboard%))
(define es (new editor-snip% (editor pb)))
(define ses (new (stretchable-editor-snip-mixin editor-snip%)
(editor (new text%))))
(send* pb
(add (new (stretchable-editor-snip-mixin editor-snip%)
(editor (new text%))))
(add (make-object string-snip% "This snip is very long")))
(send e insert es)
(send f show true)
)

20
collects/embedded-gui/private/tests/unaligned-childless-redux.ss Normal file
View File

@ -0,0 +1,20 @@
(require (lib "aligned-pasteboard.ss" "embedded-gui")
(lib "debug.ss" "mike-lib"))
(define f (new frame% (label "f") (width 100) (height 100)))
(define e (new text%))
(define c (new editor-canvas% (parent f) (editor e)))
(define main (new aligned-pasteboard%))
(define j (new editor-snip% (editor main)))
(define line (new horizontal-alignment% (parent main)))
(send e insert j)
(zero? (send line get-min-width))
(send line add (make-object string-snip% "foo"))
(send line add (make-object string-snip% "foo"))
(send f show #t)
;; If the following test case is delayed it's true.
;; is this a problem? It could be if this attempt
;; to read the min-width when aligning. However, this
;; program prints out foofoo like it should and doesn't
;; overlap them so maybe we're okay.
(not (zero? (send line get-min-width)))

130
collects/embedded-gui/private/verthoriz-alignment.ss Normal file
View File

@ -0,0 +1,130 @@
(module verthoriz-alignment mzscheme
(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")
(provide
horizontal-alignment%
vertical-alignment%)
(define (vert/horiz-alignment type)
(class* object% (alignment<%>)
(init-field (parent false))
(field
[pasteboard false]
[children empty]
[min-width 0]
[min-height 0]
[show? true])
;; need base class for this method
(define (show/hide-child child show?)
(if (is-a? child alignment<%>)
(send child show show?)
(if show?
(send pasteboard insert child)
(send pasteboard release-snip child))))
;; STATUS: This function (through lock-alignment false) invokes a call
;; to realign of the pasteboard even when this alignement has show? = false
;; so the call is not needed.
(define/public (add child)
(set! children (append children (list child)))
(send pasteboard lock-alignment true)
(cond
[(is-a? child snip%)
(when show?
(send pasteboard insert child false))]
[(is-a? child alignment<%>)
(send child set-pasteboard pasteboard)])
(send pasteboard lock-alignment false))
(define/public (get-min-width)
(if show? min-width 0))
(define/public (get-min-height)
(if show? min-height 0))
(define/public (set-pasteboard pb) (set! pasteboard pb))
(define/public (stretchable-width?) true)
(define/public (stretchable-height?) true)
(define/public (show bool)
(unless (boolean=? bool show?)
(set! show? bool)
(send pasteboard lock-alignment true)
(for-each (lambda (c)
(show/hide-child c bool))
children)
(send pasteboard lock-alignment false)))
(define/public (align x-offset y-offset width height)
(define move/resize
(match-lambda*
[(child ($ a:rect
($ a:dim x w stretchable-width?)
($ a:dim y h stretchable-height?)))
(let ([global-x (+ x x-offset)]
[global-y (+ y y-offset)])
(cond
[(is-a? child snip%)
(send pasteboard move-to child global-x global-y)
(when (or stretchable-width? stretchable-height?)
(send child stretch w h))]
[(is-a? child alignment<%>)
(send child align global-x global-y w h)]))]))
(when (and show? (not (empty? children)))
(for-each move/resize
children
(a:align type width height
(map build-rect children)))))
(define/public (set-min-sizes)
(when show?
(for-each
(lambda (child)
(when (is-a? child alignment<%>)
(send child set-min-sizes)))
children)
(let-values ([(x-accum y-accum)
(if (symbol=? type 'vertical)
(values vacuous-max +)
(values + vacuous-max))])
(set! min-width
(apply x-accum
(map child-width
children)))
(set! min-height
(apply y-accum
(map child-height
children))))))
(super-new)
(when parent (send parent add this))))
(define vertical-alignment% (vert/horiz-alignment 'vertical))
(define horizontal-alignment% (vert/horiz-alignment 'horizontal))
;; build-rect ((is-a?/c snip%) . -> . rect?)
;; makes a new default rect out of a snip
(define (build-rect item)
(cond
[(is-a? item snip%)
(a:make-rect
(a:make-dim 0 (snip-min-width item) (stretchable-width? item))
(a:make-dim 0 (snip-min-height item) (stretchable-height? item)))]
[(is-a? item alignment<%>)
(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?)))]))
)