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

...

Browse Source 
original commit: 936180b3aa8fce33882fc7d8eb91131a05119dce
This commit is contained in:
Robby Findler 1999-06-28 05:30:37 +00:00
parent 74c2fdeccc
commit 2198e9338a
6 changed files with 182 additions and 109 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

38
collects/framework/canvas.ss
View File

@ -1,17 +1,44 @@
(unit/sig framework:canvas^
(import mred-interfaces^
[preferences : framework:preferences^])
[preferences : framework:preferences^]
[frame : framework:frame^])
(define basic<%> (interface (editor-canvas<%>)))
(define basic-mixin
(mixin (editor-canvas<%>) (basic<%>) args
(inherit get-editor)
(sequence
(apply super-init args))))
(define info<%> (interface (basic<%>)))
(define info-mixin
(mixin (basic<%>) (info<%>) (parent [editor #f] . args)
(inherit has-focus? get-top-level-window)
(rename [super-on-focus on-focus]
[super-set-editor set-editor])
(override
[on-focus
(lambda (on?)
(super-on-focus on?)
(send (get-top-level-window) set-info-canvas (and on? this))
(when on?
(send (get-top-level-window) update-info)))]
[set-editor
(lambda (m)
(super-set-editor m)
(let ([tlw (get-top-level-window)])
(cond
[(eq? this (send tlw get-info-canvas))
(send tlw update-info)])))])
(sequence
(apply super-init parent editor args)
(unless (is-a? (get-top-level-window) frame:info<%>)
(error 'canvas:text-info-mixin
"expected to be placed into a frame or dialog implementing frame:info<%>, got: ~e"
(get-top-level-window)))
(when (has-focus?)
(send (get-top-level-window) update-info)))))
(define wide-snip<%> (interface (basic<%>)
add-wide-snip
add-tall-snip))
@ -108,4 +135,5 @@
(apply super-init args))))
(define basic% (basic-mixin editor-canvas%))
(define wide-snip% (wide-snip-mixin basic%)))
(define info% (info-mixin basic%))
(define wide-snip% (wide-snip-mixin basic%)))

119
collects/framework/frame.ss
View File

