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

..

Browse Source 
original commit: f0d369cbd78dee61867e195dc32ca38cad21e3e8
This commit is contained in:
Robby Findler 2002-08-18 22:02:14 +00:00
parent 112768080f
commit d84a9e2991
2 changed files with 41 additions and 27 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

18
collects/framework/gui-utils.ss
View File

@ -484,10 +484,12 @@
(min-width (floor (inexact->exact (get-total-width (get-dc))))))) (min-width (floor (inexact->exact (get-total-width (get-dc)))))))
;; selected-text-color : color ;; selected-text-color : color
(define selected-text-color (make-object color% "black")) (define selected-text-color (send the-color-database find-color "black"))
;; unselected-text-color : color ;; unselected-text-color : color
(define unselected-text-color (make-object color% "black")) (define unselected-text-color (case (system-type)
[(macosx) (make-object color% 75 75 75)]
[else (send the-color-database find-color "black")]))
;; selected-brush : brush ;; selected-brush : brush
(define selected-brush (send the-brush-list find-or-create-brush "WHITE" 'solid)) (define selected-brush (send the-brush-list find-or-create-brush "WHITE" 'solid))
@ -496,9 +498,15 @@
(define unselected-brush (send the-brush-list find-or-create-brush (get-panel-background) 'solid)) (define unselected-brush (send the-brush-list find-or-create-brush (get-panel-background) 'solid))
;; button-down/over-brush : brush ;; button-down/over-brush : brush
(define button-down/over-brush (send the-brush-list find-or-create-brush (define button-down/over-brush
(make-object color% 225 225 255) (case (system-type)
'solid)) [(macosx) (send the-brush-list find-or-create-brush
"light blue"
'solid)]
[else
(send the-brush-list find-or-create-brush
(make-object color% 225 225 255)
'solid)]))
;; label-font : font ;; label-font : font
(define label-font (send the-font-list find-or-create-font (define label-font (send the-font-list find-or-create-font

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

@ -858,28 +858,34 @@
#t)) #t))
(define box-comment-out-selection (define box-comment-out-selection
(opt-lambda ([start-pos (get-start-position)] (opt-lambda ([_start-pos 'start]
[end-pos (get-end-position)]) [_end-pos 'end])
(begin-edit-sequence) (let ([start-pos (if (eq? _start-pos 'start)
(split-snip start-pos) (get-start-position)
(split-snip end-pos) _start-pos)]
(let* ([cb (instantiate cb:comment-box-snip% ())] [end-pos (if (eq? _end-pos 'end)
[text (send cb get-editor)]) (get-end-position)
(send text set-style-list style-list) _end-pos)])
(let loop ([snip (find-snip start-pos 'after-or-none)]) (begin-edit-sequence)
(cond (split-snip start-pos)
[(not snip) (void)] (split-snip end-pos)
[((get-snip-position snip) . >= . end-pos) (void)] (let* ([cb (instantiate cb:comment-box-snip% ())]
[else [text (send cb get-editor)])
(send text insert (send snip copy) (send text set-style-list style-list)
(send text last-position) (let loop ([snip (find-snip start-pos 'after-or-none)])
(send text last-position)) (cond
(loop (send snip next))])) [(not snip) (void)]
(delete start-pos end-pos) [((get-snip-position snip) . >= . end-pos) (void)]
(insert cb start-pos) [else
(set-position start-pos start-pos)) (send text insert (send snip copy)
(end-edit-sequence) (send text last-position)
#t)) (send text last-position))
(loop (send snip next))]))
(delete start-pos end-pos)
(insert cb start-pos)
(set-position start-pos start-pos))
(end-edit-sequence)
#t)))
(define uncomment-selection (define uncomment-selection
(opt-lambda ([start-pos (get-start-position)] (opt-lambda ([start-pos (get-start-position)]