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^]
[mzlib:function mzlib:function^])
(define-struct range (start end pen brush))
(define-struct rectangle (left top width height pen brush))
(define-struct range (start end b/w-bitmap color))
(define-struct rectangle (left top width height b/w-bitmap color))
(define make-std-buffer%
(lambda (buffer%)
@ -267,9 +267,11 @@
(super-after-set-position))]
[ranges null]
;; the bitmap is used in b/w and the color is used in color.
[add-range
(lambda (start end pen brush)
(let ([l (make-range start end pen brush)])
(lambda (start end bitmap color)
(let ([l (make-range start end bitmap color)])
(set! ranges (cons l ranges))
(recompute-range-rectangles)
(lambda () (set! ranges
@ -287,8 +289,8 @@
(lambda (range)
(let ([start (range-start range)]
[end (range-end range)]
[pen (range-pen range)]
[brush (range-brush range)]
[b/w-bitmap (range-b/w-bitmap range)]
[color (range-color range)]
[buffer-width (box 0)]
[start-x (box 0)]
[top-start-y (box 0)]
@ -307,24 +309,24 @@
(unbox top-start-y)
(- (unbox end-x) (unbox start-x))
(- (unbox bottom-start-y) (unbox top-start-y))
pen brush))]
b/w-bitmap color))]
[else
(list
(make-rectangle (unbox start-x)
(unbox top-start-y)
(- (unbox buffer-width) (unbox start-x))
(- (unbox bottom-start-y) (unbox top-start-y))
pen brush)
b/w-bitmap color)
(make-rectangle 0
(unbox bottom-start-y)
(unbox buffer-width)
(- (unbox top-end-y) (unbox bottom-start-y))
pen brush)
b/w-bitmap color)
(make-rectangle 0
(unbox top-end-y)
(unbox end-x)
(- (unbox bottom-end-y) (unbox top-end-y))
pen brush))])))]
b/w-bitmap color))])))]
[invalidate-rectangle
(lambda (r)
(invalidate-bitmap-cache (rectangle-left r)
@ -345,14 +347,17 @@
(super-on-paint before dc left top right bottom dx dy draw-caret)
(unless before
(for-each (lambda (rectangle)
(let ([pen (rectangle-pen rectangle)]
[brush (rectangle-brush rectangle)]
(let ([pen (make-object wx:pen% "black" 1 wx:const-stipple)]
[brush (make-object wx:brush% "black" wx:const-stipple)]
[old-pen (send dc get-pen)]
[old-brush (send dc get-brush)]
[b/w-bitmap (rectangle-b/w-bitmap rectangle)]
[left (rectangle-left rectangle)]
[top (rectangle-top rectangle)]
[width (rectangle-width 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-brush brush)
(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: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
; are not normally thought of as shifted. It will have to be