.
original commit: bab179b024559a8a6e6ce624fb9908744dcd0114
This commit is contained in:
Robby Findler
parent
6b1a9bfdb9
commit
1c7947850d
|
|
@ -1,148 +0,0 @@
|
|||
(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))
|
||||
)
|
||||
|
|
@ -1,131 +0,0 @@
|
|||
(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)
|
||||
)
|
||||
|
|
@ -1,56 +0,0 @@
|
|||
(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))))
|
||||
|
|
@ -1,56 +0,0 @@
|
|||
(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))]))
|
||||
)
|
||||
|
|
@ -16,6 +16,15 @@
|
|||
(let* ([o (,open)]
|
||||
[b (make-weak-box o)])
|
||||
(,close o)
|
||||
|
||||
;; break at least that link.
|
||||
(set! o #f)
|
||||
|
||||
;; flush pending events
|
||||
(let ([s (make-semaphore 0)])
|
||||
(queue-callback (lambda () (semaphore-post s)) #f)
|
||||
(yield s))
|
||||
|
||||
(cons b (loop (- n 1))))]))])
|
||||
(sleep/yield 1/10) (collect-garbage)
|
||||
(sleep/yield 1/10) (collect-garbage)
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user