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

added paren highlighting and fixed drscheme/quit bug

Browse Source 
original commit: c157ca5bc72bd94fa0c9df123805d0294662a941
This commit is contained in:
Robby Findler 1996-06-14 16:41:56 +00:00
parent f2798942a9
commit ace788472e
2 changed files with 251 additions and 188 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

161
collects/mred/edit.ss
View File

@ -1,11 +1,9 @@
(define-sigfunctor (mred:edit@ mred:edit^) (define-sigfunctor (mred:edit@ mred:edit^)
(import mred:debug^ mred:finder^ mred:path-utils^ mred:mode^ mred:scheme-paren^ (import mred:debug^ mred:finder^ mred:path-utils^ mred:mode^
mred:keymap^ mzlib:function^) mred:scheme-paren^ mred:keymap^ mzlib:function^)
(define first car) (define-struct range (start end pen brush))
(define second cadr) (define-struct rectangle (left top width height pen brush))
(define third caddr)
(define fourth cadddr)
(define make-std-buffer% (define make-std-buffer%
(lambda (buffer%) (lambda (buffer%)
@ -163,18 +161,29 @@
(lambda (super%) (lambda (super%)
(class (make-std-buffer% super%) args (class (make-std-buffer% super%) args
(inherit mode canvases (inherit mode canvases
invalidate-bitmap-cache
begin-edit-sequence end-edit-sequence
flash-on get-keymap get-start-position flash-on get-keymap get-start-position
on-default-char on-default-event on-default-char on-default-event
set-file-format get-style-list) set-file-format get-style-list)
(rename [super-on-focus on-focus] (rename [super-on-focus on-focus]
[super-on-paint on-paint] [super-on-paint on-paint]
[super-after-set-position after-set-position]
[super-on-local-event on-local-event] [super-on-local-event on-local-event]
[super-on-local-char on-local-char] [super-on-local-char on-local-char]
[super-after-set-position after-set-position]
[super-on-edit-sequence on-edit-sequence]
[super-on-change-style on-change-style]
[super-on-insert on-insert] [super-on-insert on-insert]
[super-on-delete on-delete] [super-on-delete on-delete]
[super-on-set-size-constraint on-set-size-constraint]
[super-after-edit-sequence after-edit-sequence]
[super-after-change-style after-change-style]
[super-after-insert after-insert] [super-after-insert after-insert]
[super-after-delete after-delete]) [super-after-delete after-delete]
[super-after-set-size-constraint after-set-size-constraint])
(public (public
[set-mode [set-mode
(lambda (m) (lambda (m)
@ -211,6 +220,19 @@
(lambda (start len) (lambda (start len)
(if (or (not mode) (send mode on-delete this start len)) (if (or (not mode) (send mode on-delete this start len))
(super-on-delete start len)))] (super-on-delete start len)))]
[on-change-style
(lambda (start len)
(if (or (not mode) (send mode on-change-style this start len))
(super-on-change-style start len)))]
[on-edit-sequence
(lambda ()
(when mode
(send mode on-edit-sequence this))
(super-on-edit-sequence))]
[on-set-size-constraint
(lambda ()
(if (or (not mode) (send mode on-set-size-constraint this))
(super-on-set-size-constraint)))]
[after-insert [after-insert
(lambda (start len) (lambda (start len)
@ -220,6 +242,20 @@
(lambda (start len) (lambda (start len)
(if mode (send mode after-delete this start len)) (if mode (send mode after-delete this start len))
(super-after-delete start len))] (super-after-delete start len))]
[after-change-style
(lambda (start len)
(when mode (send mode after-change-style this start len))
(super-after-change-style start len))]
[after-edit-sequence
(lambda ()
(when mode
(send mode after-edit-sequence this))
(super-after-edit-sequence))]
[after-set-size-constraint
(lambda ()
(when mode
(send mode after-set-size-constraint this))
(super-after-set-size-constraint))]
[after-set-position [after-set-position
(lambda () (lambda ()
@ -227,74 +263,101 @@
(send mode after-set-position this)) (send mode after-set-position this))
(super-after-set-position))] (super-after-set-position))]
[ranges (list (list 4 24 '... '...))] [ranges null]
[add-range [add-range
(lambda (start end b/w-pattern color-pattern) (lambda (start end pen brush)
(let ([l (list start end b/w-pattern color-pattern)]) (let ([l (make-range start end pen brush)])
(set! ranges (cons l ranges)) (set! ranges (cons l ranges))
(recompute-range-rectangles)
(lambda () (set! ranges (lambda () (set! ranges
(let loop ([r ranges]) (let loop ([r ranges])
(cond (cond
[(null? r) r] [(null? r) r]
[else (if (eq? (car r) l) [else (if (eq? (car r) l)
(cdr r) (cdr r)
(cons (car r) (loop (cdr r))))]))))))] (cons (car r) (loop (cdr r))))])))
(recompute-range-rectangles))))]
[range-rectangles null] [range-rectangles null]
[recompute-range-rectangles [recompute-range-rectangles
(lambda () (lambda ()
(let ([new-rectangles (let ([new-rectangles
(lambda (start end b/w color) (lambda (range)
(let ([left 0] (let ([start (range-start range)]
[right 1000] [end (range-end range)]
[top-start-x (box 0)] [pen (range-pen range)]
[brush (range-brush range)]
[buffer-width (box 0)]
[start-x (box 0)]
[top-start-y (box 0)] [top-start-y (box 0)]
[bottom-start-x (box 0)]
[bottom-start-y (box 0)] [bottom-start-y (box 0)]
[top-end-x (box 0)] [end-x (box 0)]
[top-end-y (box 0)] [top-end-y (box 0)]
[bottom-end-x (box 0)]
[bottom-end-y (box 0)]) [bottom-end-y (box 0)])
(send this position-location start top-start-x top-start-y #t #f #t) (send this get-extent buffer-width null)
(send this position-location end top-end-x top-end-y #t #t #t) (send this position-location start start-x top-start-y #t #f #t)
(send this position-location start bottom-start-x bottom-start-y #f #f #t) (send this position-location end end-x top-end-y #t #t #t)
(send this position-location end bottom-end-x bottom-end-y #f #t #t) (send this position-location start start-x bottom-start-y #f #f #t)
(send this position-location end end-x bottom-end-y #f #t #t)
(cond (cond
[(= (unbox top-start-y) (unbox top-end-y)) [(= (unbox top-start-y) (unbox top-end-y))
(list (list (unbox top-start-x) (unbox top-start-y) (list (make-rectangle (unbox start-x)
(- (unbox bottom-end-x) (unbox top-start-x)) (unbox top-start-y)
(- (unbox bottom-end-y) (unbox top-start-y))))] (- (unbox end-x) (unbox start-x))
(- (unbox bottom-start-y) (unbox top-start-y))
pen brush))]
[else [else
(list (list (unbox top-start-x) (unbox top-start-y) (list
(- right (unbox top-start-x)) (make-rectangle (unbox start-x)
(- (unbox bottom-start-y) (unbox top-start-y))) (unbox top-start-y)
(list (unbox bottom-start-x) left (- (unbox buffer-width) (unbox start-x))
(- right left) (- (unbox bottom-start-x) (unbox top-end-x))) (- (unbox bottom-start-y) (unbox top-start-y))
(list left (unbox top-end-y) pen brush)
(- (unbox top-end-x) left) (make-rectangle 0
(- (unbox bottom-end-y) (unbox top-end-y))))])))]) (unbox bottom-start-y)
(set! range-rectangles (map (lambda (x) (apply new-rectangles x)) ranges)) (unbox buffer-width)
(printf "~a~n" range-rectangles)))] (- (unbox top-end-y) (unbox bottom-start-y))
pen brush)
(make-rectangle 0
(unbox top-end-y)
(unbox end-x)
(- (unbox bottom-end-y) (unbox top-end-y))
pen brush))])))]
[invalidate-rectangle
(lambda (r)
(invalidate-bitmap-cache (rectangle-left r)
(rectangle-top r)
(rectangle-width r)
(rectangle-height r)))]
[old-rectangles range-rectangles])
(set! range-rectangles
(mzlib:function^:foldl (lambda (x l) (append (new-rectangles x) l))
null ranges))
(begin-edit-sequence)
(for-each invalidate-rectangle old-rectangles)
(for-each invalidate-rectangle range-rectangles)
(end-edit-sequence)))]
[on-paint [on-paint
(lambda (before dc left top right bottom dx dy draw-caret) (lambda (before dc left top right bottom dx dy draw-caret)
(when #f (super-on-paint before dc left top right bottom dx dy draw-caret)
(for-each (lambda (rlist) (unless before
(for-each (lambda (rectangle) (for-each (lambda (rectangle)
(let ([pen (make-object wx:pen% "black" 1 1)] (let ([pen (rectangle-pen rectangle)]
[brush (make-object wx:brush% "black" wx:const-transparent)] [brush (rectangle-brush rectangle)]
[old-pen (send dc get-pen)] [old-pen (send dc get-pen)]
[old-brush (send dc get-brush)]) [old-brush (send dc get-brush)]
[left (rectangle-left rectangle)]
[top (rectangle-top rectangle)]
[width (rectangle-width rectangle)]
[height (rectangle-height rectangle)])
(send dc set-pen pen) (send dc set-pen pen)
(send dc set-brush brush) (send dc set-brush brush)
(send dc draw-rectangle (unless (or (zero? width)
(+ (first rectangle) dx) (zero? height))
(+ (second rectangle) dy) (send dc draw-rectangle (+ left dx) (+ top dy) width height))
(+ (third rectangle) dx)
(+ (fourth rectangle) dy))
(send dc set-pen old-pen) (send dc set-pen old-pen)
(send dc set-brush old-brush))) (send dc set-brush old-brush)))
rlist)) range-rectangles)))])
range-rectangles))
(super-on-paint before dc left top right bottom dx dy draw-caret))])
(sequence (sequence
(apply super-init args) (apply super-init args)
(send edits add this) (send edits add this)

12
collects/mred/finder.ss
View File

@ -347,10 +347,10 @@
[filter-msg "That name does not have the right form"]) [filter-msg "That name does not have the right form"])
(let* ([directory (if (and (null? directory) (let* ([directory (if (and (null? directory)
(string? name)) (string? name))
(mzlib:file^:path-only name) (or (mzlib:file^:path-only name) null)
directory)] directory)]
[name (if (string? name) [name (or (and (string? name)
(mzlib:file^:file-name-from-path name) (mzlib:file^:file-name-from-path name))
name)] name)]
[v (box #f)]) [v (box #f)])
(make-object finder-dialog% #t replace? #f v (make-object finder-dialog% #t replace? #f v
@ -382,8 +382,8 @@
(string? name)) (string? name))
(or (mzlib:file^:path-only name) null) (or (mzlib:file^:path-only name) null)
directory)] directory)]
[name (if (string? name) [name (or (and (string? name)
(mzlib:file^:file-name-from-path name) (mzlib:file^:file-name-from-path name))
name)] name)]
[f (wx:file-selector prompt directory name [f (wx:file-selector prompt directory name
'() '()
@ -402,7 +402,7 @@
[(not (and (string? dir) (directory-exists? dir))) [(not (and (string? dir) (directory-exists? dir)))
(wx:message-box "Error" "That directory does not exist.") (wx:message-box "Error" "That directory does not exist.")
#f] #f]
[(equal? name "") [(or (not name) (equal? name ""))
(wx:message-box "Error" "Empty filename.") (wx:message-box "Error" "Empty filename.")
#f] #f]
[else f])))))) [else f]))))))