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

..

Browse Source 
original commit: 6e4991499292e5cc97d0dbd163db8603ac64827b
This commit is contained in:
Robby Findler 2003-01-23 14:35:36 +00:00
parent 4391b1ebc5
commit 00f6f3ed97
3 changed files with 61 additions and 10 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

15
collects/framework/private/main.ss
View File

@ -19,7 +19,20 @@
(application-preferences-handler (lambda () (preferences:show-dialog)))
;; preferences
(preferences:set-default 'framework:paren-match-color
(let ([gray-level
;; old gray-level 192
(if (eq? (system-type) 'windows)
(* 3/4 256)
(- (* 7/8 256) 1))])
(make-object color% gray-level gray-level gray-level))
(lambda (x) (is-a? x color%)))
(preferences:set-un/marshall
'framework:paren-match-color
(lambda (c) (list (send c red) (send c green) (send c blue)))
(lambda (l) (make-object color% (car l) (cadr l) (caddr l))))
(preferences:set-default 'framework:last-directory (find-system-path 'home-dir) string?)
(preferences:set-default 'framework:recent-max-count
50

46
collects/framework/private/preferences.ss
View File

@ -582,9 +582,53 @@
'framework:paren-match
(string-constant flash-paren-match)
values values)
(scheme-panel-procs scheme-panel))))])
(scheme-panel-procs scheme-panel)
(make-highlight-color-choice scheme-panel))))])
(add-scheme-checkbox-panel)))
(define (make-highlight-color-choice panel)
(let* ([hp (instantiate horizontal-panel% ()
(parent panel)
(stretchable-height #f))]
[msg (make-object message% (string-constant paren-match-color) hp)]
[scheme-higlight-canvas (make-object scheme-highlight-canvas% hp)]
[button (make-object button%
(string-constant choose-color)
hp
(lambda (x y) (change-highlight-color panel)))])
(void)))
(define scheme-highlight-canvas%
(class canvas%
(inherit get-client-size get-dc)
(define/override (on-paint)
(let ([dc (get-dc)])
(send dc set-pen (send the-pen-list find-or-create-pen
(get 'framework:paren-match-color)
1
'solid))
(send dc set-brush (send the-brush-list find-or-create-brush
(get 'framework:paren-match-color)
'solid))
(let-values ([(w h) (get-client-size)])
(send dc draw-rectangle 0 0 w h))))
(super-instantiate ())
(inherit stretchable-width min-width)
(stretchable-width #f)
(min-width 30)
(add-callback
'framework:paren-match-color
(lambda (p v)
(on-paint)))))
(define (change-highlight-color parent)
(let ([new-color
(get-color-from-user (string-constant choose-paren-highlight-color)
(send parent get-top-level-window)
(get 'framework:paren-match-color))])
(when new-color
(set 'framework:paren-match-color new-color))))
(define (add-editor-checkbox-panel)
(letrec ([add-editor-checkbox-panel
(lambda ()

10
collects/framework/private/scheme.ss
View File

@ -315,13 +315,7 @@
(send style-list find-named-style "Basic")
delta))))
(define match-color
(let ([gray-level
;; old gray-level 192
(if (eq? (system-type) 'windows)
(* 3/4 256)
(- (* 7/8 256) 1))])
(make-object color% gray-level gray-level gray-level)))
(define (get-match-color) (preferences:get 'framework:paren-match-color))
(define mismatch-color (make-object color% "PINK"))
(define matching-parenthesis-style
@ -556,7 +550,7 @@
[off (highlight-range
left
right
(if error? mismatch-color match-color)
(if error? mismatch-color (get-match-color))
(and (send (icon:get-paren-highlight-bitmap) ok?)
(icon:get-paren-highlight-bitmap))
(= there here left))])