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

...

Browse Source 
original commit: fbd6c2e6b65df87bea47cdf8e586420e20b97f81
This commit is contained in:
Robby Findler 1999-05-27 22:37:03 +00:00
parent dc50ed83e2
commit 1a9d875296
7 changed files with 126 additions and 93 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

17
collects/framework/canvas.ss
View File

@ -1,15 +1,25 @@
(unit/sig framework:canvas^
(import mred-interfaces^
[preferences : framework:preferences^])
(define wide-snip<%> (interface (editor-canvas<%>)
(define basic<%> (interface (editor-canvas<%>)))
(define basic-mixin
(mixin (editor-canvas<%>) (basic<%>) args
(inherit get-editor)
(sequence
(apply super-init args))))
(define wide-snip<%> (interface (basic<%>)
add-wide-snip
add-tall-snip))
;; wx: this need to collude with
;; the edit, since the edit has the right callbacks.
(define wide-snip-mixin
(mixin (editor-canvas<%>) (wide-snip<%>) args
(mixin (basic<%>) (wide-snip<%>) args
(inherit get-editor)
(rename [super-on-size on-size])
(private
@ -97,4 +107,5 @@
(sequence
(apply super-init args))))
(define wide-snip% (wide-snip-mixin editor-canvas%)))
(define basic% (basic-mixin editor-canvas%))
(define wide-snip% (wide-snip-mixin basic%)))

13
collects/framework/frame.ss
View File

@ -274,7 +274,7 @@
#t
(preferences:get 'framework:print-output-mode))
#t)])
(private
[edit-menu:do (lambda (const)
(lambda (menu evt)
@ -283,16 +283,9 @@
(is-a? edit editor<%>))
(send edit do-edit-operation const)))
#t))])
(override
[edit-menu:undo (edit-menu:do 'undo)]
[edit-menu:redo (edit-menu:do 'redo)]
[edit-menu:cut (edit-menu:do 'cut)]
[edit-menu:clear (edit-menu:do 'clear)]
[edit-menu:copy (edit-menu:do 'copy)]
[edit-menu:paste (edit-menu:do 'paste)]
[edit-menu:select-all (edit-menu:do 'select-all)]
[edit-menu:between-find-and-preferences
[edit-menu:between-select-all-and-find
(lambda (edit-menu)
(make-object separator-menu-item% edit-menu)
(make-object (get-menu-item%) "Insert Text Box" edit-menu

5
collects/framework/frameworks.ss
View File

@ -140,7 +140,10 @@
(define-signature framework:canvas^
(wide-snip-mixin
(basic-mixin
basic<%>
basic%
wide-snip-mixin
wide-snip<%>
wide-snip%))

2
collects/framework/gen-standard-menus.ss
View File

@ -131,7 +131,7 @@ string=? ; exec mred -mgaqvf $0
(pretty-print
`(define standard-menus-mixin
(mixin (basic<%>) (standard-menus<%>) args
(inherit get-menu-bar can-close? on-close show)
(inherit get-menu-bar can-close? on-close show get-edit-target-object)
(sequence (apply super-init args))
,@(append
(map (lambda (x)

2
collects/framework/main.ss
View File

@ -48,9 +48,9 @@
case when unless match
let-enumerate
class class* class-asi class-asi*
make-object mixin
define-some do opt-lambda send*
local catch shared
make-object
unit/sig
with-handlers
interface

42
collects/framework/standard-menus-items.ss
View File

@ -21,6 +21,14 @@
middle
(an-item-item-name item)))]))
(define (edit-menu:do const)
`(lambda (menu evt)
(let ([edit (get-edit-target-object)])
(when (and edit
(is-a? edit editor<%>))
(send edit do-edit-operation ',const)))
#t))
(define items
(list (make-generic 'get-menu% '(lambda () menu%)
'("The result of this method is used as the class for creating the result of these methods:"
@ -111,24 +119,38 @@
'(if (eq? (system-type) 'windows) "E&xit" "Quit")
"")
(make-after 'file-menu 'quit 'nothing)
(make-an-item 'edit-menu 'undo "Undo the most recent action" #f #\z "&Undo" "")
(make-an-item 'edit-menu 'redo "Redo the most recent undo" #f #\y "&Redo" "")
(make-between 'edit-menu 'redo 'cut 'nothing)
(make-an-item 'edit-menu 'cut "Cut the selection" #f #\x "Cu&t" "")
(make-an-item 'edit-menu 'undo "Undo the most recent action"
(edit-menu:do 'undo)
#\z "&Undo" "")
(make-an-item 'edit-menu 'redo "Redo the most recent undo"
(edit-menu:do 'redo)
#\y "&Redo" "")
(make-between 'edit-menu 'redo 'cut 'separator)
(make-an-item 'edit-menu 'cut "Cut the selection"
(edit-menu:do 'cut)
#\x "Cu&t" "")
(make-between 'edit-menu 'cut 'copy 'nothing)
(make-an-item 'edit-menu 'copy "Copy the selection" #f #\c "&Copy" "")
(make-an-item 'edit-menu 'copy "Copy the selection"
(edit-menu:do 'copy)
#\c "&Copy" "")
(make-between 'edit-menu 'copy 'paste 'nothing)
(make-an-item 'edit-menu 'paste "Paste the most recent copy or cut over the selection" #f #\v "&Paste" "")
(make-an-item 'edit-menu 'paste "Paste the most recent copy or cut over the selection"
(edit-menu:do 'paste)
#\v "&Paste" "")
(make-between 'edit-menu 'paste 'clear 'nothing)
(make-an-item 'edit-menu 'clear "Clear the selection without affecting paste" #f #f
(make-an-item 'edit-menu 'clear "Clear the selection without affecting paste"
(edit-menu:do 'clear)
#f
'(if (eq? (system-type) 'macos)
"Clear"
"&Delete")
"")
(make-between 'edit-menu 'clear 'select-all 'nothing)
(make-an-item 'edit-menu 'select-all "Select the entire document" #f #\a "Select A&ll" "")
(make-between 'edit-menu 'select-all 'find 'nothing)
(make-an-item 'edit-menu 'select-all "Select the entire document"
(edit-menu:do 'select-all)
#\a "Select A&ll" "")
(make-between 'edit-menu 'select-all 'find 'separator)
(make-an-item 'edit-menu 'find "Search for a string in the window" #f
#\f "Find" "")
(make-between 'edit-menu 'find 'preferences 'separator)

138
collects/framework/text.ss
View File

@ -38,6 +38,70 @@
[b3 (box 0)]
[b4 (box 0)]
[range-rectangles null]
[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 loop ([left #f]
[top #f]
[right #f]
[bottom #f]
[rectangles rectangles])
(cond
[(null? rectangles)
(when left
(invalidate-bitmap-cache left top (- right left) (- bottom top)))]
[else (let* ([r (car rectangles)]
[rleft (rectangle-left r)]
[rright (rectangle-right r)]
[rtop (rectangle-top r)]
[rbottom (rectangle-bottom r)]
[this-left (if (number? rleft)
rleft
min-left)]
[this-right (if (number? rright)
rright
max-right)]
[this-bottom rbottom]
[this-top rtop])
(if (and left top right bottom)
(loop (min this-left left)
(min this-top top)
(max this-right right)
(max this-bottom bottom)
(cdr rectangles))
(loop this-left
this-top
this-right
this-bottom
(cdr rectangles))))]))))]
[recompute-range-rectangles
(lambda ()
(let ([new-rectangles
@ -98,76 +162,11 @@
bottom-end-y
b/w-bitmap
color))]))))]
[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 loop ([left #f]
[top #f]
[right #f]
[bottom #f]
[rectangles rectangles])
(cond
[(null? rectangles)
(when left
(invalidate-bitmap-cache left top (- right left) (- bottom top)))]
[else (let* ([r (car rectangles)]
[rleft (rectangle-left r)]
[rright (rectangle-right r)]
[rtop (rectangle-top r)]
[rbottom (rectangle-bottom r)]
[this-left (if (number? rleft)
rleft
min-left)]
[this-right (if (number? rright)
rright
max-right)]
[this-bottom rbottom]
[this-top rtop])
(if (and left top right bottom)
(loop (min this-left left)
(min this-top top)
(max this-right right)
(max this-bottom bottom)
(cdr rectangles))
(loop this-left
this-top
this-right
this-bottom
(cdr rectangles))))]))))]
[old-rectangles range-rectangles])
(set! range-rectangles
(mzlib:function:foldl (lambda (x l) (append (new-rectangles x) l))
null ranges))
(invalidate-rectangles (append old-rectangles
range-rectangles))))]
null ranges))))]
[ranges null]
[pen (make-object pen% "BLACK" 0 'solid)]
[brush (make-object brush% "black" 'solid)])
@ -179,9 +178,12 @@
(unless (or (eq? priority 'high) (eq? priority 'low))
(error 'highlight-range "expected last argument to be either 'high or 'low, got: ~e"
priority))
(invalidate-rectangles range-rectangles)
(set! ranges (if (eq? priority 'high) (cons l ranges) (append ranges (list l))))
(recompute-range-rectangles)
(invalidate-rectangles range-rectangles)
(lambda ()
(invalidate-rectangles range-rectangles)
(set! ranges
(let loop ([r ranges])
(cond
@ -189,12 +191,14 @@
[else (if (eq? (car r) l)
(cdr r)
(cons (car r) (loop (cdr r))))])))
(recompute-range-rectangles))))])
(recompute-range-rectangles)
(invalidate-rectangles range-rectangles))))])
(rename [super-on-paint on-paint])
(override
[on-paint
(lambda (before dc left-margin top-margin right-margin bottom-margin dx dy draw-caret)
(super-on-paint before dc left-margin top-margin right-margin bottom-margin dx dy draw-caret)
(recompute-range-rectangles)
(for-each
(lambda (rectangle)
(let-values ([(view-x view-y view-width view-height)