From 1a9d875296f6467836398bb712f745585d18673c Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Thu, 27 May 1999 22:37:03 +0000 Subject: [PATCH] ... original commit: fbd6c2e6b65df87bea47cdf8e586420e20b97f81 --- collects/framework/canvas.ss | 17 ++- collects/framework/frame.ss | 13 +- collects/framework/frameworks.ss | 5 +- collects/framework/gen-standard-menus.ss | 2 +- collects/framework/main.ss | 2 +- collects/framework/standard-menus-items.ss | 42 +++++-- collects/framework/text.ss | 138 +++++++++++---------- 7 files changed, 126 insertions(+), 93 deletions(-) diff --git a/collects/framework/canvas.ss b/collects/framework/canvas.ss index 9d587908..ef68a9ca 100644 --- a/collects/framework/canvas.ss +++ b/collects/framework/canvas.ss @@ -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%))) \ No newline at end of file + (define basic% (basic-mixin editor-canvas%)) + (define wide-snip% (wide-snip-mixin basic%))) \ No newline at end of file diff --git a/collects/framework/frame.ss b/collects/framework/frame.ss index 21245738..99af6e47 100644 --- a/collects/framework/frame.ss +++ b/collects/framework/frame.ss @@ -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 diff --git a/collects/framework/frameworks.ss b/collects/framework/frameworks.ss index 0f2d63a6..82352d52 100644 --- a/collects/framework/frameworks.ss +++ b/collects/framework/frameworks.ss @@ -140,7 +140,10 @@ (define-signature framework:canvas^ - (wide-snip-mixin + (basic-mixin + basic<%> + basic% + wide-snip-mixin wide-snip<%> wide-snip%)) diff --git a/collects/framework/gen-standard-menus.ss b/collects/framework/gen-standard-menus.ss index eaf6534e..7d259fa6 100755 --- a/collects/framework/gen-standard-menus.ss +++ b/collects/framework/gen-standard-menus.ss @@ -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) diff --git a/collects/framework/main.ss b/collects/framework/main.ss index 66ce6844..28b0686b 100644 --- a/collects/framework/main.ss +++ b/collects/framework/main.ss @@ -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 diff --git a/collects/framework/standard-menus-items.ss b/collects/framework/standard-menus-items.ss index 8ccc8bb9..b1ff5b3e 100644 --- a/collects/framework/standard-menus-items.ss +++ b/collects/framework/standard-menus-items.ss @@ -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) diff --git a/collects/framework/text.ss b/collects/framework/text.ss index 3d572c0f..8cbb5931 100644 --- a/collects/framework/text.ss +++ b/collects/framework/text.ss @@ -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)