@ -13,6 +13,7 @@
[text : framework:text^]
[pasteboard : framework:pasteboard^]
[editor : framework:editor^]
[canvas : framework:canvas^]
[mzlib:function : mzlib:function^])
(rename [-editor<%> editor<%>]
@ -119,7 +120,7 @@
(accept-drop-files #t)
(make-object menu% "Windows" (make-object (get-menu-bar%) this))
(make-object menu% "&Windows" (make-object (get-menu-bar%) this))
(reorder-menus this)
(send (group:get-the-frame-group) insert-frame this))
(private
@ -137,6 +138,7 @@
set-label-prefix
get-canvas%
get-canvas<%>
get-editor%
get-editor<%>
@ -199,17 +201,25 @@
(set! label t)
(do-label)))])
(public
[get-canvas% (lambda () editor-canvas%)]
[get-canvas% (lambda () editor-canvas<%>)]
[get-canvas<%> (lambda () editor-canvas%)]
[make-canvas (lambda ()
(let ([% (get-canvas%)]
[<%> (get-canvas<%>)])
(unless (implementation? % <%>)
(error 'frame:editor%
"result of get-canvas% method must match ~e interface; got: ~e"
<%> %))
(make-object % (get-area-container))))]
[get-editor% (lambda () (error 'editor-frame% "no editor% class specified"))]
[get-editor<%> (lambda () editor<%>)]
[make-editor (lambda ()
(let ([% (get-editor%)]
[<%> (get-editor<%>)])
(unless (implementation? % <%>)
(let ([name (inferred-name this)])
(error (or name 'frame:editor%)
"result of get-editor% method must match ~e interface; got: ~e"
<%> %)))
(error 'frame:editor%
"result of get-editor% method must match ~e interface; got: ~e"
<%> %))
(make-object %)))])
@ -317,7 +327,7 @@
[get-canvas (let ([c #f])
(lambda ()
(unless c
(set! c (make-object (get-canvas%) (get-area-container)))
(set! c (make-canvas))
(send c set-editor (get-editor)))
c))]
[get-editor (let ([e #f])
@ -820,9 +830,11 @@
(define info<%> (interface (-editor<%>)
determine-width
get-info-editor
lock-status-changed
update-info
set-info-canvas
get-info-canvas
get-info-editor
get-info-panel))
(define info-mixin
@ -842,6 +854,26 @@
(set! rest-panel r-root)
r-root))])
(override
[get-canvas<%>
(lambda () canvas:info<%>)]
[get-canvas%
(lambda () canvas:info%)])
(private
[info-canvas #f])
(public
[get-info-canvas
(lambda ()
info-canvas)]
[set-info-canvas
(lambda (c)
(set! info-canvas c))]
[get-info-editor
(lambda ()
(and info-canvas
(send info-canvas get-editor)))])
(public
[determine-width
(let ([magic-space 25])
@ -883,19 +915,17 @@
(unregister-collecting-blit gc-canvas)
(close-panel-callback))])
(inherit get-editor)
(public
[get-info-editor
(lambda ()
(and (procedure? get-editor)
(get-editor)))])
(public
[lock-status-changed
(let ([icon-currently-locked? #f])
(lambda ()
(let ([info-edit (get-info-editor)])
(when info-edit
(cond
[(not (object? lock-message))
(void)]
[info-edit
(unless (send lock-message is-shown?)
(send lock-message show #t))
(let ([locked-now? (ivar info-edit locked?)])
(unless (eq? locked-now? icon-currently-locked?)
(set! icon-currently-locked? locked-now?)
@ -908,7 +938,10 @@
set-label
(if (send label ok?)
label
(if locked-now? "Locked" "Unlocked")))))))))))])
(if locked-now? "Locked" "Unlocked")))))))]
[else
(when (send lock-message is-shown?)
(send lock-message show #f))]))))])
(public
[update-info
(lambda ()
@ -1033,7 +1066,12 @@
(if offset?
(+ pos 1)
pos)))))])
(when edit
(cond
[(not (object? position-canvas))
(void)]
[edit
(unless (send position-canvas is-shown?)
(send position-canvas show #t))
(let ([start (send edit get-start-position)]
[end (send edit get-end-position)])
(unless (and last-start
@ -1051,20 +1089,33 @@
(string-append (make-one start)
"-"
(make-one end))))
(lock #t)))))))))])
(lock #t)))))]
[else
(when (send position-canvas is-shown?)
(send position-canvas show #f))]))))])
(public
[anchor-status-changed
(let ([last-state? #f])
(lambda ()
(let ([info-edit (get-info-editor)])
(when info-edit
(let ([info-edit (get-info-editor)]
[failed
(lambda ()
(unless (eq? last-state? #f)
(set! last-state? #f)
(send anchor-message show #f)))])
(cond
[info-edit
(let ([anchor-now? (send info-edit get-anchor)])
(unless (eq? anchor-now? last-state?)
(when (object? anchor-message)
(cond
[(object? anchor-message)
(send anchor-message
show
anchor-now?))
(set! last-state? anchor-now?)))))))]
anchor-now?)
(set! last-state? anchor-now?)]
[else (failed)])))]
[else
(failed)]))))]
[editor-position-changed
(lambda ()
(editor-position-changed-offset/numbers
@ -1073,15 +1124,25 @@
[overwrite-status-changed
(let ([last-state? #f])
(lambda ()
(let ([info-edit (get-info-editor)])
(when info-edit
(let ([info-edit (get-info-editor)]
[failed
(lambda ()
(set! last-state? #f)
(send overwrite-message show #f))])
(cond
[info-edit
(let ([overwrite-now? (send info-edit get-overwrite-mode)])
(unless (eq? overwrite-now? last-state?)
(when (object? overwrite-message)
(cond
[(object? overwrite-message)
(send overwrite-message
show
overwrite-now?))
(set! last-state? overwrite-now?)))))))])
overwrite-now?)
(set! last-state? overwrite-now?)]
[else
(failed)])))]
[else
(failed)]))))])
(rename [super-update-info update-info])
(override
[update-info

20
collects/framework/frameworks.ss
View File

@ -1,6 +1,3 @@
;; language specification
(compile-allow-cond-fallthrough #t)
(require-library "refer.ss")
(require-library "macro.ss")
(require-library "cores.ss")
@ -133,20 +130,19 @@
searching%
info%))
(define-signature framework:pasteboard%
(pasteboard:basic%
pasteboard:info%
pasteboard:file%
pasteboard:backup-autosave%))
(define-signature framework:canvas^
(basic-mixin
basic<%>
basic%
info-mixin
info<%>
wide-snip-mixin
wide-snip<%>
wide-snip%))
wide-snip%
basic%
info%))
(define-signature framework:frame^
(reorder-menus

2
collects/framework/group.ss
View File

@ -29,7 +29,7 @@
(and menu-bar
(let ([menus (send menu-bar get-items)])
(ormap (lambda (x)
(if (string=? "Windows" (send x get-label))
(if (string=? "&Windows" (send x get-label))
x
#f))
menus)))))]

40
collects/framework/prefs.ss
View File

@ -303,22 +303,6 @@
number?)
font-size-entry))
(define (later-on)
(local [(define sema (make-semaphore 1))
(define running #f)
(define (start-one thunk)
(local [(define (do-one)
(thunk)
(semaphore-wait sema)
(set! running #f)
(semaphore-post sema))]
(semaphore-wait sema)
(when running
(kill-thread running))
(set! running (thread do-one))
(semaphore-post sema)))]
start-one))
(define ppanels
(list
(make-ppanel
@ -441,13 +425,15 @@
new-message
button
canvas))))))
(send canvas set-line-count 1)
(vector set-edit-font
(lambda () (send message get-width))
(lambda (width) (send message min-width width))
(lambda () (send label get-width))
(lambda (width) (send label min-width width)))))]
[set-edit-fonts/messages (map make-family-panel font-families)]
[collect (lambda (n) (map (lambda (x) (vector-ref x n)) set-edit-fonts/messages))]
[collect (lambda (n) (map (lambda (x) (vector-ref x n))
set-edit-fonts/messages))]
[set-edit-fonts (collect 0)]
[font-message-get-widths (collect 1)]
[font-message-user-min-sizes (collect 2)]
@ -458,6 +444,13 @@
(let ([width (mzlib:function:foldl (lambda (x l) (max l (x))) 0 gets)])
(for-each (lambda (set) (set width)) sets)))]
[size-panel (make-object horizontal-panel% main '(border))]
[initial-font-size
(let ([b (box 0)])
(if (get-resource font-section
font-size-entry
b)
(unbox b)
font-default-size))]
[size-slider
(make-object slider%
"Size"
@ -465,24 +458,17 @@
size-panel
(lambda (slider evt)
(set font-size-pref-sym (send slider get-value)))
(let ([b (box 0)])
(if (get-resource font-section
font-size-entry
b)
(unbox b)
font-default-size)))]
[guard-change-font (later-on)])
initial-font-size)])
(update-message-sizes font-message-get-widths font-message-user-min-sizes)
(update-message-sizes category-message-get-widths category-message-user-min-sizes)
(add-callback
font-size-pref-sym
(lambda (p value)
(guard-change-font
(lambda ()
(map (lambda (f) (f value)) set-edit-fonts)))
(for-each (lambda (f) (f value)) set-edit-fonts)
(unless (= value (send size-slider get-value))
(send size-slider set-value value))
#t))
(for-each (lambda (f) (f initial-font-size)) set-edit-fonts)
(make-object message% "Restart to see font changes" main)
main))
#f)))

72
collects/framework/text.ss
View File

@ -41,31 +41,32 @@
[invalidate-rectangles
(lambda (rectangles)
(let-values ([(min-left max-right)
(let loop ([left #f]
[right #f]
[canvases (get-canvases)])
(cond
[(null? canvases)
(values left right)]
[else
(let-values ([(this-left this-right)
(send (car canvases)
call-as-primary-owner
(lambda ()
(send (get-admin) get-view b1 b2 b3 b4)
(let* ([this-left (unbox b1)]
[this-width (unbox b3)]
[this-right (+ this-left this-width)])
(values this-left
this-right))))])
(if (and left right)
(loop (min this-left left)
(max this-right right)
(cdr canvases))
(loop this-left
this-right
(cdr canvases))))]))])
(let-values
([(min-left max-right)
(let loop ([left #f]
[right #f]
[canvases (get-canvases)])
(cond
[(null? canvases)
(values left right)]
[else
(let-values ([(this-left this-right)
(send (car canvases)
call-as-primary-owner
(lambda ()
(send (get-admin) get-view b1 b2 b3 b4)
(let* ([this-left (unbox b1)]
[this-width (unbox b3)]
[this-right (+ this-left this-width)])
(values this-left
this-right))))])
(if (and left right)
(loop (min this-left left)
(max this-right right)
(cdr canvases))
(loop this-left
this-right
(cdr canvases))))]))])
(let loop ([left #f]
[top #f]
[right #f]
@ -78,6 +79,7 @@
[height (- bottom top)])
(when (and (> width 0)
(> height 0))
(printf "invalidating ~a ~a ~a ~a~n" left top width height)
(invalidate-bitmap-cache left top width height))))]
[else (let* ([r (car rectangles)]
@ -187,16 +189,16 @@
(recompute-range-rectangles)
(invalidate-rectangles range-rectangles)
(lambda ()
(invalidate-rectangles range-rectangles)
(set! ranges
(let loop ([r ranges])
(cond
[(null? r) r]
[else (if (eq? (car r) l)
(cdr r)
(cons (car r) (loop (cdr r))))])))
(recompute-range-rectangles)
(invalidate-rectangles range-rectangles))))])
(let ([old-rectangles range-rectangles])
(set! ranges
(let loop ([r ranges])
(cond
[(null? r) r]
[else (if (eq? (car r) l)
(cdr r)
(cons (car r) (loop (cdr r))))])))
(recompute-range-rectangles)
(invalidate-rectangles old-rectangles)))))])
(rename [super-on-paint on-paint])
(override
[on-paint