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

.

Browse Source 
original commit: f91b745769e8b6ec4038d442604e2b392b03dfa3
This commit is contained in:
Matthew Flatt 2004-07-26 13:42:36 +00:00
parent 6fe78d3e5e
commit 0b2eb4a829
3 changed files with 159 additions and 135 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

266
collects/mred/edit.ss
View File

@ -4,7 +4,8 @@
(module edit mzscheme (module edit mzscheme
(require (lib "class.ss") (require (lib "class.ss")
(lib "mred.ss" "mred")) (lib "mred.ss" "mred")
(lib "etc.ss"))
(provide new-text-frame (provide new-text-frame
new-pasteboard-frame new-pasteboard-frame
@ -13,143 +14,144 @@
(define (new-text-frame file) (new-frame text% file)) (define (new-text-frame file) (new-frame text% file))
(define (new-pasteboard-frame file) (new-frame pasteboard% file)) (define (new-pasteboard-frame file) (new-frame pasteboard% file))
(define (new-frame editor% file) (define new-frame
(define f (make-object (class frame% (opt-lambda (editor% file [editor-canvas% editor-canvas%])
(inherit modified) (define f (make-object (class frame%
(define/override (can-close?) (inherit modified)
(and (super can-close?) (define/augment (can-close?)
(or (not (modified)) (and (or (not (modified))
(let ([r (message-box/custom (let ([r (message-box/custom
"Editor Modified" "Editor Modified"
"The editor has been modified. Really close it?" "The editor has been modified. Really close it?"
"Close" "Close"
"Cancel" "Cancel"
"Save and Close" "Save and Close"
this this
'(default=2 disallow-close))]) '(default=2 disallow-close))])
(or (and (= r 3) (or (and (= r 3)
(send e save-file)) (send e save-file))
(= r 1)))))) (= r 1))))
(super-new)) (inner #t can-close?)))
"MrEdIt" #f 620 450)) (super-new))
(define c (make-object editor-canvas% f)) "MrEdIt" #f 620 450))
(define e (make-object (class editor% (define c (make-object editor-canvas% f))
(define/override (set-modified mod?) (define e (make-object (class editor%
(send f modified mod?) (define/override (set-modified mod?)
(super set-modified mod?)) (send f modified mod?)
(super-new)))) (super set-modified mod?))
(define mb (make-object menu-bar% f)) (super-new))))
(define mb (make-object menu-bar% f))
(define file-menu (make-object menu% "File" mb)) (define file-menu (make-object menu% "File" mb))
(define edit-menu (make-object menu% "Edit" mb)) (define edit-menu (make-object menu% "Edit" mb))
(define font-menu (make-object menu% "Font" mb)) (define font-menu (make-object menu% "Font" mb))
(define para-menu (make-object menu% "Paragraph" mb)) (define para-menu (make-object menu% "Paragraph" mb))
(make-object menu-item% "New Text Frame" file-menu (make-object menu-item% "New Text Frame" file-menu
(lambda (item event)
(new-text-frame #f))
#\N)
(make-object menu-item% "New Pasteboard Frame" file-menu
(lambda (item event)
(new-pasteboard-frame #f)))
(make-object menu-item% "Open..." file-menu
(lambda (item event)
(send e load-file ""))
#\O)
(make-object menu-item% "Save As..." file-menu
(lambda (item event)
(send e save-file ""))
#\S)
(when (eq? editor% text%)
(make-object menu-item% "Save As Text..." file-menu
(lambda (item event) (lambda (item event)
(send e save-file "" 'text)))) (new-text-frame #f))
(make-object separator-menu-item% file-menu) #\N)
(make-object menu-item% "Print..." file-menu (make-object menu-item% "New Pasteboard Frame" file-menu
(lambda (item event)
(send e print))
#\P)
(make-object separator-menu-item% file-menu)
(make-object menu-item% "Close" file-menu
(lambda (item event)
(when (send f can-close?)
(send f on-close)
(send f show #f)))
#\Q)
(append-editor-operation-menu-items edit-menu #f)
(when (eq? editor% text%)
(make-object separator-menu-item% edit-menu)
(make-object checkable-menu-item% "Wrap Lines" edit-menu
(lambda (item event) (lambda (item event)
(send e auto-wrap (send item is-checked?))))) (new-pasteboard-frame #f)))
(append-editor-font-menu-items font-menu) (make-object menu-item% "Open..." file-menu
(let ([m (make-object menu% "Smoothing" font-menu)]) (lambda (item event)
(let ([mk (lambda (name v) (send e load-file ""))
(make-object menu-item% name m #\O)
(lambda (i e) (make-object menu-item% "Save As..." file-menu
(let* ([o (send f get-edit-target-object)]) (lambda (item event)
(and o (send e save-file ""))
(o . is-a? . editor<%>) #\S)
(send o change-style (when (eq? editor% text%)
(make-object style-delta% 'change-smoothing v)))))))]) (make-object menu-item% "Save As Text..." file-menu
(mk "Default" 'default) (lambda (item event)
(mk "Partly Smoothed" 'partly-smoothed) (send e save-file "" 'text))))
(mk "Smoothed" 'smoothed) (make-object separator-menu-item% file-menu)
(mk "Not Smoothed" 'unsmoothed))) (make-object menu-item% "Print..." file-menu
(lambda (item event)
(send e print))
#\P)
(make-object separator-menu-item% file-menu)
(make-object menu-item% "Close" file-menu
(lambda (item event)
(when (send f can-close?)
(send f on-close)
(send f show #f)))
#\Q)
(make-object menu-item% "Set Margins..." para-menu (append-editor-operation-menu-items edit-menu #f)
(lambda (i ev) (when (eq? editor% text%)
(let* ([d (make-object dialog% "Margins" f)] (make-object separator-menu-item% edit-menu)
[mk-txt (lambda (label) (make-object (make-object checkable-menu-item% "Wrap Lines" edit-menu
text-field% (lambda (item event)
label (send e auto-wrap (send item is-checked?)))))
d
void
"0.0"))]
[first-left (mk-txt "First Left")]
[rest-left (mk-txt "Rest Left")]
[right (mk-txt "Right")]
[button-panel (new horizontal-pane%
[parent d]
[alignment '(right center)])]
[ok (make-object button% "Ok" button-panel
(lambda (b ev)
(let* ([get (lambda (field)
(let ([n (string->number (send field get-value))])
(and n (real? n) (not (negative? n)) n)))]
[first-left (get first-left)]
[rest-left (get rest-left)]
[right (get right)])
(if (and first-left
rest-left
right)
(let ([start (send e position-paragraph
(send e get-start-position))]
[end (send e position-paragraph
(send e get-end-position))])
(let loop ([i start])
(unless (i . > . end)
(send e set-paragraph-margins
i first-left rest-left right)
(loop (add1 i)))
(send d show #f)))
(bell))))
'(border))]
[cancel (make-object button% "Cancel" button-panel
(lambda (b e)
(send d show #f)))])
(send d show #t))))
((current-text-keymap-initializer) (send e get-keymap)) (append-editor-font-menu-items font-menu)
(send c set-editor e) (let ([m (make-object menu% "Smoothing" font-menu)])
(let ([mk (lambda (name v)
(make-object menu-item% name m
(lambda (i e)
(let* ([o (send f get-edit-target-object)])
(and o
(o . is-a? . editor<%>)
(send o change-style
(make-object style-delta% 'change-smoothing v)))))))])
(mk "Default" 'default)
(mk "Partly Smoothed" 'partly-smoothed)
(mk "Smoothed" 'smoothed)
(mk "Not Smoothed" 'unsmoothed)))
(when file (make-object menu-item% "Set Margins..." para-menu
(if (regexp-match "[.](gif|bmp|jpe?g|xbm|xpm|png)$" file) (lambda (i ev)
(send e insert (make-object image-snip% file)) (let* ([d (make-object dialog% "Margins" f)]
(send e load-file file))) [mk-txt (lambda (label) (make-object
text-field%
label
d
void
"0.0"))]
[first-left (mk-txt "First Left")]
[rest-left (mk-txt "Rest Left")]
[right (mk-txt "Right")]
[button-panel (new horizontal-pane%
[parent d]
[alignment '(right center)])]
[ok (make-object button% "Ok" button-panel
(lambda (b ev)
(let* ([get (lambda (field)
(let ([n (string->number (send field get-value))])
(and n (real? n) (not (negative? n)) n)))]
[first-left (get first-left)]
[rest-left (get rest-left)]
[right (get right)])
(if (and first-left
rest-left
right)
(let ([start (send e position-paragraph
(send e get-start-position))]
[end (send e position-paragraph
(send e get-end-position))])
(let loop ([i start])
(unless (i . > . end)
(send e set-paragraph-margins
i first-left rest-left right)
(loop (add1 i)))
(send d show #f)))
(bell))))
'(border))]
[cancel (make-object button% "Cancel" button-panel
(lambda (b e)
(send d show #f)))])
(send d show #t))))
(send f show #t) ((current-text-keymap-initializer) (send e get-keymap))
f)) (send c set-editor e)
(when file
(if (regexp-match "[.](gif|bmp|jpe?g|xbm|xpm|png)$" file)
(send e insert (make-object image-snip% file))
(send e load-file file)))
(send f show #t)
f)))

24
collects/mred/mred.ss
View File

@ -4831,7 +4831,8 @@
(interface (subwindow<%>) (interface (subwindow<%>)
min-client-width min-client-height min-client-width min-client-height
on-char on-event on-paint on-scroll on-tab-in on-char on-event on-paint on-scroll on-tab-in
warp-pointer get-dc)) warp-pointer get-dc
set-canvas-background get-canvas-background))
(define-keywords canvas%-keywords (define-keywords canvas%-keywords
window%-keywords window%-keywords
@ -4852,7 +4853,24 @@
[warp-pointer (entry-point (lambda (x y) (send wx warp-pointer x y)))] [warp-pointer (entry-point (lambda (x y) (send wx warp-pointer x y)))]
[get-dc (entry-point (lambda () (send wx get-dc)))]) [get-dc (entry-point (lambda () (send wx get-dc)))]
[set-canvas-background
(entry-point
(lambda (c)
(unless (c . is-a? . wx:color%)
(raise-type-error (who->name '(method canvas<%> set-canvas-background))
"color% object"
c))
(unless (send wx get-canvas-background)
(raise-mismatch-error (who->name '(method canvas<%> set-canvas-background))
"cannot set a transparent canvas's background color: "
c))
(send wx set-canvas-background c)))]
[get-canvas-background
(entry-point
(lambda ()
(send wx get-canvas-background)))])
(private-field (private-field
[wx #f]) [wx #f])
(sequence (sequence
@ -4977,7 +4995,7 @@
(let ([cwho '(constructor editor-canvas)]) (let ([cwho '(constructor editor-canvas)])
(check-container-parent cwho parent) (check-container-parent cwho parent)
(check-instance cwho internal-editor<%> "text% or pasteboard%" #t editor) (check-instance cwho internal-editor<%> "text% or pasteboard%" #t editor)
(check-style cwho #f '(hide-vscroll hide-hscroll no-vscroll no-hscroll deleted control-border) style) (check-style cwho #f '(hide-vscroll hide-hscroll no-vscroll no-hscroll deleted control-border transparent) style)
(check-gauge-integer cwho scrolls-per-page) (check-gauge-integer cwho scrolls-per-page)
(check-label-string/false cwho label) (check-label-string/false cwho label)
(unless (eq? wheel-step no-val) (unless (eq? wheel-step no-val)

4
collects/mred/private/kernel.ss
View File

@ -342,6 +342,8 @@
on-size on-size
on-set-focus on-set-focus
on-kill-focus on-kill-focus
get-canvas-background
set-canvas-background
set-background-to-gray set-background-to-gray
on-scroll on-scroll
set-scroll-page set-scroll-page
@ -647,6 +649,8 @@
on-kill-focus on-kill-focus
popup-for-editor popup-for-editor
call-as-primary-owner call-as-primary-owner
get-canvas-background
set-canvas-background
set-y-margin set-y-margin
set-x-margin set-x-margin
get-y-margin get-y-margin