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

Remove guibuilder. See mred-designer on planet for a maintained alterative.

Browse Source
This commit is contained in:
Sam Tobin-Hochstadt 2012-02-17 10:20:59 -05:00
parent b890f7d907
commit 8378b742c7
30 changed files with 0 additions and 3380 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

583
collects/guibuilder/base.rkt
View File

@ -1,583 +0,0 @@
(module base mzscheme
(require (prefix mred: mred)
mzlib/class
mzlib/file
mzlib/pretty
mzlib/etc
mzlib/list
"utils.rkt")
(define GB:SNIP-VERSION 5)
(define MINOR-VERSION 0)
;; Info about the output mode:
(define-struct output-mode (as-class? no-free-vars?))
(define gb:snip%
(class mred:snip%
(init-field [lm 5][tm 5][rm 5][bm 5])
(inherit get-admin set-snipclass set-count)
(private-field
(need-recalc? #t)
(prev-min-w 0)
(prev-min-h 0))
(field
[x 0]
[stable-x 0]
[y 0]
[stable-y 0]
[w (+ lm rm)]
[h (+ tm bm)]
[spacing 3]
[hilited? #f])
(public*
[spacing-+
(lambda args
(+ (apply + args)
(let ([c (let loop ([l args])
(cond
[(null? l) 0]
[(zero? (car l)) (loop (cdr l))]
[else (add1 (loop (cdr l)))]))])
(if (positive? c)
(* spacing (sub1 c))
0))))])
(public*
[init-horizontal-child-alignment (lambda () 2)]
[init-vertical-child-alignment (lambda () 2)]
[init-name (lambda () (new-name "item"))]
[get-classname (lambda () "gb:core")]
[container? (lambda () #t)]
[init-y-stretch? (lambda () #t)]
[init-x-stretch? (lambda () #t)])
(field
[horizontal-child-alignment (init-horizontal-child-alignment)]
[vertical-child-alignment (init-vertical-child-alignment)]
[with-border? #f]
[dialog #f]
[name (init-name)]
[id #f]
[original-id #f]
[original-children-ids #f]
(parent #f)
(pb #f)
(children null)
(y-stretch? (init-y-stretch?))
(x-stretch? (init-x-stretch?)))
(public*
(set-id (lambda (x) (set! id x)))
(set-horizontal-child-alignment
(lambda (v) (set! horizontal-child-alignment v)))
(set-vertical-child-alignment
(lambda (v) (set! vertical-child-alignment v)))
(set-with-border
(lambda (v) (set! with-border? v)))
(get-frame%
(lambda ()
(class mred:frame%
(init-field do-on-close)
(inherit show)
(public*
[get-kind (lambda () "Panel")]
[on-main (lambda (x) x)]
[find-control (lambda (tag) #f)])
(super-make-object (format "~a Settings" (get-kind)) #f 200 10)
(private-field
[main (on-main (make-object mred:vertical-panel% this))]
[name-edit (make-one-line/callback-edit main "Scheme Name:"
(lambda (txt)
(set! name txt))
name)])
(field
[controls (make-object mred:vertical-panel% main)])
(augment*
[on-close (lambda () (do-on-close))])
(send controls set-alignment 'left 'center)
(let* ([p (make-object mred:vertical-panel% main)]
[make-sc
(lambda (name set)
(make-object mred:check-box%
name
p
(lambda (c e)
(set (send c get-value))
(gb-need-recalc-size))))]
[xsc (make-sc "Allow Horizontal Stretching"
(lambda (on?) (set! x-stretch? on?)))]
[ysc (make-sc "Allow Vertical Stretching"
(lambda (on?) (set! y-stretch? on?)))])
(send p set-alignment 'left 'center)
(send xsc set-value x-stretch?)
(send ysc set-value y-stretch?)
(let ([p (make-object mred:vertical-panel% p)])
(send p stretchable-height #f))))))
(gb-add-child
(case-lambda
[(c) (gb-add-child c (length children))]
[(c pos)
(set! children
(let loop ([l children][p pos])
(cond
[(or (zero? p) (null? l)) (cons c l)]
[else (cons (car l) (loop (cdr l) (sub1 p)))])))
(when pb
(send c gb-install pb this)
(send pb insert c (send pb find-first-snip) x (+ y h)))
(gb-need-recalc-size)]))
(gb-remove-child
(lambda (c)
(set! children (remq c children))
(gb-need-recalc-size)))
(gb-need-recalc-size
(lambda ()
(set! need-recalc? #t)
(resized)))
(gb-install
(lambda (pb-in parent-in)
(set! parent parent-in)
(if pb
(when parent
(send pb set-before this parent))
(set! pb pb-in))
(set! id (send pb new-id))
(for-each
(lambda (c)
(send pb insert c (send pb find-first-snip) x (+ y h))
(send c gb-install pb this))
children)))
(gb-get-child-x-start
(lambda (mw mh w h)
0))
(gb-get-child-y-start
(lambda (mw mh w h)
(if (or (= vertical-child-alignment 1)
(ormap (lambda (c) (gb-y-stretch? c)) children))
0
(case vertical-child-alignment
[(2) (/ (- h mh) 2)]
[(3) (- h mh)]))))
(gb-combine-child-width (lambda (a b) (max a b)))
(gb-combine-child-height (lambda (a b) (spacing-+ a b)))
(gb-compute-child-x-pos
(lambda (dc c w)
(if (gb-x-stretch? c)
0
(case horizontal-child-alignment
[(2) (let-values ([(cw ch) (send c gb-get-min-size dc)])
(/ (- w cw) 2))]
[(1) 0]
[(3) (let-values ([(cw ch) (send c gb-get-min-size dc)])
(- w cw))]))))
(gb-compute-child-y-pos
(lambda (dc c h)
0))
(gb-compute-child-width
(lambda (dc c w xsc dw)
(if (gb-x-stretch? c)
w
(let-values ([(cw ch) (send c gb-get-min-size dc)])
cw))))
(gb-compute-child-height
(lambda (dc c h ysc dh)
(let-values ([(cw ch) (send c gb-get-min-size dc)])
(if (gb-y-stretch? c)
(+ ch (/ dh ysc))
ch))))
(gb-combine-child-x-offset (lambda (a b) a))
(gb-combine-child-y-offset (lambda (a b) (spacing-+ a b)))
(gb-get-min-size
(lambda (dc)
(let loop ([lw 0][lh 0][l children])
(cond
[(null? l) (let* ([w (+ lw lm rm)]
[h (+ lh tm bm)])
(set! prev-min-h h)
(values w h))]
[else
(let ([c (car l)])
(let-values ([(cw ch) (send c gb-get-min-size dc)])
(loop (gb-combine-child-width lw cw)
(gb-combine-child-height lh ch)
(cdr l))))]))))
(gb-set-shape
(lambda (dc x-in y-in w-in h-in)
(let*-values ([(xsc) (apply + (map
(lambda (c) (if (gb-x-stretch? c) 1 0))
children))]
[(ysc) (apply + (map
(lambda (c) (if (gb-y-stretch? c) 1 0))
children))]
[(mw mh) (gb-get-min-size dc)]
[(ew eh) (values (- w-in lm rm) (- h-in tm bm))]
[(dw dh) (values (- w-in mw) (- h-in mh))])
(let loop ([lx (+ lm x-in (gb-get-child-x-start mw mh w-in h-in))]
[ly (+ tm y-in (gb-get-child-y-start mw mh w-in h-in))]
[l children])
(cond
[(null? l) 0]
[else
(let ([c (car l)])
(let-values ([(cw ch)
(send c gb-set-shape dc
(+ lx (gb-compute-child-x-pos dc c ew))
(+ ly (gb-compute-child-y-pos dc c eh))
(gb-compute-child-width dc c ew xsc dw)
(gb-compute-child-height dc c eh ysc dh))])
(loop (gb-combine-child-x-offset lx cw)
(gb-combine-child-y-offset ly ch)
(cdr l))))])))
(unless parent
(when (and pb (not (and (= w w-in) (= h h-in))))
(send pb top-resized this w h w-in h-in)))
(set! x x-in)
(set! y y-in)
(set! w w-in)
(set! h h-in)
(resized)
(when pb
(send pb move-to this x-in y-in))
(values w-in h-in)))
(find-position-<
(lambda (fx fy cx cy)
(< fy cy)))
(gb-find-position
(lambda (fx fy)
(let loop ([l children][pos 0])
(if (null? l)
pos
(let*-values ([(c) (car l)]
[(cx) (send c gb-get-stable-x)]
[(cy) (send c gb-get-stable-y)]
[(w h) (send c gb-get-size)])
(if (find-position-< fx fy (+ cx w) (+ cy h))
pos
(loop (cdr l) (add1 pos))))))))
(gb-get-child-pos
(lambda (c)
(let loop ([l children][pos 0])
(cond
[(null? l) pos]
[(eq? (car l) c) pos]
[else (loop (cdr l) (add1 pos))]))))
(gb-get-saved-min-size
(lambda ()
(values prev-min-w prev-min-h)))
(gb-recalc-size
(lambda (dc)
(if parent
(send parent gb-recalc-size dc)
(let-values ([(mw mh) (gb-get-min-size dc)]
[(xb) (box 0)]
[(yb) (box 0)])
(when pb
(send pb get-snip-location this xb yb #f)
(send pb get-main-location this dc xb yb))
(gb-set-shape dc (unbox xb) (unbox yb)
(if x-stretch? (max w mw) mw)
(if y-stretch? (max h mh) mh))))))
(gb-hilite
(lambda (on?)
(unless (eq? on? hilited?)
(set! hilited? on?)
(refresh))))
(gb-get-parent
(lambda () parent))
(gb-get-children
(lambda () children))
(gb-get-size
(lambda () (values w h)))
(gb-get-x (lambda () x))
(gb-get-y (lambda () y))
(gb-get-stable-x (lambda () stable-x))
(gb-get-stable-y (lambda () stable-y))
(gb-get-position-and-size
(lambda () (values x y w h)))
(gb-set-stable-position
(lambda ()
(set! stable-x x)
(set! stable-y y)))
(gb-drag-children-along
(lambda (new-x new-y)
(when (not (and (= x new-x) (= y new-y)))
(for-each
(lambda (c)
(let ([cx (+ new-x (- (send c gb-get-stable-x) stable-x))]
[cy (+ new-y (- (send c gb-get-stable-y) stable-y))])
(send pb move-to c cx cy)
(send c gb-drag-children-along cx cy)))
children)
(set! x new-x)
(set! y new-y))))
(gb-open-dialog
(lambda ()
(if dialog
(send dialog show #t)
(let ([f (make-object (get-frame%) (lambda () (set! dialog #f)))])
(set! dialog f)
(send f show #t)))))
(gb-reconnect-to-original-children
(lambda ()
(if original-children-ids
(let ([sl (map
(lambda (id) (send pb find-snip-by-original-id id))
original-children-ids)])
(set! original-children-ids #f)
(for-each
(lambda (s)
(when s
(gb-add-child s)
(send pb remove-selected s)))
sl)
#t)
#f)))
(gb-forget-original-id
(lambda ()
;; Make unique name
(let ([orig-name name])
(set! name #f)
(let loop ([new-name orig-name])
(if (send pb find-snip-by-name new-name)
(loop (string-append new-name "+"))
(set! name new-name))))
(set! original-id #f)
(set! original-children-ids #f)))
(gb-get-instantiate-class-getter
(lambda ()
`(,(string->symbol (string-append "get-" name "%")))))
(gb-get-style
(lambda ()
(if with-border?
'(border)
null)))
(gb-local-instantiate
(lambda (parent mode)
`(new ,(if (output-mode-as-class? mode)
(gb-get-instantiate-class-getter)
(gb-get-default-class))
[parent ,parent]
,@(gb-instantiate-arguments))))
(gb-instantiate-arguments
(lambda () `([style ',(gb-get-style)]
[stretchable-width ,x-stretch?]
[stretchable-height ,y-stretch?])))
(gb-get-default-class (lambda () 'vertical-panel%))
(gb-aux-instantiate
(lambda (mode)
(if (output-mode-as-class? mode)
`((public* [,(string->symbol (string-append "get-" name "%"))
(lambda () ,(gb-get-default-class))]))
null)))
(gb-instantiate
(lambda (parent mode)
(let ([v (gb-local-instantiate parent mode)]
[name (string->symbol name)])
`(,@(gb-aux-instantiate mode)
,(if (output-mode-as-class? mode)
`(field [,name ,v])
`(define ,name ,v))
,@(apply append
(map (lambda (c) (send c gb-instantiate name mode)) children))))))
(draw-box
(lambda (dc x y w h)
(let* ((xw (sub1 (+ x w)))
(yh (sub1 (+ y h)))
(x (add1 x))
(y (add1 y)))
(send dc draw-line x y xw y)
(send dc draw-line xw y xw yh)
(send dc draw-line x yh xw yh)
(send dc draw-line x y x yh))))
(base-setup
(lambda (nm xs? ys? nw nh hca vca wb? id children-ids)
(set! name nm)
(set! x-stretch? xs?)
(set! y-stretch? ys?)
(set! w nw)
(set! h nh)
(set! horizontal-child-alignment hca)
(set! vertical-child-alignment vca)
(set! with-border? wb?)
(set! original-id id)
(set! original-children-ids children-ids)))
[get-tagged-value
(lambda (tag) #f)]
[set-tagged-value (lambda (t v-in) (void))]
(refresh
(lambda ()
(let ([admin (get-admin)])
(when admin
(send admin needs-update this 0 0 w h)))))
(resized
(lambda ()
(let ([admin (get-admin)])
(when admin
(send admin resized this #t))))))
(override*
(get-extent
(lambda (dc x y wbox hbox descentbox spacebox
lspacebox rspacebox)
(when need-recalc?
(set! need-recalc? #f)
(gb-recalc-size dc))
(when hbox
(set-box! hbox h))
(when wbox
(set-box! wbox w))
(when descentbox
(set-box! descentbox 0))
(when spacebox
(set-box! spacebox 0))
(when rspacebox
(set-box! rspacebox 0))
(when lspacebox
(set-box! lspacebox 0))))
(draw
(lambda (dc x y . other)
(draw-box dc x y w h)
(when (or with-border? hilited?)
(draw-box dc (add1 x) (add1 y) (- w 2) (- h 2)))
(when (and with-border? hilited?)
(draw-box dc (+ 2 x) (+ 2 y) (- w 4) (- h 4)))))
(copy
(lambda ()
(let ([o (make-object (hash-table-get interface->class-table
(object-interface this))
lm tm rm bm)])
(send o base-setup
name
x-stretch? y-stretch? w h
horizontal-child-alignment
vertical-child-alignment
with-border?
(or original-id id)
(or original-children-ids
(and (pair? children)
(map (lambda (child) (gb-id child)) children))))
o)))
(write
(lambda (stream)
(send stream put (string->bytes/utf-8 name))
(send stream put (if x-stretch? 1 0))
(send stream put (if y-stretch? 1 0))
(send stream put (floor (inexact->exact w)))
(send stream put (floor (inexact->exact h)))
(send stream put horizontal-child-alignment)
(send stream put vertical-child-alignment)
(send stream put (if with-border? 1 0))
(send stream put (string->bytes/utf-8 (if id id "BAD")))
(stream-write-list stream (map (lambda (c) (gb-id c)) children)))))
(public*
(read
(lambda (stream version)
(base-setup
;; name
(if (>= version 3)
((get-bytes->string version) (send stream get-bytes))
name)
(positive? (send stream get-exact))
(positive? (send stream get-exact))
(send stream get-exact) ; w
(send stream get-exact) ; h
(if (>= version 2) (send stream get-exact) horizontal-child-alignment) ; hca
(if (>= version 2) (send stream get-exact) vertical-child-alignment) ; vca
(if (>= version 2) (positive? (send stream get-exact)) #f) ; with-border?
((get-bytes->string version) (send stream get-bytes))
(let ([v (stream-read-list stream version)])
(if (null? v) #f v))))))
(override*
(resize
(lambda (w-in h-in)
(if (not parent)
(let-values ([(mw mh) (values prev-min-w prev-min-h)])
(if (or (and (> w-in mw) x-stretch?)
(and (> h-in mh) y-stretch?))
(begin
(when x-stretch? (set! w (max mw w-in)))
(when y-stretch? (set! h (max mh h-in)))
(gb-need-recalc-size)
#t)
#f))
#f))))
(super-new)
(set-snipclass (send (mred:get-the-snip-class-list) find (get-classname)))
(set-count 1)))
(define gb:atomic-snip%
(class gb:snip%
(override*
(init-x-stretch? (lambda () #f))
(init-y-stretch? (lambda () #f))
(container? (lambda () #f)))
(super-new)))
(define gb-y-stretch? (class-field-accessor gb:snip% y-stretch?))
(define gb-x-stretch? (class-field-accessor gb:snip% x-stretch?))
(define gb-id (class-field-accessor gb:snip% id))
(define gb-original-id (class-field-accessor gb:snip% original-id))
(define gb-parent (class-field-accessor gb:snip% parent))
(define gb-name (class-field-accessor gb:snip% name))
(define interface->class-table (make-hash-table))
(define register-class
(lambda (class% classname)
(hash-table-put!
interface->class-table
(class->interface class%)
class%)
(let ([snipclass
(make-object
(class mred:snip-class% ()
(inherit set-classname set-version reading-version)
(override*
[read
(lambda (stream)
(let ([o (make-object class%)])
(send o read stream (reading-version stream))
o))])
(super-new)
(set-classname classname)
(set-version GB:SNIP-VERSION)))])
(send (mred:get-the-snip-class-list) add snipclass))))
(register-class gb:snip% "gb:core")
(provide gb:snip%
gb:atomic-snip%
gb-y-stretch?
gb-x-stretch?
gb-id
gb-original-id
gb-parent
gb-name
(struct output-mode (as-class? no-free-vars?))
interface->class-table
register-class))

22
collects/guibuilder/button.xpm
View File

@ -1,22 +0,0 @@
/* XPM */
static char * button_xpm[] = {
"16 16 3 1",
" c #FFFFFFFFFFFF",
". c #000000000000",
"X c #A0A0A0A0A0A0",
" ",
" ",
" ",
" ",
" .......... ",
" . . ",
" . XX X X . ",
" . X X XX . ",
" . X X X X . ",
" . XX X X . ",
" . . ",
" .......... ",
" ",
" ",
" ",
" "};

154
collects/guibuilder/canvas.rkt
View File

@ -1,154 +0,0 @@
(module canvas mzscheme
(require (prefix mred: mred)
mzlib/class
mzlib/file
mzlib/pretty
mzlib/etc
mzlib/list
"utils.rkt"
"base.rkt"
"feature.rkt")
(define gb:make-canvas-hscroll-checkable-snip%
(lambda (cl)
(class (gb:make-boolean-configure-snip% cl 'hscroll "Horizontal Scroll" #t
void void)
(inherit get-tagged-value)
(public*
[get-hscroll
(lambda () (get-tagged-value 'hscroll))])
(super-new))))
(define gb:make-canvas-vscroll-checkable-snip%
(lambda (cl)
(class (gb:make-boolean-configure-snip% cl 'vscroll "Vertical Scroll" #t
void void)
(inherit get-tagged-value)
(public*
[get-vscroll
(lambda () (get-tagged-value 'vscroll))])
(super-new))))
(define gb:make-sb-box-snip%
(lambda (cl item-kind)
(class cl
(inherit-field w h)
(inherit get-hscroll get-vscroll)
(field
[sb-width 10]
[canvas-min-space 15])
(override*
[get-frame%
(lambda ()
(class (super get-frame%)
(override*
[get-kind (lambda () item-kind)])
(super-new)))]
[init-x-stretch? (lambda () #t)]
[init-y-stretch? (lambda () #t)]
[gb-get-min-size
(lambda (dc)
(values (+ sb-width canvas-min-space)
(+ sb-width canvas-min-space)))]
[draw
(lambda (dc x y . other)
(send dc draw-rectangle x y w h)
(when (get-vscroll)
(send dc draw-line
(+ x w (- sb-width)) y
(+ x w (- sb-width)) (+ y h -1)))
(when (get-hscroll)
(send dc draw-line
x (+ y h (- sb-width))
(+ x w -1) (+ y h (- sb-width)))))])
(super-new))))
(define gb:make-canvas-snip%
(lambda (cl cn)
(class cl
(inherit get-hscroll get-vscroll gb-get-instantiate-class-getter)
(override*
[gb-get-style
(lambda ()
(append
(super gb-get-style)
(cond
[(and (get-hscroll) (get-vscroll)) '(hscroll vscroll)]
[(get-hscroll) '(hscroll)]
[(get-vscroll) '(vscroll)]
[else null])))]
[get-classname (lambda () cn)]
[init-name (lambda () (new-name "canvas"))]
[gb-get-default-class (lambda () 'canvas%)])
(super-new))))
(define gb:canvas-snip% (gb:make-canvas-snip%
(gb:make-sb-box-snip%
(gb:make-canvas-vscroll-checkable-snip%
(gb:make-canvas-hscroll-checkable-snip%
gb:atomic-snip%))
"Canvas")
"gb:canvas"))
(register-class gb:canvas-snip% "gb:canvas")
(define gb:make-ecanvas-hscroll-select-snip%
(lambda (cl)
(class (gb:make-select-configure-snip% cl 'hscroll "Horizontal Scroll"
'("Show" "Hide" "No Scrolling"))
(inherit get-tagged-value)
(public*
[get-hscroll
(lambda () (zero? (get-hscroll-val)))]
[get-hscroll-val
(lambda () (get-tagged-value 'hscroll))])
(super-new))))
(define gb:make-ecanvas-vscroll-select-snip%
(lambda (cl)
(class (gb:make-select-configure-snip% cl 'vscroll "Vertical Scroll"
'("Show" "Hide" "No Scrolling"))
(inherit get-tagged-value)
(public*
[get-vscroll
(lambda () (zero? (get-vscroll-val)))]
[get-vscroll-val
(lambda () (get-tagged-value 'vscroll))])
(super-new))))
(define gb:make-editor-canvas-snip%
(lambda (cl cn)
(class cl
(inherit get-hscroll-val get-vscroll-val)
(override*
[get-classname (lambda () cn)]
[init-name (lambda () (new-name "ecanvas"))]
[gb-get-default-class (lambda () 'editor-canvas%)]
[gb-get-style
(lambda ()
(append
(super gb-get-style)
(case (get-hscroll-val)
[(0) null]
[(1) '(hide-hscroll)]
[(2) '(no-hscroll)])
(case (get-vscroll-val)
[(0) ()]
[(1) '(hide-vscroll)]
[(2) '(no-vscroll)])))])
(super-new))))
(define gb:editor-canvas-snip% (gb:make-editor-canvas-snip%
(gb:make-sb-box-snip%
(gb:make-ecanvas-vscroll-select-snip%
(gb:make-ecanvas-hscroll-select-snip%
gb:atomic-snip%))
"Editor Canvas")
"gb:editor-canvas"))
(register-class gb:editor-canvas-snip% "gb:editor-canvas")
(provide gb:canvas-snip%
gb:editor-canvas-snip%))

22
collects/guibuilder/canvas.xpm
View File

@ -1,22 +0,0 @@
/* XPM */
static char * canvas_xpm[] = {
"16 16 3 1",
" c #FFFFFFFFFFFF",
". c #A0A0A0A0A0A0",
"X c #000000000000",
" ",
" .............. ",
" . XXX . . ",
" .X X . . ",
" .X XXXXX . . ",
" .X X X X . . ",
" . XXX X . . ",
" . XXXXX . . ",
" . X . . ",
" . XX . . ",
" . XXX. . ",
" . XXXX . ",
" ........XXX... ",
" . XX . ",
" ...........X.. ",
" "};

22
collects/guibuilder/checkbox.xpm
View File

@ -1,22 +0,0 @@
/* XPM */
static char * checkbox_xpm[] = {
"16 16 3 1",
" c #FFFFFFFFFFFF",
". c #000000000000",
"X c #A0A0A0A0A0A0",
" ",
" ",
" ",
" ",
" ",
" ",
" .... ",
" . . XXXXXXXXX ",
" . . XXXXXXXXX ",
" .... ",
" ",
" ",
" ",
" ",
" ",
" "};

25
collects/guibuilder/choice.xpm
View File

@ -1,25 +0,0 @@
/* XPM */
static char *choice[] = {
/* width height num_colors chars_per_pixel */
" 16 16 2 1",
/* colors */
". c #000000",
"# c #fefefe",
/* pixels */
"################",
"################",
"################",
"################",
"#.............##",
"#.###########..#",
"#.#.....#####..#",
"#.##...######..#",
"#.###.#######..#",
"#.###########..#",
"#..............#",
"##.............#",
"################",
"################",
"################",
"################"
};

12
collects/guibuilder/doc.txt
View File

@ -1,12 +0,0 @@
_GUI builder_
To run the GUI builder, use DrRacket and select "Insert GUI"
from the "Special" menu.
Though less recommended, you can also run
(require guibuilder/guibuilder)
to get a stand-alone builder. Save your files with the extension
".gui" to ensure that they can be re-loaded later.

352
collects/guibuilder/feature.rkt
View File

@ -1,352 +0,0 @@
(module feature mzscheme
(require (prefix mred: mred)
mzlib/class
mzlib/file
mzlib/pretty
mzlib/etc
mzlib/list
"base.rkt"
"utils.rkt")
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Mixins for GUI features
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define gb:make-text-label-snip%
(lambda (cl deflabel)
(class cl
(inherit get-style gb-need-recalc-size)
(override*
[get-frame%
(lambda ()
(class (super get-frame%)
(inherit-field controls)
(override*
[get-kind (lambda () deflabel)])
(super-new)
(private-field
[label-buffer (make-one-line/callback-edit controls "Label:"
(lambda (txt)
(set! label txt)
(gb-need-recalc-size))
label)])))]
[gb-instantiate-arguments
(lambda ()
`(,@(super gb-instantiate-arguments)
[label ,(get-label)]))])
(field
[label deflabel])
(public*
[get-label
(lambda ()
label)]
[get-label-size
(lambda (dc)
(let-values ([(w h d a) (send dc get-text-extent label
(send (get-style) get-font))])
(values w h)))]
[draw-label
(lambda (dc x y)
(send dc draw-text label x y))]
[label-install
(lambda (n)
(set! label n))])
(override*
[copy
(lambda ()
(let ([o (super copy)])
(send o label-install label)
o))]
[write
(lambda (stream)
(super write stream)
(send stream put (string->bytes/utf-8 label)))]
[read
(lambda (stream version)
(super read stream version)
(label-install ((get-bytes->string version) (send stream get-bytes))))])
(super-new))))
(define gb:make-callback-snip%
(lambda (cl)
(class cl
(inherit-field name)
(public*
[get-callback-kinds (lambda () (list "-callback"))]
[get-callback-code (lambda ()
(map (lambda (x) '(lambda (w e) (void))) (get-callback-kinds)))]
[get-callback-names
(lambda ()
(map
(lambda (ct)
(string->symbol (string-append name ct)))
(get-callback-kinds)))]
[gb-get-unified-callback
(lambda ()
`(lambda (b e) (,(car (get-callback-names)) b e)))])
(override*
[gb-instantiate-arguments
(lambda ()
`(,@(super gb-instantiate-arguments)
[callback ,(gb-get-unified-callback)]))]
[gb-aux-instantiate
(lambda (mode)
(append
(if (or (output-mode-as-class? mode)
(output-mode-no-free-vars? mode))
(map (lambda (n c)
(if (output-mode-as-class? mode)
`(public* [,n ,c])
`(define ,n ,c)))
(get-callback-names) (get-callback-code))
null)
(super gb-aux-instantiate mode)))])
(super-new))))
(define gb:make-text-labelled-snip%
(lambda (cl deflabel)
(class (gb:make-text-label-snip% cl deflabel)
(inherit-field w h)
(inherit get-label-size draw-label gb-need-recalc-size)
(private-field
[hmargin 2]
[vertical-label? (init-vertical-label?)])
(public*
[get-label-top-margin (lambda () 0)]
[init-vertical-label? (lambda () #f)]
[get-min-body-size
(lambda (dc)
(values 0 0))]
[draw-body
(lambda (dc x y w h)
(void))]
[labelpos-install
(lambda (vert?)
(set! vertical-label? vert?))])
(override*
[get-frame%
(lambda ()
(class (super get-frame%)
(inherit-field controls)
(super-new)
(private-field
[direction-radio
(make-object mred:radio-box% "Label Position:" '("Top" "Left")
controls
(lambda (r e)
(set! vertical-label? (zero? (send direction-radio get-selection)))
(gb-need-recalc-size))
'(horizontal))])
(send direction-radio set-selection (if vertical-label? 0 1))))]
[gb-get-min-size
(lambda (dc)
(let-values ([(x y) (get-label-size dc)]
[(x2 y2) (get-min-body-size dc)]
[(+x +y) (if vertical-label?
(values max +)
(values (lambda (a b) (+ a b hmargin)) max))])
(values (+x x x2) (+y (+ y (get-label-top-margin)) y2))))]
[draw
(lambda (dc x y . other)
(draw-label dc x (+ y (get-label-top-margin)))
(let*-values ([(lw lh) (get-label-size dc)]
[(dx dy) (if vertical-label?
(values 0 lh)
(values (+ lw hmargin) 0))])
(with-clipping-region dc (+ x dx) (+ y dy) (- w dx) (- h dy)
(lambda ()
(draw-body dc (+ x dx) (+ y dy) (- w dx) (- h dy))))))]
[gb-get-style
(lambda ()
(cons (if vertical-label?
'vertical-label
'horizontal-label)
(super gb-get-style)))]
[copy
(lambda ()
(let ([o (super copy)])
(send o labelpos-install vertical-label?)
o))]
[write
(lambda (stream)
(super write stream)
(send stream put (if vertical-label? 1 0)))]
[read
(lambda (stream version)
(super read stream version)
(labelpos-install (positive? (send stream get-exact))))])
(super-new))))
(define gb:make-layout-snip%
(lambda (cl)
(class cl
(inherit gb-need-recalc-size)
(override*
[get-frame%
(lambda ()
(class (super get-frame%)
(inherit-field controls)
(super-new)
(private-field
[layout-direction-radio
(make-object mred:radio-box%
"Layout:"
'("Vertical" "Horizontal")
controls
(lambda (r e)
(set! vertical-layout?
(zero? (send layout-direction-radio get-selection)))
(gb-need-recalc-size))
'(horizontal))])
(send layout-direction-radio set-selection (if vertical-layout? 0 1))))])
(field
[vertical-layout? (init-vertical-layout?)])
(public*
[init-vertical-layout? (lambda () #t)]
[layout-install
(lambda (vert?)
(set! vertical-layout? vert?))])
(override*
[gb-get-style
(lambda ()
(cons (if vertical-layout?
'vertical
'horizontal)
(super gb-get-style)))]
[copy
(lambda ()
(let ([o (super copy)])
(send o layout-install vertical-layout?)
o))]
[write
(lambda (stream)
(super write stream)
(send stream put (if vertical-layout? 1 0)))]
[read
(lambda (stream version)
(super read stream version)
(layout-install (positive? (send stream get-exact))))])
(super-new))))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Mixins for configuration options
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define gb:make-configure-snip%
(lambda (cl tag init)
(class cl
(private-field
[v init])
(override*
[get-tagged-value
(lambda (t)
(if (eq? t tag)
v
(super get-tagged-value t)))]
[set-tagged-value
(lambda (t v-in)
(if (eq? t tag)
(set! v v-in)
(super set-tagged-value t v-in)))]
[copy
(lambda ()
(let ([o (super copy)])
(send o set-tagged-value tag v)
o))])
(super-new))))
(define gb:make-boolean-configure-snip%
(lambda (cl tag label init change-cb init-cb)
(class (gb:make-configure-snip% cl tag init)
(inherit gb-need-recalc-size get-tagged-value set-tagged-value)
(override*
[get-frame%
(lambda ()
(define this-snip this)
(class (super get-frame%)
(inherit-field controls)
(override*
[find-control
(lambda (t)
(if (eq? t tag)
c
(super find-control t)))])
(super-new)
(private-field
[c (make-object mred:check-box%
label controls
(lambda (c e)
(set-tagged-value tag (send c get-value))
(change-cb this this-snip)
(gb-need-recalc-size)))])
(send c set-value (get-tagged-value tag))
(init-cb this this-snip)))]
[write
(lambda (stream)
(super write stream)
(send stream put (if (get-tagged-value tag) 1 0)))]
[read
(lambda (stream version)
(super read stream version)
(set-tagged-value tag (positive? (send stream get-exact))))])
(super-new))))
(define gb:make-multi-checkable-snip%
(lambda (cl)
(class (gb:make-boolean-configure-snip% cl 'multi "Multiple Lines" #f
(lambda (f snip)
(send snip multi-changed f))
void)
(inherit get-tagged-value)
(public*
[get-multi
(lambda () (get-tagged-value 'multi))]
[multi-changed
(lambda (f)
(send (send f find-control 'hscroll) enable (get-multi)))])
(super-new))))
(define gb:make-select-configure-snip%
(lambda (cl tag label choices)
(class (gb:make-configure-snip% cl tag 0)
(inherit gb-need-recalc-size get-tagged-value set-tagged-value)
(override*
[get-frame%
(lambda ()
(class (super get-frame%)
(inherit-field controls)
(super-new)
(private-field
[c (make-object mred:choice%
label choices controls
(lambda (c e)
(set-tagged-value tag (send c get-selection))
(gb-need-recalc-size)))])
(send c set-selection (get-tagged-value tag))))]
[write
(lambda (stream)
(super write stream)
(send stream put (get-tagged-value tag)))]
[read
(lambda (stream version)
(super read stream version)
(set-tagged-value tag (send stream get-exact)))])
(super-new))))
(provide gb:make-text-label-snip%
gb:make-callback-snip%
gb:make-text-labelled-snip%
gb:make-layout-snip%
gb:make-configure-snip%
gb:make-boolean-configure-snip%
gb:make-multi-checkable-snip%
gb:make-select-configure-snip%))

26
collects/guibuilder/gauge.xpm
View File

@ -1,26 +0,0 @@
/* XPM */
static char *gauge[] = {
/* width height num_colors chars_per_pixel */
" 16 16 3 1",
/* colors */
". c #000000",
"# c #a0a0a0",
"a c #ffffff",
/* pixels */
"aaaaaaaaaaaaaaaa",
"aaaaaaaaaaaaaaaa",
"aaaaaaaaaaaaaaaa",
"aaaaaaaaaaaaaaaa",
"aaaaaaaaaaaaaaaa",
"a..............a",
"a.######aaaaaa.a",
"a.######aaaaaa.a",
"a.######aaaaaa.a",
"a.######aaaaaa.a",
"a..............a",
"aaaaaaaaaaaaaaaa",
"aaaaaaaaaaaaaaaa",
"aaaaaaaaaaaaaaaa",
"aaaaaaaaaaaaaaaa",
"aaaaaaaaaaaaaaaa"
};

100
collects/guibuilder/guibuilder.rkt
View File

@ -1,100 +0,0 @@
(module guibuilder mzscheme
(require (prefix mred: mred)
mzlib/class
mzlib/file
mzlib/pretty
mzlib/etc
mzlib/list
(prefix framework: framework)
"utils.rkt"
"top-level.rkt"
"toolbar.rkt")
;; These modules implement snips for the various
;; kinds of windows and controls.
(require "base.rkt"
"panel.rkt"
"simple-control.rkt"
"text-field.rkt"
"multiple-choice.rkt"
"slider-guage.rkt"
"canvas.rkt")
(define my-base-frame% framework:frame:editor%)
(define gb:frame%
(class my-base-frame%
(init [file #f])
(inherit get-editor show get-area-container get-menu-bar)
(define gb-editor #f)
(define (get-gb-editor)
gb-editor)
(override*
[get-editor% (lambda ()
(class framework:text:info%
(inherit insert)
(super-new)
(set! gb-editor (new gb:edit%))
(insert (make-object mred:editor-snip% gb-editor))))])
(define toolbar #f)
(public*
[init-tools
(lambda (mb)
(set! toolbar (make-object toolbar% (get-area-container)))
(send (get-area-container) change-children
(lambda (l)
(cons toolbar (remove toolbar l))))
(let* ([emenu (make-object mred:menu% "Element" mb)]
[vmenu (make-object mred:menu% "Output" mb)])
(make-object mred:menu-item% "Configure Selected" emenu
(lambda (i e)
(send (get-gb-editor)
for-each-selected-snip
(lambda (s)
(send s gb-open-dialog)))))
(make-object mred:separator-menu-item% emenu)
(add-tools toolbar emenu (lambda (c%) (insert-element c%)))
(make-object mred:menu-item% "Configure Output" vmenu
(lambda (i e) (send (get-gb-editor) open-dialog)))
(make-object mred:separator-menu-item% vmenu)
(make-object mred:menu-item% "Make Sample Window" vmenu
(lambda (i e) (send (get-gb-editor) instantiate)))
(make-object mred:menu-item% "Make Source Code" vmenu
(lambda (i e) (send (get-gb-editor) view-source)))))]
[insert-element
(lambda (c%)
(let ([e (get-gb-editor)])
(send e insert-element c%)))])
(super-make-object (or file "GUI Builder"))
(init-tools (get-menu-bar))
(let ([file (and file (normalize-path file))])
(if (and file (file-exists? file) (send (get-gb-editor) load-file file))
;; Force title size calc:
(let ([e (get-gb-editor)])
(send e get-main-location
(send e get-main-panel)
(send (send e get-canvas) get-dc)
(box 0) (box 0)))
(begin
(send (get-gb-editor) create-main-panel)
(when file
(send (get-gb-editor) set-filename file)))))
(show #t)))
(framework:handler:insert-format-handler "GUI Builder" "gui"
(lambda (file)
(make-object gb:frame% file)))
(define (new-gui-builder-frame) (new gb:frame% [height 400]))
(new-gui-builder-frame))

1
collects/guibuilder/help.mre
View File

@ -1 +0,0 @@
(The help document has not been written.)

22
collects/guibuilder/hpanel.xpm
View File

@ -1,22 +0,0 @@
/* XPM */
static char * hpanel_xpm[] = {
"16 16 3 1",
" c #FFFFFFFFFFFF",
". c #000000000000",
"X c #A0A0A0A0A0A0",
" ",
" ",
" ",
" .............. ",
" . . ",
" . . ",
" . X XX X . ",
" . X XX X . ",
" . X XX X . ",
" . X XX X . ",
" . . ",
" . . ",
" .............. ",
" ",
" ",
" "};

4
collects/guibuilder/info.rkt
View File

@ -1,4 +0,0 @@
#lang setup/infotab
(define tools '(("tool.rkt")))
(define tool-names '("GUI Builder"))

22
collects/guibuilder/list.xpm
View File

@ -1,22 +0,0 @@
/* XPM */
static char * list_xpm[] = {
"16 16 3 1",
" c #FFFFFFFFFFFF",
". c #000000000000",
"X c #A0A0A0A0A0A0",
" ",
" ",
" ............ ",
" . . . ",
" . XXXX . . ",
" . . . ",
" . XXXX . . ",
" . . . ",
" . XXXX . . ",
" . . . ",
" . XXXX . . ",
" . . . ",
" . . . ",
" ............ ",
" ",
" "};

22
collects/guibuilder/mcanvas.xpm
View File

@ -1,22 +0,0 @@
/* XPM */
static char * mcanvas_xpm[] = {
"16 16 3 1",
" c #FFFFFFFFFFFF",
". c #A0A0A0A0A0A0",
"X c #000000000000",
" ",
" .............. ",
" . . . ",
" . XXXXX X X. . ",
" . X X X X . . ",
" . X X . . ",
" . X X . . ",
" . XXX X . . ",
" . X . . ",
" . X . . ",
" . X X. . ",
" . . . ",
" .............. ",
" . . . ",
" .............. ",
" "};

21
collects/guibuilder/message.xpm
View File

@ -1,21 +0,0 @@
/* XPM */
static char * message_xpm[] = {
"16 16 2 1",
" c #FFFFFFFFFFFF",
". c #000000000000",
" ",
" ",
" ",
" ",
" ",
" ...... ",
" . .. . ",
" .. ",
" .. ",
" .. ",
" .... ",
" ",
" ",
" ",
" ",
" "};

269
collects/guibuilder/multiple-choice.rkt
View File

@ -1,269 +0,0 @@
(module multiple-choice mzscheme
(require (prefix mred: mred)
mzlib/class
mzlib/file
mzlib/pretty
mzlib/etc
mzlib/list
"utils.rkt"
"base.rkt"
"feature.rkt")
(define gb:make-item-list-snip%
(lambda (cl)
(class cl
(inherit gb-need-recalc-size)
(private*
[delete
(lambda (l p)
(let loop ([l l][p p])
(cond
[(null? l) l]
[(zero? p) (cdr l)]
[else (cons (car l) (loop (cdr l) (sub1 p)))])))])
(public*
[get-items
(lambda ()
items)]
[init-items (lambda () null)]
[get-item-height
(lambda (dc)
(let-values ([(w h d a) (send dc get-text-extent "Xj")])
h))]
[get-max-item-width
(lambda (dc)
(let loop ([l items][mw 0])
(if (null? l)
mw
(let-values ([(w h d a) (send dc get-text-extent (car l))])
(loop (cdr l) (max mw w))))))]
[items-install
(lambda (l)
(set! items l))])
(override*
[get-frame%
(lambda ()
(class (super get-frame%)
(inherit-field controls)
(super-new)
(public*
[user-item (lambda (v)
(mred:get-text-from-user "Item name:" "List Item Name" #f v))])
(private-field
[items-panel (make-object mred:vertical-panel% controls)]
[items-list (make-object mred:list-box%
"Items:"
items
items-panel
(lambda (l e)
(when (eq? 'list-box-dclick (send e get-event-type))
(let ([pos (send items-list get-selection)])
(unless (negative? pos)
(let ([v (user-item (list-ref items pos))])
(when v
(send items-list set-string pos v)
(set! items (let loop ([items items][pos pos])
(if (zero? pos)
(cons v (cdr items))
(cons (car items)
(loop (cdr items) (sub1 pos))))))
(gb-need-recalc-size))))))))]
[item-buttons-panel (let ([v (make-object mred:horizontal-panel% items-panel)])
(send v stretchable-width #f)
v)]
[add-item (make-object mred:button% "Add Item" item-buttons-panel
(lambda (b e)
(let ([v (user-item (format
"Item~a"
(send items-list get-number)))])
(when v
(send items-list append v)
(set! items (append items (list v)))
(gb-need-recalc-size)))))]
[delete-item (make-object mred:button% "Delete Item" item-buttons-panel
(lambda (b e)
(let loop ([ls (reverse (send items-list get-selections))])
(unless (null? ls)
(send items-list delete (car ls))
(set! items (delete items (car ls)))
(loop (cdr ls))))
(gb-need-recalc-size)))])))]
[gb-instantiate-arguments
(lambda ()
(cons
`[choices ',(get-items)]
(super gb-instantiate-arguments)))]
[copy
(lambda ()
(let ([o (super copy)])
(send o items-install items)
o))]
[write
(lambda (stream)
(super write stream)
(stream-write-list stream items))]
[read
(lambda (stream version)
(super read stream version)
(items-install (stream-read-list stream version)))])
(private-field
[items (init-items)])
(super-new))))
(define gb:make-list-box-snip%
(lambda (cl cn)
(class cl
(inherit-field w h)
(inherit get-callback-names get-items get-item-height)
(field
[min-body-width 50]
[sb-width 10]
[min-item-count 3])
(override*
[get-classname (lambda () cn)]
[init-name (lambda () (new-name "listbox"))]
[init-y-stretch? (lambda () #t)]
[init-x-stretch? (lambda () #t)]
[get-min-body-size
(lambda (dc)
(let ([y (get-item-height dc)])
(values min-body-width (* min-item-count y))))]
[draw-body
(lambda (dc x y w h)
(send dc draw-rectangle x y w h)
(send dc draw-line
(+ w x (- sb-width)) y
(+ w x (- sb-width)) (+ y h))
(with-clipping-region
dc x y (- w sb-width) h
(lambda ()
(let ([ih (get-item-height dc)])
(let loop ([l (get-items)][iy (add1 y)])
(unless (or (>= iy (+ y h)) (null? l))
(send dc draw-text (car l) (+ 2 x) iy)
(loop (cdr l) (+ iy ih))))))))]
[get-callback-kinds (lambda ()
(list "-select-callback" "-double-select-callback"))]
[gb-get-default-class (lambda () 'list-box%)]
[gb-get-style
(lambda ()
(cons 'single
(super gb-get-style)))]
[gb-get-unified-callback
(lambda ()
(let-values ([(sel dbl) (apply values (get-callback-names))])
`(lambda (b e)
(case (send e get-event-type)
[(list-box) (,sel b e)]
[(list-box-dclick) (,dbl b e)]))))])
(super-new))))
(define gb:list-box-snip% (gb:make-list-box-snip%
(gb:make-item-list-snip%
(gb:make-callback-snip%
(gb:make-text-labelled-snip% gb:atomic-snip%
"List")))
"gb:listbox"))
(register-class gb:list-box-snip% "gb:listbox")
(define gb:make-radio-box-snip%
(lambda (cl cn)
(class cl
(inherit-field w h vertical-layout?)
(inherit get-item-height get-max-item-width get-items
gb-need-recalc-size)
(private-field
[circle-size 10]
[margin 2])
(override*
[get-classname (lambda () cn)]
[init-name (lambda () (new-name "radiobox"))]
[init-items (lambda () (list "First" "Second"))]
[get-min-body-size
(lambda (dc)
(let ([h (max (get-item-height dc) circle-size)]
[w (get-max-item-width dc)]
[l (length (get-items))])
(let-values ([(x-l y-l) (if vertical-layout?
(values 1 l)
(values l 1))])
(values (* (+ circle-size margin w) x-l)
(* h y-l)))))]
[draw-body
(lambda (dc x y w h)
(let ([ih (max (get-item-height dc) circle-size)]
[iw (+ (get-max-item-width dc) circle-size margin)])
(let loop ([l (get-items)][iy y][ix x])
(unless (null? l)
(send dc draw-ellipse ix (+ iy (/ (- ih circle-size) 2)) circle-size circle-size)
(send dc draw-text (car l) (+ circle-size margin ix) iy)
(if vertical-layout?
(loop (cdr l) (+ iy ih) ix)
(loop (cdr l) iy (+ ix iw)))))))]
[gb-get-default-class (lambda () 'radio-box%)])
(super-new))))
(define gb:radio-box-snip% (gb:make-radio-box-snip%
(gb:make-item-list-snip%
(gb:make-layout-snip%
(gb:make-callback-snip%
(gb:make-text-labelled-snip% gb:atomic-snip%
"Radiobox"))))
"gb:radiobox"))
(register-class gb:radio-box-snip% "gb:radiobox")
(define gb:make-choice-snip%
(lambda (cl cn)
(class cl
(inherit-field w h)
(inherit get-item-height get-max-item-width get-items
gb-need-recalc-size)
(field
[arrow-size 10]
[lmargin 2]
[amargin 2]
[rmargin 2]
[arrow (list (make-object mred:point% 0 0)
(make-object mred:point% arrow-size 0)
(make-object mred:point% (quotient arrow-size 2) (quotient arrow-size 2)))])
(override*
[get-classname (lambda () cn)]
[init-name (lambda () (new-name "choice"))]
[init-items (lambda () (list "First"))]
[get-min-body-size
(lambda (dc)
(let ([h (get-item-height dc)]
[w (get-max-item-width dc)])
(values (+ lmargin arrow-size amargin w rmargin 3) (+ 3 h))))]
[draw-body
(lambda (dc x y w h)
(send dc draw-rectangle x y (sub1 w) (sub1 h))
(send dc draw-line (sub1 (+ x w)) (add1 y) (sub1 (+ x w)) (+ y h))
(send dc draw-line (add1 x) (sub1 (+ y h)) (+ x w) (sub1 (+ y h)))
(send dc draw-polygon arrow (+ 1 lmargin x) (+ y (/ (- h (/ arrow-size 2)) 2)))
(let ([l (get-items)])
(unless (null? l)
(send dc draw-text (car l) (+ 1 lmargin arrow-size amargin x) (add1 y)))))]
[gb-get-default-class (lambda () 'choice%)])
(super-new))))
(define gb:choice-snip% (gb:make-choice-snip%
(gb:make-item-list-snip%
(gb:make-callback-snip%
(gb:make-text-labelled-snip% gb:atomic-snip%
"Choice")))
"gb:choice"))
(register-class gb:choice-snip% "gb:choice")
(provide gb:list-box-snip%
gb:radio-box-snip%
gb:choice-snip%))

157
collects/guibuilder/panel.rkt
View File

@ -1,157 +0,0 @@
(module panel mzscheme
(require (prefix mred: mred)
mzlib/class
mzlib/file
mzlib/pretty
mzlib/etc
mzlib/list
"utils.rkt"
"base.rkt")
(define gb:make-panel-params-snip%
(lambda (cl)
(class cl
(inherit-field horizontal-child-alignment
vertical-child-alignment
with-border?)
(inherit set-horizontal-child-alignment
set-vertical-child-alignment
set-with-border
gb-need-recalc-size)
(override*
[get-frame%
(lambda ()
(class (super get-frame%)
(inherit-field controls)
(super-new)
(field
[hca-choice
(make-object mred:choice%
"Horizontal Align Children:"
'("Left" "Center" "Right")
controls
(lambda (r e)
(set-horizontal-child-alignment
(add1 (send r get-selection)))
(gb-need-recalc-size)))]
[vca-choice
(make-object mred:choice%
"Vertical Align Children:"
'("Top" "Center" "Bottom")
controls
(lambda (r e)
(set-vertical-child-alignment
(add1 (send r get-selection)))
(gb-need-recalc-size)))]
[border-check
(make-object mred:check-box%
"Show Border" controls
(lambda (c e)
(set-with-border (send c get-value))
(gb-need-recalc-size)))])
(send hca-choice stretchable-width #f)
(send hca-choice set-selection (sub1 horizontal-child-alignment))
(send vca-choice stretchable-width #f)
(send vca-choice set-selection (sub1 vertical-child-alignment))
(send border-check set-value with-border?)))])
(private*
[symbol-append
(lambda (a b) (string->symbol (string-append (symbol->string a) (symbol->string b))))])
(override*
[gb-instantiate-arguments
(lambda ()
`(,@(super gb-instantiate-arguments)
[alignment '(,(case horizontal-child-alignment
[(1) 'left]
[(2) 'center]
[(3) 'right])
,(case horizontal-child-alignment
[(1) 'top]
[(2) 'center]
[(3) 'bottom]))]))])
(super-new))))
(define gb:vertical-panel-snip%
(class (gb:make-panel-params-snip% gb:snip%)
(override*
[get-classname (lambda () "gb:vertical-panel")]
[init-name (lambda () (new-name "vpanel"))])
(super-new)))
(register-class gb:vertical-panel-snip% "gb:vertical-panel")
; Used by top-level panel:
(define gb:panel-snip%
(class gb:vertical-panel-snip%
(override*
[get-classname (lambda () "gb:panel")])
(super-new)))
(register-class gb:panel-snip% "gb:panel")
(define gb:horizontal-panel-snip%
(class (gb:make-panel-params-snip% gb:snip%)
(inherit-field horizontal-child-alignment vertical-child-alignment
children)
(inherit spacing-+)
(override*
[get-classname (lambda () "gb:horizontal-panel")]
[init-name (lambda () (new-name "hpanel"))]
(gb-get-child-x-start
(lambda (mw mh w h)
(if (or (= horizontal-child-alignment 1)
(ormap (lambda (c) (gb-x-stretch? c)) children))
0
(case horizontal-child-alignment
[(2) (/ (- w mw) 2)]
[(3) (- w mw)]))))
(gb-get-child-y-start
(lambda (mw mh w h)
0))
(gb-combine-child-width (lambda (a b) (spacing-+ a b)))
(gb-combine-child-height (lambda (a b) (max a b)))
(gb-compute-child-x-pos
(lambda (dc c w)
0))
(gb-compute-child-y-pos
(lambda (dc c h)
(if (gb-y-stretch? c)
0
(case vertical-child-alignment
[(2) (let-values ([(cw ch) (send c gb-get-min-size dc)])
(/ (- h ch) 2))]
[(1) 0]
[(3) (let-values ([(cw ch) (send c gb-get-min-size dc)])
(- h ch))]))))
(gb-compute-child-width
(lambda (dc c w xsc dw)
(let-values ([(cw ch) (send c gb-get-min-size dc)])
(if (gb-x-stretch? c)
(+ cw (/ dw xsc))
cw))))
(gb-compute-child-height
(lambda (dc c h ysc dh)
(if (gb-y-stretch? c)
h
(let-values ([(cw ch) (send c gb-get-min-size dc)])
ch))))
(gb-combine-child-x-offset (lambda (a b) (spacing-+ a b)))
(gb-combine-child-y-offset (lambda (a b) a))
(find-position-<
(lambda (fx fy cx cy)
(< fx cx)))
[gb-get-default-class (lambda () 'horizontal-panel%)])
(super-new)))
(register-class gb:horizontal-panel-snip% "gb:horizontal-panel")
(provide gb:make-panel-params-snip%
gb:vertical-panel-snip%
gb:panel-snip%
gb:horizontal-panel-snip%))

23
collects/guibuilder/radiobox.xpm
View File

@ -1,23 +0,0 @@
/* XPM */
static char * radiobox_xpm[] = {
"16 16 4 1",
" c #FFFFFFFFFFFF",
". c #000000000000",
"X c #A0A0A0A0A0A0",
"o c #A0A0A0A0A0A0",
" ",
" ",
" ",
" .. ",
" .XX. ooooooooo ",
" .XX. ooooooooo ",
" .. ",
" ",
" ",
" .. ",
" . . ooooooooo ",
" . . ooooooooo ",
" .. ",
" ",
" ",
" "};

54
collects/guibuilder/readable.rkt
View File

@ -1,54 +0,0 @@
(module readable mzscheme
(require mred
mzlib/class
"top-level.rkt"
"toolbar.rkt")
(define gui-snip-class%
(class snip-class%
(inherit set-classname set-version)
(define/override (read f)
(let ([e (make-object gb:edit%)])
(send e prepare-to-load)
(send e read-from-file f)
(send e done-loading #t)
(make-object gui-code-snip% e)))
(super-new)
(set-classname "(lib \"readable.ss\" \"guibuilder\")")
(set-version 1)))
(define gui-snip-class (new gui-snip-class%))
(send (get-the-snip-class-list) add gui-snip-class)
(define gui-code-snip%
(class* editor-snip% (readable-snip<%>)
(inherit get-editor set-min-width set-min-height set-snipclass get-admin)
(define/public (read-special source line column position)
(send (get-editor) build-code #f #f))
(define/override (write f)
(send (get-editor) write-to-file f))
(define/override (copy)
(make-object gui-code-snip% (send (get-editor) copy-self)))
(define/override (on-event dc x y editorx editory e)
(if (send e button-down? 'right)
(let ([tool-menu (make-object popup-menu%)])
(add-tools #f tool-menu (lambda (c%)
(send (get-editor) insert-element c%)))
(send (get-admin) popup-menu
tool-menu this
(- (send e get-x) x)
(- (send e get-y) y)))
(super on-event dc x y editorx editory e)))
(super-new)
(set-snipclass gui-snip-class)))
(provide gui-code-snip%
(rename gui-snip-class snip-class)))

101
collects/guibuilder/simple-control.rkt
View File

@ -1,101 +0,0 @@
(module simple-control mzscheme
(require (prefix mred: mred)
mzlib/class
mzlib/file
mzlib/pretty
mzlib/etc
mzlib/list
"utils.rkt"
"base.rkt"
"feature.rkt")
(define gb:make-message-snip%
(lambda (cl cn)
(class cl
(inherit-field w h)
(inherit get-label get-label-size draw-label)
(override*
[get-classname (lambda () cn)]
[init-name (lambda () (new-name "message"))]
[gb-get-min-size
(lambda (dc)
(get-label-size dc))]
[draw
(lambda (dc x y . other)
(draw-label dc x y))]
[gb-get-default-class (lambda () 'message%)])
(super-new))))
(define gb:message-snip% (gb:make-message-snip%
(gb:make-text-label-snip% gb:atomic-snip%
"Message")
"gb:message"))
(register-class gb:message-snip% "gb:message")
(define gb:make-button-snip%
(lambda (cl cn)
(class cl
(inherit-field w h)
(inherit get-label get-label-size get-callback-names draw-label)
(private-field
[m 5])
(override*
[get-classname (lambda () cn)]
[init-name (lambda () (new-name "button"))]
[gb-get-min-size
(lambda (dc)
(let-values ([(x y) (get-label-size dc)])
(values (+ (* 2 m) x) (+ (* 2 m) y))))]
[draw
(lambda (dc x y . other)
(send dc draw-rounded-rectangle x y w h 3)
(let-values ([(lw lh) (get-label-size dc)])
(draw-label dc
(+ (+ x m) (/ (- w lw (* 2 m)) 2))
(+ (+ y m) (/ (- h lh (* 2 m)) 2)))))]
[gb-get-default-class (lambda () 'button%)])
(super-new))))
(define gb:make-check-box-snip%
(lambda (cl cn)
(class cl
(inherit-field w h)
(inherit get-style get-label get-callback-names get-label-size draw-label)
(private-field
[hspace 2]
[boxsize 12])
(override*
[get-classname (lambda () cn)]
[init-name (lambda () (new-name "checkbox"))]
[gb-get-min-size
(lambda (dc)
(let-values ([(x y) (get-label-size dc)])
(values (+ boxsize hspace x) (max boxsize y))))]
[draw
(lambda (dc x y . other)
(let-values ([(lx ly) (get-label-size dc)])
(send dc draw-rectangle x (+ y (/ (- h boxsize) 2)) boxsize boxsize)
(draw-label dc (+ x boxsize hspace) (+ y (/ (- h ly) 2)))))]
[gb-get-default-class (lambda () 'check-box%)])
(super-new))))
(define gb:button-snip% (gb:make-button-snip%
(gb:make-callback-snip%
(gb:make-text-label-snip% gb:atomic-snip%
"Button"))
"gb:button"))
(define gb:check-box-snip% (gb:make-check-box-snip%
(gb:make-callback-snip%
(gb:make-text-label-snip% gb:atomic-snip%
"Checkbox"))
"gb:checkbox"))
(register-class gb:button-snip% "gb:button")
(register-class gb:check-box-snip% "gb:checkbox")
(provide gb:message-snip%
gb:button-snip%
gb:check-box-snip%))

192
collects/guibuilder/slider-guage.rkt
View File

@ -1,192 +0,0 @@
(module slider-guage mzscheme
(require (prefix mred: mred)
mzlib/class
mzlib/file
mzlib/pretty
mzlib/etc
mzlib/list
"utils.rkt"
"base.rkt"
"feature.rkt")
(define gb:make-slider-snip%
(lambda (cl cn)
(class cl
(inherit-field vertical-layout?)
(inherit get-label get-callback-names gb-need-recalc-size)
(field
[init-value 0]
[min-value 0]
[max-value 10]
[arrow-size 10]
[height arrow-size]
[line-height 3]
[min-width 50]
[darrow (list (make-object mred:point% 0 0)
(make-object mred:point% arrow-size 0)
(make-object mred:point% (quotient arrow-size 2) (quotient arrow-size 2)))]
[rarrow (list (make-object mred:point% 0 0)
(make-object mred:point% 0 arrow-size)
(make-object mred:point% (quotient arrow-size 2) (quotient arrow-size 2)))])
(public*
[slider-install
(lambda (mn mx in)
(set! min-value mn)
(set! max-value mx)
(set! init-value in))])
(override*
[get-frame%
(lambda ()
(class (super get-frame%)
(inherit-field controls)
(super-new)
(private-field
[min-val (make-number-control controls "Minimum:" 0 (lambda () -10000) (lambda () 10000)
(lambda (x)
(set! min-value x)
(send max-val check)
(send init-val check)
(gb-need-recalc-size)))]
[max-val (make-number-control controls "Maximum:" 10 (lambda () (send min-val get-val)) (lambda () 10000)
(lambda (x)
(set! max-value x)
(send init-val check)
(gb-need-recalc-size)))]
[init-val (make-number-control controls "Initial:" 0 (lambda () (send min-val get-val))
(lambda () (send max-val get-val))
(lambda (x)
(set! init-value x)
(gb-need-recalc-size)))])))]
[get-classname (lambda () cn)]
[init-name (lambda () (new-name "slider"))]
[init-vertical-layout? (lambda () #f)]
[get-min-body-size
(lambda (dc)
(if vertical-layout?
(values height min-width)
(values min-width height)))]
[draw-body
(lambda (dc x y w h)
(let ([percent (/ (- init-value min-value) (- max-value min-value))])
(if vertical-layout?
(begin
(send dc draw-rectangle
(+ x (/ arrow-size 2)) (+ y (/ arrow-size 2))
line-height (- h arrow-size))
(send dc draw-polygon rarrow x (+ y (* percent (- h arrow-size)))))
(begin
(send dc draw-rectangle
(+ x (/ arrow-size 2)) (+ y (/ arrow-size 2))
(- w arrow-size) line-height)
(send dc draw-polygon darrow (+ x (* percent (- w arrow-size))) y)))))]
[gb-get-default-class (lambda () 'slider%)]
[gb-instantiate-arguments
(lambda ()
(list*
`[min-value ,min-value]
`[max-value ,max-value]
`[init-value ,init-value]
(super gb-instantiate-arguments)))]
[copy
(lambda ()
(let ([o (super copy)])
(send o slider-install min-value max-value init-value)
o))]
[write
(lambda (stream)
(super write stream)
(send stream put min-value)
(send stream put max-value)
(send stream put init-value))]
[read
(lambda (stream version)
(super read stream version)
(slider-install (send stream get-exact)
(send stream get-exact)
(send stream get-exact)))])
(super-new))))
(define gb:slider-snip% (gb:make-slider-snip%
(gb:make-layout-snip%
(gb:make-callback-snip%
(gb:make-text-labelled-snip% gb:atomic-snip%
"Slider")))
"gb:slider"))
(register-class gb:slider-snip% "gb:slider")
(define gb:make-gauge-snip%
(lambda (cl cn)
(class cl
(inherit-field vertical-layout?)
(inherit get-label gb-need-recalc-size)
(field
[max-value 10]
[min-height 10]
[min-width 50])
(public*
[gauge-install
(lambda (mx)
(set! max-value mx))])
(override*
[get-frame%
(lambda ()
(class (super get-frame%)
(inherit-field controls)
(super-new)
(private-field
[max-val (make-number-control controls "Maximum:" 10 (lambda () 1) (lambda () 10000)
(lambda (x)
(set! max-value x)
(gb-need-recalc-size)))])))]
[get-classname (lambda () cn)]
[init-name (lambda () (new-name "gauge"))]
[init-vertical-layout? (lambda () #f)]
[get-min-body-size
(lambda (dc)
(if vertical-layout?
(values min-height min-width)
(values min-width min-height)))]
[draw-body
(lambda (dc x y w h)
(send dc draw-rectangle x y w h)
(let ([b (send dc get-brush)])
(send dc set-brush (send mred:the-brush-list find-or-create-brush "BLACK" 'solid))
(send dc draw-rectangle
x (if vertical-layout? (+ y (* 0.75 h)) y)
(if vertical-layout? w (* 0.25 w)) (if vertical-layout? (* 0.25 h) h))
(send dc set-brush b)))]
[gb-get-default-class (lambda () 'gauge%)]
[gb-instantiate-arguments
(lambda ()
(list*
`[range ,max-value]
(super gb-instantiate-arguments)))]
[copy
(lambda ()
(let ([o (super copy)])
(send o gauge-install max-value)
o))]
[write
(lambda (stream)
(super write stream)
(send stream put max-value))]
[read
(lambda (stream version)
(super read stream version)
(gauge-install (send stream get-exact)))])
(super-new))))
(define gb:gauge-snip% (gb:make-gauge-snip%
(gb:make-layout-snip%
(gb:make-text-labelled-snip% gb:atomic-snip%
"Gauge"))
"gb:gauge"))
(register-class gb:gauge-snip% "gb:gauge")
(provide gb:slider-snip%
gb:gauge-snip%))

26
collects/guibuilder/slider.xpm
View File

@ -1,26 +0,0 @@
/* XPM */
static char *slider[] = {
/* width height num_colors chars_per_pixel */
" 16 16 3 1",
/* colors */
". c #000000",
"# c #a0a0a0",
"a c #ffffff",
/* pixels */
"aaaaaaaaaaaaaaaa",
"aaaaaaaaaaaaaaaa",
"aaaaaaaaaaaaaaaa",
"aaaaaaaaaaaaaaaa",
"aaaaaaaaaaaaaaaa",
"aaaaa.....aaaaaa",
"aaaaaa...aaaaaaa",
"aaaaaaa.aaaaaaaa",
"a##############a",
"a..............a",
"aaaaaaaaaaaaaaaa",
"aaaaaaaaaaaaaaaa",
"aaaaaaaaaaaaaaaa",
"aaaaaaaaaaaaaaaa",
"aaaaaaaaaaaaaaaa",
"aaaaaaaaaaaaaaaa"
};

135
collects/guibuilder/text-field.rkt
View File

@ -1,135 +0,0 @@
(module text-field mzscheme
(require (prefix mred: mred)
mzlib/class
mzlib/file
mzlib/pretty
mzlib/etc
mzlib/list
"utils.rkt"
"base.rkt"
"feature.rkt")
(define gb:make-text-initial-snip%
(lambda (cl)
(class cl
(inherit gb-need-recalc-size get-style)
(private-field
[initial "value"])
(public*
[get-initial (lambda () initial)]
[get-initial-size
(lambda (dc)
(let-values ([(w h d a) (send dc get-text-extent initial
(send (get-style) get-font))])
(values w h)))]
[initial-install
(lambda (i)
(set! initial i))])
(override*
[get-frame%
(lambda ()
(class (super get-frame%)
(inherit-field controls)
(super-new)
(private-field
[initial-text
(make-one-line/callback-edit controls "Initial:"
(lambda (txt)
(set! initial txt)
(gb-need-recalc-size))
initial)])))]
[copy
(lambda ()
(let ([o (super copy)])
(send o initial-install initial)
o))]
[write
(lambda (stream)
(super write stream)
(send stream put (string->bytes/utf-8 initial)))]
[read
(lambda (stream version)
(super read stream version)
(initial-install ((get-bytes->string version) (send stream get-bytes))))])
(super-new))))
(define gb:make-text-hscroll-checkable-snip%
(lambda (cl)
(class (gb:make-boolean-configure-snip% cl 'hscroll "Horizontal Scroll" #f
void
(lambda (f snip)
(send (send f find-control 'hscroll)
enable
(send snip get-tagged-value 'multi))))
(inherit get-tagged-value)
(override*
[gb-get-style
(lambda ()
(append
(if (get-tagged-value 'hscroll)
'(hscroll)
null)
(super gb-get-style)))])
(super-new))))
(define gb:make-text-snip%
(lambda (cl cn)
(class cl
(inherit-field w h)
(inherit get-initial-size get-initial
get-callback-names get-multi
get-label)
(private-field
[margin 2])
(override*
[get-classname (lambda () cn)]
[init-name (lambda () (new-name "text"))]
[init-x-stretch? (lambda () #t)]
[get-label-top-margin (lambda () margin)]
[get-min-body-size
(lambda (dc)
(let-values ([(w h) (get-initial-size dc)])
(values (+ w (* 2 margin))
(+ (* h (if (get-multi) 3 1))
(* 2 margin)))))]
[draw-body
(lambda (dc x y w h)
(send dc draw-rectangle x y w h)
(send dc draw-text (get-initial) (+ x margin) (+ y margin)))]
[get-callback-kinds (lambda ()
(list "-change-callback" "-return-callback" "-focus-callback"))]
[gb-get-default-class (lambda () 'text-field%)]
[gb-get-style (lambda () (append
(super gb-get-style)
(if (get-multi) '(multiple) '(single))))]
[gb-get-unified-callback
(lambda ()
(let-values ([(change return focus)
(apply values (get-callback-names))])
`(lambda (b e)
(let ([t (send e get-event-type)])
(cond
[(eq? t 'text-field) (,change b e)]
[(eq? t 'text-field-enter) (,return b e)]
[else (,focus b e)])))))]
[gb-instantiate-arguments
(lambda ()
(cons
`[init-value ,(get-initial)]
(super gb-instantiate-arguments)))])
(super-new))))
(define gb:text-snip% (gb:make-text-snip%
(gb:make-text-hscroll-checkable-snip%
(gb:make-multi-checkable-snip%
(gb:make-text-initial-snip%
(gb:make-callback-snip%
(gb:make-text-labelled-snip% gb:atomic-snip%
"Text")))))
"gb:text"))
(register-class gb:text-snip% "gb:text")
(provide gb:text-snip%))

22
collects/guibuilder/text.xpm
View File

@ -1,22 +0,0 @@
/* XPM */
static char * text_xpm[] = {
"16 16 3 1",
" c #FFFFFFFFFFFF",
". c #000000000000",
"X c #A0A0A0A0A0A0",
" ",
" . . ",
" . ",
" XXXXXXXXX.XX ",
" X . X ",
" X ...... . X ",
" X . .. . . X ",
" X .. . X ",
" X .. . X ",
" X .. . .X ",
" X .... X ",
" X X ",
" XXXXXXXXXXXX ",
" ",
" ",
" "};

76
collects/guibuilder/tool.rkt
View File

@ -1,76 +0,0 @@
(module tool mzscheme
(require drscheme/tool
mred
mzlib/unit
mzlib/class
string-constants
mzlib/contract
"top-level.rkt"
"toolbar.rkt"
"readable.rkt")
(provide tool@)
(define-syntax (name stx) (syntax-case stx () [(_ x e) #'(let ((x e)) x)]))
(define tool@
(unit
(import drscheme:tool^)
(export drscheme:tool-exports^)
(define (phase1) (void))
(define (phase2)
(drscheme:get/extend:extend-unit-frame
(lambda (drs:frame%)
(name guibuilder-frame%
(class drs:frame%
(inherit get-insert-menu get-edit-target-object)
(define toolbar #f)
(define toolbar-shown? #f)
(define/override (get-definitions/interactions-panel-parent)
(let ([p (super get-definitions/interactions-panel-parent)])
(set! toolbar (new toolbar% [parent p][style '(deleted)]))
(add-tools toolbar #f
(lambda (c%)
(let ([e (get-edit-target-object)])
(if (e . is-a? . gb:edit%)
(send e insert-element c%)
(message-box
(string-constant gui-tool-heading)
(string-constant gui-tool-before-clicking-message)
this
'(ok stop))))))
(new vertical-panel% (parent p))))
(define/override (add-show-menu-items menu)
(super add-show-menu-items menu)
(make-object menu-item%
(string-constant gui-tool-show-gui-toolbar)
menu
(lambda (i e)
(let ([p (send toolbar get-parent)])
(if toolbar-shown?
(send p delete-child toolbar)
(send p change-children (lambda (l)
(cons toolbar l))))
(set! toolbar-shown? (not toolbar-shown?))
(send i set-label (if toolbar-shown?
(string-constant gui-tool-hide-gui-toolbar)
(string-constant gui-tool-show-gui-toolbar)))))))
(super-new)
(make-object menu-item% (string-constant gui-tool-insert-gui) (get-insert-menu)
(lambda (b e)
(let ([e (get-edit-target-object)])
(when e
(let* ([gb (make-object gb:edit%)]
[s (make-object gui-code-snip% gb)])
(send e insert s)
(send gb create-main-panel)
(send gb set-caret-owner #f 'display))))))
(inherit register-capability-menu-item)
(register-capability-menu-item 'drscheme:special:insert-gui-tool (get-insert-menu)))))))
(drscheme:language:register-capability 'drscheme:special:insert-gui-tool (flat-contract boolean?) #t))))

159
collects/guibuilder/toolbar.rkt
View File

@ -1,159 +0,0 @@
(module toolbar mzscheme
(require (prefix mred: mred)
mzlib/class
mzlib/file
mzlib/pretty
mzlib/etc
mzlib/list
"utils.rkt")
;; These modules implement snips for the various
;; kinds of windows and controls.
(require "base.rkt"
"panel.rkt"
"simple-control.rkt"
"text-field.rkt"
"multiple-choice.rkt"
"slider-guage.rkt"
"canvas.rkt")
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Frame
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define-struct tool (icon callback active?))
(define lg-pen (send mred:the-pen-list find-or-create-pen
(make-object mred:color% 200 200 200) 0 'solid))
(define dg-pen (send mred:the-pen-list find-or-create-pen
(make-object mred:color% 140 140 140) 0 'solid))
(define icons (make-hash-table))
(define toolbar%
(class mred:canvas%
(inherit min-height stretchable-height get-dc)
(init parent [style '()])
(private-field
[margin 2]
[icon-size 16]
[tools null]
[active-tool #f])
(private*
[deactivate-tool
(lambda ()
(when active-tool
(set-tool-active?! active-tool #f)
(set! active-tool #f)
(on-paint)))]
[activate-tool
(lambda (mx my only)
(let ([y 0]
[h (+ icon-size (* 2 margin))]
[w (+ icon-size (* 2 margin))])
(let loop ([l tools][x 0])
(unless (null? l)
(if (and (<= x mx (+ x w)) (<= y my (+ y h))
(or (not only) (eq? (car l) only)))
(begin
(set! active-tool (car l))
(set-tool-active?! active-tool #t)
(on-paint))
(loop (cdr l) (+ x w)))))))])
(private-field
[can-drag #f])
(override*
[on-paint
(lambda ()
(let ([dc (get-dc)]
[y 0]
[h (+ icon-size (* 2 margin))]
[w (+ icon-size (* 2 margin))])
(let loop ([l tools][x 0])
(unless (null? l)
(let ([tool (car l)])
(let ([p (send dc get-pen)]
[on? (tool-active? tool)])
(send dc set-pen (if on? dg-pen lg-pen))
(send dc draw-line x y (+ x w -1) y)
(send dc draw-line x y x (+ y h -1))
(send dc draw-line x (add1 y) (+ x w -2) (add1 y))
(send dc draw-line (add1 x) y (add1 x) (+ y h -2))
(send dc set-pen (if on? lg-pen dg-pen))
(send dc draw-line (+ x 1) (+ y h -1) (+ x w -1) (+ y h -1))
(send dc draw-line (+ x w -1) (+ y 1) (+ x w -1) (+ y h -1))
(send dc draw-line (+ x 2) (+ y h -2) (+ x w -2) (+ y h -2))
(send dc draw-line (+ x w -2) (+ y 2) (+ x w -2) (+ y h -2))
(send dc set-pen p))
(if (tool-icon tool)
(send dc draw-bitmap (tool-icon tool) (+ x margin) margin)
(send dc draw-rectangle (+ x margin) margin icon-size icon-size)))
(loop (cdr l) (+ x w))))))]
[on-event
(lambda (e)
(cond
[(send e button-down?)
(deactivate-tool)
(activate-tool (send e get-x) (send e get-y) #f)
(set! can-drag active-tool)]
[(send e button-up?)
(set! can-drag #f)
(when active-tool
(let ([cb (tool-callback active-tool)])
(deactivate-tool)
(cb #f #f)))]
[(send e dragging?)
(when can-drag
(let ([old-active active-tool])
(set! active-tool #f)
(activate-tool (send e get-x) (send e get-y) can-drag)
(when (and (not active-tool) old-active)
(set-tool-active?! old-active #f)
(on-paint))))]
[else (set! can-drag #f)
(deactivate-tool)]))])
(public*
[append-tool
(lambda (icon-name cb)
(let* ([name (string->symbol icon-name)]
[icon
(hash-table-get
icons name
(lambda ()
(let* ([icon (make-object mred:bitmap%
(build-path (collection-path "guibuilder")
icon-name))])
(if (send icon ok?)
icon
#f))))])
(hash-table-put! icons name icon)
(set! tools (append tools (list (make-tool icon cb #f))))))])
(super-new [parent parent] [style (cons 'no-focus style)])
(min-height (+ icon-size (* margin 2)))
(stretchable-height #f)))
(define (add-tools toolbar emenu insert-element)
(let* ([append-element-type
(lambda (name icon c%)
(let ([maker (lambda (i e) (insert-element c%))])
(when toolbar
(send toolbar append-tool icon maker))
(when emenu
(make-object mred:menu-item% name emenu maker))))])
(append-element-type "New Vertical Panel" "vpanel.xpm" gb:vertical-panel-snip%)
(append-element-type "New Horizontal Panel" "hpanel.xpm" gb:horizontal-panel-snip%)
(append-element-type "New Message Label" "message.xpm" gb:message-snip%)
(append-element-type "New Button" "button.xpm" gb:button-snip%)
(append-element-type "New Checkbox" "checkbox.xpm" gb:check-box-snip%)
(append-element-type "New Text Field" "text.xpm" gb:text-snip%)
(append-element-type "New List" "list.xpm" gb:list-box-snip%)
(append-element-type "New Radiobox" "radiobox.xpm" gb:radio-box-snip%)
(append-element-type "New Choice" "choice.xpm" gb:choice-snip%)
(append-element-type "New Slider" "slider.xpm" gb:slider-snip%)
(append-element-type "New Gauge" "gauge.xpm" gb:gauge-snip%)
(append-element-type "New Canvas" "canvas.xpm" gb:canvas-snip%)
(append-element-type "New Editor Canvas" "mcanvas.xpm" gb:editor-canvas-snip%)))
(provide toolbar%
add-tools))

633
collects/guibuilder/top-level.rkt
View File

@ -1,633 +0,0 @@
#lang racket/base
(require racket/class
racket/file
racket/gui
racket/pretty
racket/list
(prefix-in mred: racket/gui)
(prefix-in framework: framework)
"utils.rkt"
"base.rkt"
"panel.rkt")
;; INVARIANT: If a snip is selected, then no ancestor or
;; descendant of the snip can be selected. Otherwise, the
;; dragging rules get complicated (perhaps impossible).
;; INVARIANT: a child must be ordered before its parent in the
;; pasteboard. Not only does this affect drawing, but it also
;; affects how select-all and rubber-banding work due to the
;; ancestor/descendant-selection-exclusion rule.
(define START-FRAME-WIDTH 100)
(define START-FRAME-HEIGHT 100)
;; Keep in order of choice items:
(define FRAME-MODE 0)
(define DIALOG-MODE 1)
(define PANEL-MODE 2)
(define -FIRST-MODE- FRAME-MODE)
(define -LAST-MODE- PANEL-MODE)
(define top-font (send mred:the-font-list find-or-create-font
12 'default 'normal 'normal #f))
;; for use of eval on the generated code
(define-namespace-anchor anchor)
(define gb:edit%
(class mred:pasteboard%
(inherit set-selected find-next-selected-snip insert
find-first-snip is-selected? add-selected remove-selected
get-admin find-snip begin-edit-sequence end-edit-sequence
get-snip-location delete erase set-modified resize
invalidate-bitmap-cache
begin-write-header-footer-to-file end-write-header-footer-to-file
get-keymap)
(private-field
[dragging? #f]
[pasting? #f]
[copying? #f]
[cur-hilite #f]
[cur-hilite-pos 0]
[cur-id 1]
[last-empty-click -inf.0])
(public*
[new-id (lambda ()
(begin0
(number->string cur-id)
(set! cur-id (add1 cur-id))))]
[for-each-snip
(lambda (f)
(let loop ([s (find-first-snip)])
(when s
(f s)
(loop (send s next)))))]
[for-each-selected-snip
(lambda (f)
(let loop ([s (find-next-selected-snip #f)])
(when s
(f s)
(loop (find-next-selected-snip s)))))]
[in-selected-hierarchy?
(lambda (s)
(or (is-selected? s)
(let ([parent (send s gb-get-parent)])
(and parent
(in-selected-hierarchy? parent)))))]
[find-unselected-snip
(lambda (x y)
(let ([s (find-snip x y)])
(if (or (not s) (and (not (in-selected-hierarchy? s))
(send s container?)))
s
(let loop ([s (find-first-snip)])
(cond
[(not s) #f]
[(and (send s container?)
(not (in-selected-hierarchy? s)))
(let ([tb (box 0)]
[lb (box 0)]
[bb (box 0)]
[rb (box 0)])
(get-snip-location s lb tb #f)
(get-snip-location s rb bb #t)
(if (and (<= (unbox lb) x (unbox rb))
(<= (unbox tb) y (unbox bb)))
s
(loop (send s next))))]
[else (loop (send s next))])))))]
[find-snip-by-XXX
(lambda (id get)
(let/ec found
(for-each-snip
(lambda (s)
(when (equal? id (get s))
(found s))))
#f))]
[find-snip-by-id
(lambda (id)
(find-snip-by-XXX id (gb-id)))]
[find-snip-by-original-id
(lambda (id)
(find-snip-by-XXX id gb-original-id))]
[find-snip-by-name
(lambda (id)
(find-snip-by-XXX id gb-name))]
[top-resized
(lambda (snip old-w old-h w h)
(when (eq? snip main-panel)
(unless (= top-level-type PANEL-MODE)
(invalidate-bitmap-cache 0 0
(+ (max old-w w) (* 2 margin))
(+ (max old-h h) (* 2 margin)
(or frame-label-h 0) 2)))))])
(augment*
[can-move-to?
(lambda (snip x y dragging?)
(or (not (eq? snip main-panel))
(and (= x main-panel-x)
(= y main-panel-y))))]
[after-move-to
(lambda (snip x y dragging?)
(when dragging?
(send snip gb-drag-children-along x y)))]
[after-resize
(lambda (snip w h did?)
(when (and (eq? snip main-panel) did?)
(unless (= top-level-type PANEL-MODE)
(invalidate-bitmap-cache
0 0 last-frame-paint-w last-frame-paint-h))))]
[on-interactive-move
(lambda (e)
(set! dragging? #t)
(for-each-snip (lambda (s) (send s gb-set-stable-position)))
(inner (void) on-interactive-move e))]
[on-select
(lambda (s on?)
(when (and (not copying?) on?)
; deselect parents:
(let loop ([p (send s gb-get-parent)])
(when p
(if (is-selected? p)
(remove-selected p)
(loop (send p gb-get-parent)))))
; deselect children:
(for-each
(lambda (c)
(when (is-selected? c)
(remove-selected c)))
(send s gb-get-children))))]
[after-interactive-move
(lambda (e)
(set! dragging? #f)
;; Adjust parent of selected snips & move selected snip's children
(for-each-selected-snip
(lambda (snip)
(when (not (eq? snip main-panel))
(let* ([parent (send snip gb-get-parent)]
[pos (if parent
(send parent gb-get-child-pos snip)
-1)])
(if cur-hilite
(when (or (not (eq? cur-hilite parent))
(not (= pos cur-hilite-pos)))
(when parent
(send parent gb-remove-child snip))
(send cur-hilite gb-add-child snip cur-hilite-pos)
(set! cur-hilite-pos (add1 cur-hilite-pos)))
(when parent
(send parent gb-remove-child snip)
(send snip gb-install this #f))))
(send snip gb-need-recalc-size))))
(when cur-hilite
(send cur-hilite gb-hilite #f)
(set! cur-hilite #f))
(inner (void) after-interactive-move e))])
(override*
[interactive-adjust-move
(lambda (snip x-box y-box)
(super interactive-adjust-move snip x-box y-box)
;; The following doesn't really work very well.
#;
(let ([parent (send snip gb-get-parent)])
(when parent
(let-values ([(x y w h)
(send (let loop ([p parent])
(let ([parent (send p gb-get-parent)])
(if parent
(loop parent)
p)))
gb-get-position-and-size)])
(when (and (<= x (unbox x-box) (+ x w))
(<= y (unbox y-box) (+ y h)))
(set-box! x-box (send snip gb-get-stable-x))
(set-box! y-box (send snip gb-get-stable-y)))))))]
[interactive-adjust-resize
(lambda (snip wb hb)
(super interactive-adjust-resize snip wb hb)
(let-values ([(x-min y-min) (send snip gb-get-saved-min-size)])
(when (or (not (gb-x-stretch? snip))
(<= (unbox wb) x-min))
(set-box! wb x-min))
(when (or (not (gb-y-stretch? snip))
(<= (unbox hb) y-min))
(set-box! hb y-min))))])
(augment*
[after-interactive-resize
(lambda (snip)
(inner (void) after-interactive-resize snip)
(send snip gb-need-recalc-size))])
(override*
[on-default-event
(lambda (e)
(unless dragging?
(when (send e button-down?)
(unless (find-next-selected-snip #f)
(when ((- (send e get-time-stamp) last-empty-click)
. < .
(send (get-keymap) get-double-click-interval))
(open-dialog))
(set! last-empty-click (send e get-time-stamp)))))
(when dragging?
(let ([x (send e get-x)]
[y (send e get-y)]
[xb (box 0)]
[yb (box 0)])
(send (get-admin) get-dc xb yb)
(let ([lx (+ x (unbox xb))]
[ly (+ y (unbox yb))])
(let ([s (find-unselected-snip lx ly)])
(when s
(set! cur-hilite-pos (send s gb-find-position lx ly)))
(when (and (or cur-hilite s)
(not (eq? cur-hilite s)))
(begin-edit-sequence)
(when cur-hilite
(send cur-hilite gb-hilite #f)
(set! cur-hilite #f))
(when s
(set! cur-hilite s)
(send s gb-hilite #t))
(end-edit-sequence))))))
(super on-default-event e))]
[on-double-click
(lambda (snip e)
(send snip gb-open-dialog))])
(augment*
[after-delete
(lambda (snip)
(for-each (lambda (i) (delete i)) (send snip gb-get-children))
(let ([parent (send snip gb-get-parent)])
(when parent
(send parent gb-remove-child snip)))
(inner (void) after-delete snip))]
[can-insert?
(lambda (snip before x y)
(is-a? snip gb:snip%))]
[after-insert
(lambda (snip behind x y)
(when pasting?
(dynamic-wind
(lambda () (set! pasting? #f))
(lambda () (send snip gb-install this #f))
(lambda () (set! pasting? #t))))
(inner (void) after-insert snip behind x y))])
(private*
[do-generic-paste
(lambda (time super-call)
(dynamic-wind
(lambda () (set! pasting? #t))
(lambda () (super-call time))
(lambda () (set! pasting? #f)))
(let ([a-paste #f])
(for-each-snip
(lambda (s)
(unless a-paste
(let ([oi (gb-original-id s)])
(when oi
(set! a-paste s))))))
(handle-new-arrivals)
(when a-paste
(let ([top-paste (let loop ([a-paste a-paste])
(let ([p (send a-paste gb-get-parent)])
(if p
(loop p)
a-paste)))])
(send main-panel gb-add-child top-paste)
(set-selected top-paste)))))])
(override*
[do-paste
(lambda (time)
(do-generic-paste time (lambda (time) (super do-paste time))))]
[do-paste-x-selection
(lambda (time)
(do-generic-paste time (lambda (time) (super do-paste-x-selection time))))])
(public*
[handle-new-arrivals
(lambda ()
(let loop ()
((let/ec k
(for-each-snip
(lambda (s)
(when (send s gb-reconnect-to-original-children)
(k loop))))
void)))
(for-each-snip (lambda (s) (send s gb-forget-original-id))))])
(override*
[do-copy
(lambda (time delete?)
(dynamic-wind
(lambda () (set! copying? #t))
(lambda ()
(when (find-next-selected-snip #f)
(letrec ([selected
(let loop ([s (find-next-selected-snip #f)])
(let ([next (find-next-selected-snip s)])
(if next
(cons s (loop next))
(list s))))]
[close-selected
(lambda (method)
(lambda (s)
(for-each
(lambda (child)
(method child)
((close-selected method) child))
(send s gb-get-children))))])
(for-each (close-selected (lambda (x) (add-selected x))) selected)
(super do-copy time delete?)
(for-each (close-selected (lambda (x) (remove-selected x))) selected))))
(lambda () (set! copying? #f))))])
(public*
[get-selected-snip
(lambda ()
(let ([s (find-next-selected-snip #f)])
(if (or (not s)
(not (find-next-selected-snip s)))
main-panel
s)))]
[insert-element
(lambda (c%)
(let* ([i (make-object c%)]
[se (get-selected-snip)]
[s (if (send se container?)
se
(or (gb-parent se)
main-panel))])
(send s gb-add-child i)
(set-selected s)))])
(init-field
[auto-show? #t]
[top-level-type FRAME-MODE]
[frame-label "Frame"]
[top-name "top"])
(private-field
[frame-label-w #f]
[frame-label-h #f]
[last-frame-paint-w 0]
[last-frame-paint-h 0]
[main-panel-x 0]
[main-panel-y 0]
[margin 2]
[configure-frame #f])
(public*
[get-top-level-type
(lambda () top-level-type)]
[get-auto-show
(lambda () auto-show?)]
[get-frame-label
(lambda () frame-label)]
[open-dialog
(lambda ()
(unless configure-frame
(set! configure-frame (make-object
(class mred:frame%
(augment*
[on-close
(lambda ()
(set! configure-frame #f)
(inner (void) on-close))])
(super-new))
"Output"))
(let ([p (make-object mred:vertical-panel% configure-frame)])
(send p set-alignment 'left 'center)
(letrec ([update-frame
(lambda ()
(send main-panel gb-need-recalc-size)
(invalidate-bitmap-cache 0 0 'end 'end))]
[kind-choice
(make-object mred:choice%
"Output:"
'("Frame" "Dialog" "Panel")
p
(lambda (c e)
(let ([mode (send c get-selection)])
(set! top-level-type mode)
(send frame-stuff enable (< mode PANEL-MODE))
(update-frame))))]
[frame-stuff (make-object mred:vertical-panel% p)]
[name-text (make-one-line/callback-edit
frame-stuff
"Scheme Name:"
(lambda (txt)
(set! top-name txt))
top-name)]
[title-text (make-one-line/callback-edit
frame-stuff
"Frame Title:"
(lambda (txt)
(unless (string=? frame-label txt)
(set! frame-label txt)
(let ([w frame-label-w]
[h frame-label-h])
(set! frame-label-h #f)
(update-frame))))
frame-label)]
[auto-show-check (make-object mred:check-box%
"Show Automatically" frame-stuff
(lambda (c e)
(set! auto-show? (send c get-value))))])
(send frame-stuff set-alignment 'left 'center)
(send frame-stuff enable (< top-level-type PANEL-MODE))
(send kind-choice stretchable-width #f)
(send kind-choice set-selection top-level-type)
(send auto-show-check set-value auto-show?))))
(send configure-frame show #t))]
[get-main-location
(lambda (snip dc dx dy)
(when (eq? snip main-panel)
(if (= top-level-type PANEL-MODE)
(begin
(set! main-panel-x 0)
(set! main-panel-y 0))
(begin
(unless frame-label-h
(let-values ([(w h d a) (send dc get-text-extent
frame-label top-font)])
(set! frame-label-w w)
(set! frame-label-h h)))
(set! main-panel-x margin)
(set! main-panel-y (+ frame-label-h 2 margin))))
(set-box! dx main-panel-x)
(set-box! dy main-panel-y)))])
(override*
[on-paint
(lambda (pre? dc l t r b dx dy show-caret?)
(unless (or (not pre?) (= top-level-type PANEL-MODE)
(not main-panel))
(let ([tb (box 0)]
[lb (box 0)]
[bb (box 0)]
[rb (box 0)])
(get-snip-location main-panel lb tb #f)
(get-snip-location main-panel rb bb #t)
(let* ([w (- (unbox rb) (unbox lb))]
[h (- (unbox bb) (unbox tb))]
[th (+ (or frame-label-h 0) 2)]
[tw (+ (* 2 margin) w)]
[totalh (+ th (* 2 margin) h)])
(when (and (or (<= 0 l tw) (<= 0 r tw) (<= l 0 tw r))
(or (<= 0 t totalh) (<= 0 b totalh) (<= t 0 totalh b)))
(set! last-frame-paint-w tw)
(set! last-frame-paint-h totalh)
(send dc draw-rectangle dx dy
tw totalh)
(send dc draw-line dx (+ dy th)
(+ dx tw -1) (+ dy th))
(with-clipping-region
dc (add1 dx) (add1 dy)
(+ tw -2) (- th 2)
(lambda ()
(let ([f (send dc get-font)])
(send dc set-font f)
(send dc draw-text frame-label
(+ dx (/ (- tw (or frame-label-w 0)) 2))
(+ dy 1))
(send dc set-font f)))))))))]
[write-footers-to-file
(lambda (stream)
(super write-footers-to-file stream)
(let ([out (lambda (name val)
(let ([info (box 0)])
(begin-write-header-footer-to-file stream name info)
(send stream put val)
(end-write-header-footer-to-file stream (unbox info))))])
(out "gb:mode" top-level-type)
(out "gb:title-utf8" (string->bytes/utf-8 frame-label))
(out "gb:top-name-utf8" (string->bytes/utf-8 top-name))
(out "gb:show" (if auto-show? 1 0))))]
[read-footer-from-file
(lambda (stream kind)
(cond
[(string=? kind "gb:mode")
(set! top-level-type
(min -LAST-MODE-
(max -FIRST-MODE- (send stream get-exact))))]
[(string=? kind "gb:title")
(set! frame-label (bytes->string/latin-1 (send stream get-bytes)))]
[(string=? kind "gb:title-utf8")
(set! frame-label (bytes->string/utf-8 (send stream get-bytes)))]
[(string=? kind "gb:top-name-utf8")
(set! top-name (bytes->string/latin-1 (send stream get-bytes)))]
[(string=? kind "gb:top-name")
(set! top-name (bytes->string/utf-8 (send stream get-bytes)))]
[(string=? kind "gb:show")
(set! auto-show? (positive? (send stream get-exact)))]
[else (super read-footer-from-file stream kind)]))]
[copy-self-to (lambda (e)
(send e prepare-to-load)
(super copy-self-to e)
(send e done-loading #t))]
[copy-self (lambda ()
(let ([e (new gb:edit%
[auto-show? auto-show?]
[top-level-type top-level-type]
[frame-label frame-label]
[top-name top-name])])
(copy-self-to e)
e))])
(private-field
[main-panel #f])
(public*
[get-main-panel (lambda () main-panel)]
[create-main-panel
(lambda ()
(erase)
(set! main-panel (make-object gb:panel-snip%))
(insert main-panel 0 0)
(resize main-panel START-FRAME-WIDTH START-FRAME-HEIGHT)
(send main-panel gb-install this #f)
(send main-panel set-id "0")
(send main-panel gb-need-recalc-size)
(set-modified #f))])
(public*
[prepare-to-load
(lambda ()
(set! pasting? #t))]
[done-loading
(lambda (ok?)
(set! pasting? #f)
(when ok?
(set! main-panel (find-snip-by-original-id "0"))
(send main-panel set-id "0")
(handle-new-arrivals)
(set-modified #f)))])
(augment*
[on-load-file
(lambda (file mode)
(prepare-to-load))]
[after-load-file
(lambda (ok?)
(done-loading ok?))])
;; Code generation:
(public*
[instantiate
(lambda ()
(let ([code (build-code #t #f)])
(thread
(lambda ()
(parameterize ([mred:current-eventspace (mred:make-eventspace)]
[current-namespace (namespace-anchor->namespace anchor)])
(eval code))))))]
[view-source
(lambda ()
(let ([port (open-output-string)])
(pretty-print (build-code #f #f) port)
(let ([f (make-object (framework:frame:text-mixin framework:frame:editor%)
"code.scm")])
(send (send f get-editor) insert (get-output-string port))
(send f show #t))))]
[build-code
(lambda (force-frame? as-class?)
(let* ([main (get-main-panel)]
[type (get-top-level-type)]
[frame-label (if (and (= type PANEL-MODE) force-frame?)
"Panel Tester"
(get-frame-label))]
[mode (make-output-mode as-class? force-frame?)]
[top (string->symbol top-name)])
`(,@(cond
[as-class? '(class object%)]
[(and (= type PANEL-MODE)
(not force-frame?))
'(lambda (top))]
[else '(begin)])
,@(if as-class?
(if (and (= type PANEL-MODE) (not force-frame?))
'((init top))
'())
'())
,@(cond
[(or (= type FRAME-MODE)
(and (= type PANEL-MODE) force-frame?))
(if as-class?
`((public* [get-top% (lambda () frame%)])
(field [,top (make-object (get-top%) ,frame-label)]))
`((define ,top (make-object frame% ,frame-label))))]
[(= type PANEL-MODE) null]
[else
(if as-class?
`((public* [get-top% (lambda () dialog%)])
(field [,top (make-object (get-top%) ,frame-label)]))
`((define ,top (make-object dialog% ,frame-label))))])
,@(send main gb-instantiate 'top mode)
,@(if as-class?
'((super-new))
null)
,@(if (and (not force-frame?)
(or (= type PANEL-MODE) (not (get-auto-show))))
null
`((send ,top show #t))))))])
(super-new)))
(provide gb:edit%)

101
collects/guibuilder/utils.rkt
View File

@ -1,101 +0,0 @@
(module utils mzscheme
(require (prefix mred: mred)
mzlib/class
mzlib/etc
mzlib/list)
(define-syntax (private-field stx)
(syntax-case stx ()
[(_ (id val) ...)
(syntax/loc stx (begin (define id val) ...))]))
(define make-one-line/callback-edit
(opt-lambda (parent label cb [v ""])
(make-object mred:text-field% label parent
(lambda (t e) (cb (send t get-value))) v)))
(define make-number-control
(lambda (parent label value get-min get-max set-v)
(let* ([p (make-object mred:horizontal-panel% parent)]
[l (make-object mred:message% label p)]
[vl (make-object mred:message% "999999" p)]
[set-value
(lambda (n)
(set! value n)
(send vl set-label (number->string n))
(set-v n))]
[b (make-object mred:button%
"Set..."
p
(lambda (b e)
(let ([v (mred:get-text-from-user
(format "~a, in [~a, ~a]:" label (get-min) (get-max))
label
#f
(number->string value))])
(when v
(let ([n (string->number v)])
(if (and (integer? n) (exact? n)
(>= n (get-min)) (<= n (get-max)))
(set-value n)
(mred:message-box "Error" "Bad value")))))))])
(send vl set-label (number->string value))
(make-object (class object% ()
(public*
[get-val (lambda () value)]
[check (lambda ()
(when (< value (get-min))
(set-value (get-min)))
(when (> value (get-max))
(set-value (get-max))))])
(super-new))))))
(define new-name (lambda (base) (symbol->string (gensym base))))
(define (stream-write-list stream l)
(send stream put (length l))
(for-each
(lambda (i)
(send stream put (string->bytes/utf-8 i)))
l))
(define (get-bytes->string version)
(if (version . >= . 5)
bytes->string/utf-8
bytes->string/latin-1))
(define (stream-read-list stream version)
(let ([n (send stream get-exact)]
[b->s (get-bytes->string version)])
(let loop ([n n])
(if (zero? n)
null
(cons (b->s (send stream get-bytes)) (loop (sub1 n)))))))
(define cached-region #f)
(define cached-region-dc #f)
(define (with-clipping-region dc x y w h thunk)
(let ([r (send dc get-clipping-region)]
[r2 (if (eq? dc cached-region-dc)
cached-region
(make-object mred:region% dc))])
(set! cached-region-dc #f)
(send r2 set-rectangle x y w h)
(send r2 intersect r)
(send dc set-clipping-region r2)
(thunk)
(send dc set-clipping-region r)
(set! cached-region r2)
(set! cached-region-dc dc)))
(provide private-field
make-one-line/callback-edit
make-number-control
new-name
get-bytes->string
stream-write-list
stream-read-list
with-clipping-region))

22
collects/guibuilder/vpanel.xpm
View File

@ -1,22 +0,0 @@
/* XPM */
static char * vpanel_xpm[] = {
"16 16 3 1",
" c #FFFFFFFFFFFF",
". c #000000000000",
"X c #A0A0A0A0A0A0",
" ",
" .......... ",
" . . ",
" . . ",
" . XXXX . ",
" . . ",
" . . ",
" . XXXX . ",
" . XXXX . ",
" . . ",
" . . ",
" . XXXX . ",
" . . ",
" . . ",
" .......... ",
" "};