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

added new preferences first cut

Browse Source 
original commit: 2e3ea2a1310978b7ade80ad64839e9929416313b
This commit is contained in:
Robby Findler 1996-06-19 22:01:02 +00:00
parent 62001f554c
commit a69d8d39c9
2 changed files with 355 additions and 350 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

29
collects/mred/edit.ss
View File

@ -5,8 +5,8 @@
[mred:scheme-paren mred:scheme-paren^] [mred:keymap mred:keymap^] [mred:scheme-paren mred:scheme-paren^] [mred:keymap mred:keymap^]
[mzlib:function mzlib:function^]) [mzlib:function mzlib:function^])
(define-struct range (start end pen brush)) (define-struct range (start end b/w-bitmap color))
(define-struct rectangle (left top width height pen brush)) (define-struct rectangle (left top width height b/w-bitmap color))
(define make-std-buffer% (define make-std-buffer%
(lambda (buffer%) (lambda (buffer%)
@ -267,9 +267,11 @@
(super-after-set-position))] (super-after-set-position))]
[ranges null] [ranges null]
;; the bitmap is used in b/w and the color is used in color.
[add-range [add-range
(lambda (start end pen brush) (lambda (start end bitmap color)
(let ([l (make-range start end pen brush)]) (let ([l (make-range start end bitmap color)])
(set! ranges (cons l ranges)) (set! ranges (cons l ranges))
(recompute-range-rectangles) (recompute-range-rectangles)
(lambda () (set! ranges (lambda () (set! ranges
@ -287,8 +289,8 @@
(lambda (range) (lambda (range)
(let ([start (range-start range)] (let ([start (range-start range)]
[end (range-end range)] [end (range-end range)]
[pen (range-pen range)] [b/w-bitmap (range-b/w-bitmap range)]
[brush (range-brush range)] [color (range-color range)]
[buffer-width (box 0)] [buffer-width (box 0)]
[start-x (box 0)] [start-x (box 0)]
[top-start-y (box 0)] [top-start-y (box 0)]
@ -307,24 +309,24 @@
(unbox top-start-y) (unbox top-start-y)
(- (unbox end-x) (unbox start-x)) (- (unbox end-x) (unbox start-x))
(- (unbox bottom-start-y) (unbox top-start-y)) (- (unbox bottom-start-y) (unbox top-start-y))
pen brush))] b/w-bitmap color))]
[else [else
(list (list
(make-rectangle (unbox start-x) (make-rectangle (unbox start-x)
(unbox top-start-y) (unbox top-start-y)
(- (unbox buffer-width) (unbox start-x)) (- (unbox buffer-width) (unbox start-x))
(- (unbox bottom-start-y) (unbox top-start-y)) (- (unbox bottom-start-y) (unbox top-start-y))
pen brush) b/w-bitmap color)
(make-rectangle 0 (make-rectangle 0
(unbox bottom-start-y) (unbox bottom-start-y)
(unbox buffer-width) (unbox buffer-width)
(- (unbox top-end-y) (unbox bottom-start-y)) (- (unbox top-end-y) (unbox bottom-start-y))
pen brush) b/w-bitmap color)
(make-rectangle 0 (make-rectangle 0
(unbox top-end-y) (unbox top-end-y)
(unbox end-x) (unbox end-x)
(- (unbox bottom-end-y) (unbox top-end-y)) (- (unbox bottom-end-y) (unbox top-end-y))
pen brush))])))] b/w-bitmap color))])))]
[invalidate-rectangle [invalidate-rectangle
(lambda (r) (lambda (r)
(invalidate-bitmap-cache (rectangle-left r) (invalidate-bitmap-cache (rectangle-left r)
@ -345,14 +347,17 @@
(super-on-paint before dc left top right bottom dx dy draw-caret) (super-on-paint before dc left top right bottom dx dy draw-caret)
(unless before (unless before
(for-each (lambda (rectangle) (for-each (lambda (rectangle)
(let ([pen (rectangle-pen rectangle)] (let ([pen (make-object wx:pen% "black" 1 wx:const-stipple)]
[brush (rectangle-brush rectangle)] [brush (make-object wx:brush% "black" wx:const-stipple)]
[old-pen (send dc get-pen)] [old-pen (send dc get-pen)]
[old-brush (send dc get-brush)] [old-brush (send dc get-brush)]
[b/w-bitmap (rectangle-b/w-bitmap rectangle)]
[left (rectangle-left rectangle)] [left (rectangle-left rectangle)]
[top (rectangle-top rectangle)] [top (rectangle-top rectangle)]
[width (rectangle-width rectangle)] [width (rectangle-width rectangle)]
[height (rectangle-height rectangle)]) [height (rectangle-height rectangle)])
(send pen set-stipple b/w-bitmap)
(send brush set-stipple b/w-bitmap)
(send dc set-pen pen) (send dc set-pen pen)
(send dc set-brush brush) (send dc set-brush brush)
(unless (or (zero? width) (unless (or (zero? width)

2
collects/mred/keys.ss
View File

@ -4,7 +4,7 @@
[mred:handler mred:handler^] [mred:find-string mred:find-string^] [mred:handler mred:handler^] [mred:find-string mred:find-string^]
[mred:scheme-paren mred:scheme-paren^]) [mred:scheme-paren mred:scheme-paren^])
(mred:debug:printf "mred:keymap@~n") (mred:debug:printf "mred:keymap@")
; This is a list of keys that are typed with the SHIFT key, but ; This is a list of keys that are typed with the SHIFT key, but
; are not normally thought of as shifted. It will have to be ; are not normally thought of as shifted. It will have to be