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

.

Browse Source 
original commit: 2539a4b8947f614b6ddd56eec831b190020c928e
This commit is contained in:
Matthew Flatt 2004-12-30 15:57:52 +00:00
parent 9d83265f7b
commit fa0140d065
3 changed files with 94 additions and 44 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/mred/private/kernel.ss
View File

@ -934,8 +934,8 @@
get-inexact
get-exact
get-fixed
get-unterminated-bytes
get-bytes
get-terminated-bytes
get)
(define-class editor-stream-out% object% #f
ok?

24
collects/tests/mred/draw.ss
View File

@ -88,11 +88,12 @@
(list->bytes '(#xcc #x33 #xcc #x33 #xcc #x33 #xcc #x33))
8 8))
(let* ([f (make-object frame% "Graphics Test" #f 300 450)]
(let* ([f (make-object frame% "Graphics Test" #f 300 550)]
[vp (make-object vertical-panel% f)]
[hp0 (make-object horizontal-panel% vp)]
[hp (make-object horizontal-panel% vp)]
[hp2 hp]
[hp2.5 (make-object horizontal-panel% vp)]
[hp3 (make-object horizontal-pane% vp)]
[bb (make-object bitmap% (sys-path "bb.gif") 'gif)]
[return (let* ([bm (make-object bitmap% (sys-path "return.xbm") 'xbm)]
@ -107,11 +108,13 @@
[use-bad? #f]
[depth-one? #f]
[cyan? #f]
[smoothing 'unsmoothed]
[save-filename #f]
[save-file-format #f]
[clip 'none])
(send hp0 stretchable-height #f)
(send hp stretchable-height #f)
(send hp2.5 stretchable-height #f)
(send hp3 stretchable-height #f)
(make-object button% "What Should I See?" hp0
(lambda (b e)
@ -734,6 +737,17 @@
(send dc set-pen pent)
(loop (cdr l) (+ x 20)))))))
(when last?
(send dc set-pen (make-object pen% "black" 1 'transparent))
(send dc set-brush (make-object brush% "blue" 'solid))
(send dc draw-ellipse 400 10 40 40)
(send dc draw-ellipse 400 50 40 40)
(send dc draw-ellipse 400 90 40 40)
(send dc set-pen (make-object pen% "black" 1 'solid))
(send dc draw-ellipse 400 130 40 40)
(send dc draw-ellipse 400 170 40 40)
(send dc draw-ellipse 400 210 40 40))
(when (and last? (not (or ps? (eq? dc can-dc)))
(send mem-dc get-bitmap))
(send can-dc draw-bitmap (send mem-dc get-bitmap) 0 0 'opaque)))
@ -759,6 +773,7 @@
(send dc set-scale xscale yscale)
(send dc set-origin offset offset)
(send dc set-smoothing smoothing)
(send dc set-background
(if cyan?
@ -923,7 +938,12 @@
(make-object check-box% "Pixset" hp2
(lambda (self event)
(send canvas set-pixel-copy (send self get-value))))
(make-object check-box% "Kern" hp2
(make-object choice% #f '("Unsmoothed" "Smoothed" "Compatible") hp2.5
(lambda (self event)
(set! smoothing (list-ref '(unsmoothed smoothed compatible)
(send self get-selection)))
(send canvas on-paint)))
(make-object check-box% "Kern" hp2.5
(lambda (self event)
(send canvas set-kern (send self get-value))))
(make-object choice% "Clip"

112
collects/tests/mred/editor.ss
View File

@ -132,12 +132,16 @@
;; Snips and Streams ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define number-snip-class%
(define (mk-number-snip-class% term?)
(class snip-class%
(define/override (read f)
(let* ([number-str (send f get-bytes)]
(let* ([number-str (if term?
(send f get-bytes)
(send f get-unterminated-bytes))]
[number (string->number (bytes->string/utf-8 number-str))]
[decimal-prefix (bytes->string/utf-8 (send f get-bytes))]
[decimal-prefix (bytes->string/utf-8 (if term?
(send f get-bytes)
(send f get-unterminated-bytes)))]
[snip
(instantiate number-snip% ()
[number number]
@ -145,48 +149,74 @@
snip))
(super-instantiate ())))
(define snip-class (make-object number-snip-class%))
(define snip-class (make-object (mk-number-snip-class% #t)))
(send snip-class set-classname (format "~s" `(lib "number-snip.ss" "drscheme" "private")))
(send (get-the-snip-class-list) add snip-class)
(define number-snip%
(class snip%
(init-field number)
(define/public (get-number) number)
(define/public (get-prefix) decimal-prefix)
(init-field [decimal-prefix ""])
(define/override (write f)
(send f put (string->bytes/utf-8 (number->string number)))
(send f put (string->bytes/utf-8 decimal-prefix)))
(define/override (copy)
(instantiate number-snip% ()
[number number]
[decimal-prefix decimal-prefix]))
(inherit get-style)
(super-instantiate ())
(inherit set-snipclass set-flags get-flags)
(set-snipclass snip-class)))
(define snip-class2 (make-object (mk-number-snip-class% #f)))
(send snip-class2 set-classname (format "~s" `(lib "number-snip-two.ss" "drscheme" "private")))
(send (get-the-snip-class-list) add snip-class2)
(define t (new text%))
(define t2 (new text%))
(send t insert (instantiate number-snip% () [number 1/2]))
(send t set-position 0 1)
(send t copy)
;; Under X, force snip to be marshalled:
(let ([s (send the-clipboard get-clipboard-data "WXME" 0)])
(send the-clipboard set-clipboard-client
(make-object (class clipboard-client%
(define/override (get-data fmt)
(and (string=? fmt "WXME")
s))
(inherit add-type)
(super-new)
(add-type "WXME")))
0))
(send t2 paste)
(let ([s (send t2 find-first-snip)])
(st 1/2 s get-number)
(st "" s get-prefix))
(define (mk-number-snip% snip-class term?)
(define self%
(class snip%
(init-field number)
(define/public (get-number) number)
(define/public (get-prefix) decimal-prefix)
(init-field [decimal-prefix ""])
(define/override (write f)
(let ([num (string->bytes/utf-8 (number->string number))]
[pfx (string->bytes/utf-8 decimal-prefix)])
(if term?
(begin
(send f put num)
(send f put pfx))
(begin
(unless (eq? 'ok
(with-handlers ([exn:fail? (lambda (x) 'ok)])
(send f put 5 #"123")
'not-ok))
(error "too-long write should have failed"))
(send f put (bytes-length num) num)
(send f put (bytes-length pfx) pfx)))))
(define/override (copy)
(instantiate self% ()
[number number]
[decimal-prefix decimal-prefix]))
(inherit get-style)
(super-instantiate ())
(inherit set-snipclass set-flags get-flags)
(set-snipclass snip-class)))
self%)
(define number-snip% (mk-number-snip% snip-class #t))
(define number-snip2% (mk-number-snip% snip-class2 #f))
(define (snip-test term?)
(define t (new text%))
(define t2 (new text%))
(send t insert (new (if term? number-snip% number-snip2%)
[number 1/2]))
(send t set-position 0 1)
(send t copy)
;; Under X, force snip to be marshalled:
(let ([s (send the-clipboard get-clipboard-data "WXME" 0)])
(send the-clipboard set-clipboard-client
(make-object (class clipboard-client%
(define/override (get-data fmt)
(and (string=? fmt "WXME")
s))
(inherit add-type)
(super-new)
(add-type "WXME")))
0))
(send t2 paste)
(let ([s (send t2 find-first-snip)])
(st 1/2 s get-number)
(st "" s get-prefix)))
(snip-test #t)
(snip-test #f)
(let ()
(define orig-snip (make-object string-snip% "hello"))