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

.

Browse Source 
original commit: 8f00b4c933d9ad9dacbba745a8e8c4e1e87a0217
This commit is contained in:
Matthew Flatt 2002-12-18 22:54:32 +00:00
parent 6a7c4b554a
commit b36417e76d
1 changed files with 12 additions and 9 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

21
collects/hierlist/hierlist-unit.ss
View File

@ -37,6 +37,8 @@
;; Hack for implementing auto-wrapping items: ;; Hack for implementing auto-wrapping items:
(define arrow-size 0) (define arrow-size 0)
(define orig-size (max (send up-click-bitmap get-width) (send up-click-bitmap get-height)))
;; Private arrow snip class: ;; Private arrow snip class:
(define arrow-snip-class (make-object snip-class%)) (define arrow-snip-class (make-object snip-class%))
(send arrow-snip-class set-classname "hier-arrow") (send arrow-snip-class set-classname "hier-arrow")
@ -46,7 +48,7 @@
(rename [super-get-extent get-extent]) (rename [super-get-extent get-extent])
(private-field (private-field
[size-calculated? #f] [size-calculated? #f]
[size (max (send up-click-bitmap get-width) (send up-click-bitmap get-height))] [size orig-size]
[width-fraction 1/2] [width-fraction 1/2]
[on? #f] [on? #f]
[click-callback callback] [click-callback callback]
@ -58,11 +60,11 @@
[h (send s get-text-height dc)] [h (send s get-text-height dc)]
[d (send s get-text-descent dc)] [d (send s get-text-descent dc)]
[a (send s get-text-space dc)]) [a (send s get-text-space dc)])
(set! size (- h d a)) (set! size (max orig-size (- h d a)))
(set! size-calculated? #t) (set! size-calculated? #t)
(set! arrow-size (+ size 2))))] (set! arrow-size size)))]
[get-width (lambda () (+ 2 size))] [get-width (lambda () size)]
[get-height (lambda () (+ 2 size))] [get-height (lambda () size)]
[update [update
(lambda () (lambda ()
(send (get-admin) needs-update this 0 0 (get-width) (get-height)))]) (send (get-admin) needs-update this 0 0 (get-width) (get-height)))])
@ -72,7 +74,7 @@
(unless size-calculated? (set-sizes dc)) (unless size-calculated? (set-sizes dc))
(when w (set-box! w (get-width))) (when w (set-box! w (get-width)))
(when h (set-box! h (get-height))) (when h (set-box! h (get-height)))
(when descent (set-box! descent 2)) (when descent (set-box! descent 0))
(when space (set-box! space 0)))] (when space (set-box! space 0)))]
[partial-offset (lambda (dc x y len) [partial-offset (lambda (dc x y len)
(unless size-calculated? (set-sizes dc)) (unless size-calculated? (set-sizes dc))
@ -86,9 +88,10 @@
(if on? down-bitmap up-bitmap))] (if on? down-bitmap up-bitmap))]
[bw (send bitmap get-width)] [bw (send bitmap get-width)]
[bh (send bitmap get-height)]) [bh (send bitmap get-height)])
(send dc draw-bitmap bitmap (send dc draw-bitmap-section bitmap
(+ x (- (/ size 2) (/ bw 2))) (+ x (max 0 (- (/ size 2) (/ bw 2))))
(+ y (- (/ size 2) (/ bh 2))))))] (+ y (max 0 (- (/ size 2) (/ bh 2))))
0 0 (min bw (+ size 2)) (min bh (+ size 2)))))]
[size-cache-invalid (lambda () (set! size-calculated? #f))] [size-cache-invalid (lambda () (set! size-calculated? #f))]
[on-event [on-event
(lambda (dc x y mediax mediay event) (lambda (dc x y mediax mediay event)