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

This commit was manufactured by cvs2git to create branch 'countdown'.

Browse Source 
Sprout from master 1997-10-15 16:43:43 UTC Robby Findler <robby@racket-lang.org> 'Initial revision'
Cherrypick from master 1997-10-15 16:52:54 UTC Robby Findler <robby@racket-lang.org> 'Initial revision':
    collects/countdwn/README
Delete:
    collects/backward/sparamr.ss
    collects/backward/sparams.ss
    collects/cogen/ariesr.ss
    collects/cogen/ariess.ss
    collects/drscheme-jr/drscheme-jr.el
    collects/drscheme-jr/drscheme-jr.elc
    collects/drscheme-jr/drscheme-jr.ss
    collects/drscheme-jr/openbugs
    collects/drscheme/app.ss
    collects/drscheme/basis.ss
    collects/drscheme/cunit.ss
    collects/drscheme/donkstub.ss
    collects/drscheme/drsig.ss
    collects/drscheme/edit.ss
    collects/drscheme/export.ss
    collects/drscheme/face.ss
    collects/drscheme/frame.ss
    collects/drscheme/history
    collects/drscheme/icons.ss
    collects/drscheme/info.ss
    collects/drscheme/init.ss
    collects/drscheme/intrface.ss
    collects/drscheme/language.ss
    collects/drscheme/link.ss
    collects/drscheme/main.ss
    collects/drscheme/openbugs
    collects/drscheme/params.ss
    collects/drscheme/phooks.ss
    collects/drscheme/prefs.ss
    collects/drscheme/prog.ss
    collects/drscheme/rep.ss
    collects/drscheme/setup.ss
    collects/drscheme/sig.ss
    collects/drscheme/snip.ss
    collects/drscheme/spidstub.ss
    collects/drscheme/tool.ss
    collects/drscheme/tools/analysis/unit.ss
    collects/drscheme/tools/debug/unit.ss
    collects/drscheme/tools/syncheck/unit.ss
    collects/drscheme/toy.ss
    collects/drscheme/unit.ss
    collects/drscheme/zlink.ss
    collects/drscheme/zodiac.ss
    collects/graphics/TREADME
    collects/graphics/graphic.ss
    collects/graphics/graphicr.ss
    collects/graphics/graphics.ss
    collects/graphics/graphicu.ss
    collects/graphics/turex.ss
    collects/graphics/turtle.ss
    collects/graphics/turtler.ss
    collects/graphics/turtles.ss
    collects/graphics/turtlmr.ss
    collects/gusrspce/gusrspcr.ss
    collects/gusrspce/gusrspcs.ss
    collects/hierarchy/classr.ss
    collects/hierarchy/hierr.ss
    collects/hierarchy/m3r.ss
    collects/hierarchy/unitr.ss
    collects/hierlist/doc.txt
    collects/hierlist/hierlist.ss
    collects/hierlist/hierlistr.ss
    collects/hierlist/hierlists.ss
    collects/mred/autoload.ss
    collects/mred/autosave.ss
    collects/mred/canvas.ss
    collects/mred/connect.ss
    collects/mred/console.ss
    collects/mred/constant.ss
    collects/mred/containr.ss
    collects/mred/contfram.ss
    collects/mred/contkids.ss
    collects/mred/contpanl.ss
    collects/mred/cparens.ss
    collects/mred/cppmode.ss
    collects/mred/edframe.ss
    collects/mred/edit.ss
    collects/mred/exit.ss
    collects/mred/exn.ss
    collects/mred/fileutil.ss
    collects/mred/finder.ss
    collects/mred/findstr.ss
    collects/mred/frame.ss
    collects/mred/graph.ss
    collects/mred/group.ss
    collects/mred/guiutils.ss
    collects/mred/html.ss
    collects/mred/hyper.ss
    collects/mred/hypersig.ss
    collects/mred/hyprdial.ss
    collects/mred/hypredit.ss
    collects/mred/hyprfram.ss
    collects/mred/icon.ss
    collects/mred/keys.ss
    collects/mred/link.ss
    collects/mred/mcache.ss
    collects/mred/menu.ss
    collects/mred/mode.ss
    collects/mred/panel.ss
    collects/mred/paren.ss
    collects/mred/prefs.ss
    collects/mred/project.ss
    collects/mred/sig.ss
    collects/mred/sparen.ss
    collects/mred/ssmode.ss
    collects/mred/stdrs.ss
    collects/mred/stlink.ss
    collects/mred/stprims.ss
    collects/mred/strun.ss
    collects/mred/stsigs.ss
    collects/mred/testable.ss
    collects/mred/url.ss
    collects/mred/version.ss
    collects/mred/wxr.ss
    collects/mred/wxs.ss
    collects/mzlib/awk.ss
    collects/mzlib/awkc.ss
    collects/mzlib/compat.ss
    collects/mzlib/compatc.ss
    collects/mzlib/compatr.ss
    collects/mzlib/compats.ss
    collects/mzlib/compatu.ss
    collects/mzlib/compile.ss
    collects/mzlib/compilec.ss
    collects/mzlib/compiler.ss
    collects/mzlib/compiles.ss
    collects/mzlib/compileu.ss
    collects/mzlib/constan.ss
    collects/mzlib/constanc.ss
    collects/mzlib/constant.ss
    collects/mzlib/core.ss
    collects/mzlib/corec.ss
    collects/mzlib/corer.ss
    collects/mzlib/cores.ss
    collects/mzlib/coreu.ss
    collects/mzlib/date.ss
    collects/mzlib/datec.ss
    collects/mzlib/dater.ss
    collects/mzlib/dates.ss
    collects/mzlib/dateu.ss
    collects/mzlib/defstru.ss
    collects/mzlib/defstruc.ss
    collects/mzlib/file.ss
    collects/mzlib/filec.ss
    collects/mzlib/filer.ss
    collects/mzlib/files.ss
    collects/mzlib/fileu.ss
    collects/mzlib/functio.ss
    collects/mzlib/functioc.ss
    collects/mzlib/function.ss
    collects/mzlib/functior.ss
    collects/mzlib/functios.ss
    collects/mzlib/functiou.ss
    collects/mzlib/inflate.ss
    collects/mzlib/inflatec.ss
    collects/mzlib/inflater.ss
    collects/mzlib/inflates.ss
    collects/mzlib/inflateu.ss
    collects/mzlib/letplsrc.ss
    collects/mzlib/letplus.ss
    collects/mzlib/macro.ss
    collects/mzlib/macroc.ss
    collects/mzlib/macrox.ss
    collects/mzlib/match.ss
    collects/mzlib/matchc.ss
    collects/mzlib/mzlib.ss
    collects/mzlib/mzlibc.ss
    collects/mzlib/mzlibr.ss
    collects/mzlib/mzlibs.ss
    collects/mzlib/mzlibu.ss
    collects/mzlib/pconver.ss
    collects/mzlib/pconverc.ss
    collects/mzlib/pconverr.ss
    collects/mzlib/pconvers.ss
    collects/mzlib/pconvert.ss
    collects/mzlib/pconveru.ss
    collects/mzlib/pretty.ss
    collects/mzlib/prettyc.ss
    collects/mzlib/prettyr.ss
    collects/mzlib/prettys.ss
    collects/mzlib/prettyu.ss
    collects/mzlib/refer.ss
    collects/mzlib/referc.ss
    collects/mzlib/referf.ss
    collects/mzlib/sfunctor.ss
    collects/mzlib/shared.ss
    collects/mzlib/sharedc.ss
    collects/mzlib/spidey.ss
    collects/mzlib/spideyc.ss
    collects/mzlib/string.ss
    collects/mzlib/stringc.ss
    collects/mzlib/stringr.ss
    collects/mzlib/strings.ss
    collects/mzlib/stringu.ss
    collects/mzlib/synrule.ss
    collects/mzlib/synrulec.ss
    collects/mzlib/thread.ss
    collects/mzlib/threadc.ss
    collects/mzlib/threadr.ss
    collects/mzlib/threads.ss
    collects/mzlib/threadu.ss
    collects/mzlib/trace.ss
    collects/mzlib/tracec.ss
    collects/mzlib/trigger.ss
    collects/mzlib/triggerc.ss
    collects/mzlib/triggerr.ss
    collects/mzlib/triggers.ss
    collects/mzlib/triggeru.ss
    collects/mzlib/unitsig.ss
    collects/mzlib/unitsigc.ss
    collects/mzlib/zmath.ss
    collects/mzlib/zmathc.ss
    collects/mzlib/zmathr.ss
    collects/mzlib/zmaths.ss
    collects/mzlib/zmathu.ss
    collects/net/cgi.ss
    collects/net/cgir.ss
    collects/net/cgis.ss
    collects/net/cgiu.ss
    collects/net/nntp.sd
    collects/net/nntp.ss
    collects/net/nntpr.ss
    collects/net/nntps.ss
    collects/net/nntpu.ss
    collects/system/app.ss
    collects/system/compsys.ss
    collects/system/debug.ss
    collects/system/history
    collects/system/info.ss
    collects/system/invoke.ss
    collects/system/noconsle.ss
    collects/system/nuapp.ss
    collects/system/openbugs
    collects/system/splash.ss
    collects/system/system.ss
    collects/system/timesys.ss
    collects/tests/mred/sixlib.ss
    collects/userspce/paramr.ss
    collects/userspce/ricedef.ss
    collects/userspce/ricedefr.ss
    collects/userspce/ricedefs.ss
    collects/userspce/userspcr.ss
    collects/userspce/userspcs.ss
    collects/zodiac/back.ss
    collects/zodiac/basestr.ss
    collects/zodiac/corelate.ss
    collects/zodiac/invoke.ss
    collects/zodiac/link.ss
    collects/zodiac/load.ss
    collects/zodiac/make.ss
    collects/zodiac/misc.ss
    collects/zodiac/namedarg.ss
    collects/zodiac/pattern.ss
    collects/zodiac/qq.ss
    collects/zodiac/quasi.ss
    collects/zodiac/reader.ss
    collects/zodiac/readstr.ss
    collects/zodiac/scanner.ss
    collects/zodiac/scanparm.ss
    collects/zodiac/scanstr.ss
    collects/zodiac/scm-core.ss
    collects/zodiac/scm-hanc.ss
    collects/zodiac/scm-main.ss
    collects/zodiac/scm-obj.ss
    collects/zodiac/scm-ou.ss
    collects/zodiac/scm-spdy.ss
    collects/zodiac/scm-unit.ss
    collects/zodiac/sexp.ss
    collects/zodiac/sigs.ss
    collects/zodiac/x.ss
    collects/zodiac/zsigs.ss
    man/man1/DrScheme.1
    man/man1/drscheme.1
    man/man1/mred.1
    man/man1/mzscheme.1
    tests/mred/sixlib.ss
original commit: 96b3c4f6aa05997ef10ca7fe72ce11ea011cd352
This commit is contained in:
cvs2git 1997-10-15 16:52:55 +00:00
parent e8295ee015
commit 3165d97d4d
9 changed files with 0 additions and 3638 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

56
collects/hierlist/hierlist.ss
View File

@ -1,56 +0,0 @@
(require-library "hierlists.ss" "hierlist")
(invoke-open-unit/sig (require-library "hierlistr.ss" "hierlist") mred (mred : mred^))
#|
;; Testing
(define f (make-object mred:frame% null "test"))
(define p (make-object mred:horizontal-panel% f))
(define c (make-object (class-asi mred:hierarchical-list%
(public
[item-opened
(lambda (i)
(let ([f (send i user-data)])
(when f (f i))))]
[select
(lambda (i)
(printf "Selected: ~a~n"
(if i
(send (send i get-buffer) get-flattened-text)
i)))]
[double-select
(lambda (s)
(printf "Double-click: ~a~n"
(send (send s get-buffer) get-flattened-text)))]))
p))
(define a (send c new-list))
(send (send a get-buffer) insert "First Item: List")
(send (send (send a new-item) get-buffer) insert "Sub1")
(send (send (send a new-item) get-buffer) insert "Sub2")
(define a.1 (send a new-list))
(send (send a.1 get-buffer) insert "Deeper List")
(send (send (send a.1 new-item) get-buffer) insert "Way Down")
(define b (send c new-item))
(send (send b get-buffer) insert "Second Item")
(define d (send c new-list))
(send (send d get-buffer) insert "dynamic")
(send d user-data (lambda (d)
(time (let loop ([i 30])
(unless (zero? i)
(send (send (send d new-item) get-buffer) insert (number->string i))
(loop (sub1 i)))))))
(define x (send c new-list))
(send (send x get-buffer) insert "x")
(define y (send c new-item))
(send (send y get-buffer) insert "y")
(send f show #t)
|#

969
collects/mred/edit.ss
View File

@ -1,969 +0,0 @@
(unit/sig mred:edit^
(import mred:wx^
[mred:constants : mred:constants^]
[mred:connections : mred:connections^]
[mred:autosave : mred:autosave^]
[mred:finder : mred:finder^]
[mred:path-utils : mred:path-utils^]
[mred:mode : mred:mode^]
[mred:frame : mred:frame^]
[mred:scheme-paren : mred:scheme-paren^]
[mred:keymap : mred:keymap^]
[mred:icon : mred:icon^]
[mred:preferences : mred:preferences^]
[mred:gui-utils : mred:gui-utils^]
[mzlib:function : mzlib:function^])
(mred:debug:printf 'invoke "mred:edit@")
(define-struct range (start end b/w-bitmap color caret-space?))
(define-struct rectangle (left top right bottom b/w-bitmap color))
(mred:preferences:set-preference-default 'mred:verify-change-format #f
(lambda (x)
(or (not x)
(eq? x #t))))
(mred:preferences:set-preference-default 'mred:auto-set-wrap? #f
(lambda (x)
(or (not x)
(eq? x #t))))
(define make-snip%
(let ([sl (make-object wx:style-list%)])
(send sl new-named-style "Standard" (send sl find-named-style "Basic"))
(let ([std (send sl find-named-style "Standard")])
(lambda (snip%)
(class snip% args
(inherit set-style)
(public [edit% media-edit%])
(sequence
(cond
[(null? args)
(super-init (make-object edit%))]
[(null? (car args))
(apply super-init (make-object edit%) (cdr args))]
[else (apply super-init args)])
(set-style std)))))))
(define media-snip% (make-snip% wx:media-snip%))
(define snip% (make-snip% wx:snip%))
(define make-std-buffer%
(lambda (buffer%)
(class buffer% args
(sequence (mred:debug:printf 'creation "creating a buffer"))
(inherit modified? get-filename save-file canvases
get-max-width get-admin)
(rename [super-set-modified set-modified]
[super-on-save-file on-save-file]
[super-on-focus on-focus]
[super-lock lock])
(public [editing-this-file? #f])
(public
[locked? #f]
[lock
(lambda (x)
(set! locked? x)
(super-lock x))]
[do-close (lambda () (void))]
[get-edit-snip
(lambda () (make-object media-snip%
(make-object edit%)))]
[get-pasteboard-snip
(lambda () (make-object media-snip%
(make-object pasteboard%)))]
[on-new-box
(lambda (type)
(cond
[(= type wx:const-edit-buffer)
(get-edit-snip)]
[else (get-pasteboard-snip)]))])
(public
[get-file (lambda (d)
(let ([v (mred:finder:get-file d)])
(if v
v
null)))]
[put-file (lambda (d f) (let ([v (mred:finder:put-file f d)])
(if v
v
null)))]
[mode #f]
[set-mode-direct (lambda (v) (set! mode v))]
[set-mode
(lambda (m)
#f)])
(sequence
(apply super-init args)))))
(define make-pasteboard% make-std-buffer%)
(define make-media-edit%
(lambda (super%)
(class super% args
(inherit canvases get-max-width get-admin split-snip get-snip-position
delete find-snip set-filename invalidate-bitmap-cache
begin-edit-sequence end-edit-sequence
set-autowrap-bitmap get-keymap mode set-mode-direct
set-file-format get-file-format get-frame
get-style-list modified? change-style set-modified
position-location get-extent)
(rename [super-on-focus on-focus]
[super-on-local-event on-local-event]
[super-on-set-focus on-set-focus]
[super-on-kill-focus on-kill-focus]
[super-after-set-position after-set-position]
[super-on-edit-sequence on-edit-sequence]
[super-on-change-style on-change-style]
[super-on-insert on-insert]
[super-on-delete on-delete]
[super-on-set-size-constraint on-set-size-constraint]
[super-after-edit-sequence after-edit-sequence]
[super-after-change-style after-change-style]
[super-after-insert after-insert]
[super-after-delete after-delete]
[super-after-set-size-constraint after-set-size-constraint]
[super-set-max-width set-max-width]
[super-load-file load-file]
[super-on-paint on-paint])
(private [styles-fixed-edit-modified? #f])
(private
[b1 (box 0)]
[b2 (box 0)]
[b3 (box 0)]
[b4 (box 0)]
[range-rectangles null]
[recompute-range-rectangles
(lambda ()
(let ([new-rectangles
(lambda (range)
(let* ([start (range-start range)]
[end (range-end range)]
[b/w-bitmap (range-b/w-bitmap range)]
[color (range-color range)]
[caret-space? (range-caret-space? range)]
[start-eol? #f]
[end-eol? (if (= start end)
start-eol?
#t)])
(let-values ([(start-x top-start-y)
(begin (position-location start b1 b2 #t start-eol? #t)
(values (if caret-space?
(+ 1 (unbox b1))
(unbox b1))
(unbox b2)))]
[(end-x top-end-y)
(begin (position-location end b1 b2 #t end-eol? #t)
(values (unbox b1) (unbox b2)))]
[(bottom-start-y)
(begin (position-location start b1 b2 #f start-eol? #t)
(unbox b2))]
[(bottom-end-y)
(begin (position-location end b1 b2 #f end-eol? #t)
(unbox b2))])
(cond
[(= top-start-y top-end-y)
(list
(make-rectangle start-x
top-start-y
(if (= end-x start-x)
(+ end-x 1)
end-x)
bottom-start-y
b/w-bitmap
color))]
[else
(list
(make-rectangle start-x
top-start-y
'right-edge
bottom-start-y
b/w-bitmap
color)
(make-rectangle 'left-edge
bottom-start-y
'max-width
top-end-y
b/w-bitmap
color)
(make-rectangle 'left-edge
top-end-y
end-x
bottom-end-y
b/w-bitmap
color))]))))]
[invalidate-rectangles
(lambda (rectangles)
(let-values ([(min-left max-right)
(let loop ([left #f]
[right #f]
[canvases canvases])
(cond
[(null? canvases)
(values left right)]
[else
(let-values ([(this-left this-right)
(send (car canvases)
call-as-primary-owner
(lambda ()
(send (get-admin) get-view b1 b2 b3 b4)
(let* ([this-left (unbox b1)]
[this-width (unbox b3)]
[this-right (+ this-left this-width)])
(values this-left
this-right))))])
(if left
(loop (min this-left left)
(max this-right right)
(cdr canvases))
(loop this-left
this-right
(cdr canvases))))]))])
(let loop ([left #f]
[top #f]
[right #f]
[bottom #f]
[rectangles rectangles])
(cond
[(null? rectangles)
(when left
(invalidate-bitmap-cache left top (- right left) (- bottom top)))]
[else (let* ([r (car rectangles)]
[rleft (rectangle-left r)]
[rright (rectangle-right r)]
[rtop (rectangle-top r)]
[rbottom (rectangle-bottom r)]
[this-left (if (number? rleft)
rleft
min-left)]
[this-right (if (number? rright)
rright
max-right)]
[this-bottom rbottom]
[this-top rtop])
(if left
(loop (min this-left left)
(min this-top top)
(max this-right right)
(max this-bottom bottom)
(cdr rectangles))
(loop this-left
this-top
this-right
this-bottom
(cdr rectangles))))]))))]
[old-rectangles range-rectangles])
(set! range-rectangles
(mzlib:function:foldl (lambda (x l) (append (new-rectangles x) l))
null ranges))
(invalidate-rectangles (append old-rectangles
range-rectangles))))]
[ranges null]
[pen (make-object wx:pen%
"BLACK"
0
wx:const-stipple)]
[brush (make-object wx:brush%
"black"
wx:const-stipple)])
(public
;; the bitmap is used in b/w and the color is used in color.
[highlight-range
(opt-lambda (start end color bitmap [caret-space? #f])
(mred:debug:printf 'highlight-range "highlight-range: adding range: ~a ~a" start end)
(let ([l (make-range start end bitmap color caret-space?)])
(set! ranges (cons l ranges))
(recompute-range-rectangles)
(lambda ()
(mred:debug:printf 'highlight-range "highlight-range: removing range: ~a ~a" start end)
(set! ranges
(let loop ([r ranges])
(cond
[(null? r) r]
[else (if (eq? (car r) l)
(cdr r)
(cons (car r) (loop (cdr r))))])))
(recompute-range-rectangles))))]
[on-paint
(lambda (before dc left top right bottom dx dy draw-caret)
(super-on-paint before dc left top right bottom dx dy draw-caret)
(for-each
(lambda (rectangle)
(let-values ([(view-x view-y view-width view-height)
(begin
(send (get-admin) get-view b1 b2 b3 b4)
(values (unbox b1)
(unbox b2)
(unbox b3)
(unbox b4)))])
(let* ([old-pen (send dc get-pen)]
[old-brush (send dc get-brush)]
[old-logical-function (send dc get-logical-function)]
[b/w-bitmap (rectangle-b/w-bitmap rectangle)]
[color (let* ([rc (rectangle-color rectangle)]
[tmpc (make-object wx:colour% 0 0 0)])
(if rc
(begin (send dc try-colour rc tmpc)
(and (<= (max (abs (- (send rc red) (send tmpc red)))
(abs (- (send rc blue) (send tmpc blue)))
(abs (- (send rc green) (send tmpc green))))
15)
rc))
rc))]
[first-number (lambda (x y) (if (number? x) x y))]
[left (first-number (rectangle-left rectangle) view-x)]
[top (rectangle-top rectangle)]
[right (if (number? (rectangle-right rectangle))
(rectangle-right rectangle)
(+ view-x view-width))]
[bottom (rectangle-bottom rectangle)]
[width (max 0 (- right left))]
[height (max 0 (- bottom top))])
(let/ec k
(cond
[(and (not before)
color
(not (eq? wx:platform 'unix))
(<= 8 (wx:display-depth)))
(send pen set-style wx:const-solid)
(send brush set-style wx:const-solid)
(send pen set-colour color)
(send brush set-colour color)
(send dc set-logical-function wx:const-and)]
[(and before
color
(<= 8 (wx:display-depth)))
(send* pen (set-style wx:const-solid)
(set-colour color))
(send* brush (set-style wx:const-solid)
(set-colour color))
(send dc set-logical-function wx:const-copy)]
[(and (not before)
(< (wx:display-depth) 8)
b/w-bitmap
(eq? wx:platform 'unix))
(send pen set-stipple b/w-bitmap)
(send brush set-stipple b/w-bitmap)]
[else (k (void))])
(send dc set-pen pen)
(send dc set-brush brush)
(send dc draw-rectangle
(+ left dx)
(+ top dy)
width
height)
(send dc set-logical-function old-logical-function)
(send dc set-pen old-pen)
(send dc set-brush old-brush)))))
range-rectangles))])
(public
[on-kill-focus
(lambda ()
(super-on-kill-focus)
(let ([frame (get-frame)])
(when (and frame
(is-a? frame mred:frame:empty-frame%))
(send (get-keymap)
remove-chained-keymap
(ivar frame keymap)))))]
[on-set-focus
(lambda ()
(super-on-set-focus)
(let ([frame (get-frame)])
(when (and frame
(is-a? frame mred:frame:empty-frame%))
(send (get-keymap)
chain-to-keymap
(ivar frame keymap)
#t))))])
(public
[set-mode
(lambda (m)
(if mode
(send mode deinstall this))
(if (is-a? m mred:mode:mode%)
(begin
(set-mode-direct m)
(set-file-format (ivar m file-format))
(send m install this)
(let ([new-delta (ivar m standard-style-delta)])
(when new-delta
(send (send (get-style-list)
find-named-style "Standard")
set-delta new-delta))))
(begin
(set-mode-direct #f)
(send (send (get-style-list)
find-named-style "Standard")
set-delta (make-object wx:style-delta%)))))]
[styles-fixed? #f]
[set-styles-fixed (lambda (b) (set! styles-fixed? b))])
(public
[on-focus
(lambda (on?)
(super-on-focus on?)
(when mode
(send mode on-focus this on?)))]
[on-local-event
(lambda (mouse)
(if (or (not mode)
(not (send mode on-event this mouse)))
(super-on-local-event mouse)))]
[on-insert
(lambda (start len)
(if (or (not mode) (send mode on-insert this start len))
(super-on-insert start len)))]
[on-delete
(lambda (start len)
(if (or (not mode) (send mode on-delete this start len))
(super-on-delete start len)))]
[on-change-style
(lambda (start len)
(when styles-fixed?
(set! styles-fixed-edit-modified? (modified?)))
(and (or (not mode)
(send mode on-change-style this start len))
(super-on-change-style start len)))]
[on-edit-sequence
(lambda ()
(when mode
(send mode on-edit-sequence this))
(super-on-edit-sequence))]
[on-set-size-constraint
(lambda ()
(and (or (not mode) (send mode on-set-size-constraint this))
(super-on-set-size-constraint)))]
[after-insert
(lambda (start len)
(when styles-fixed?
(change-style (send (get-style-list) find-named-style "Standard")
start
(+ start len)))
(when mode (send mode after-insert this start len))
(super-after-insert start len))]
[after-delete
(lambda (start len)
(if mode (send mode after-delete this start len))
(super-after-delete start len))]
[after-change-style
(lambda (start len)
(when mode (send mode after-change-style this start len))
(super-after-change-style start len)
(when styles-fixed?
(set-modified styles-fixed-edit-modified?)))]
[after-edit-sequence
(lambda ()
(when mode
(send mode after-edit-sequence this))
(super-after-edit-sequence))]
[after-set-size-constraint
(lambda ()
(when mode
(send mode after-set-size-constraint this))
(super-after-set-size-constraint))]
[after-set-position
(lambda ()
(when mode
(send mode after-set-position this))
(super-after-set-position))])
(public
[set-max-width
(lambda (x)
(mred:debug:printf 'rewrap "rewrap: set-max-width: ~a" x)
(super-set-max-width x))]
[auto-set-wrap? (mred:preferences:get-preference 'mred:auto-set-wrap?)]
[set-auto-set-wrap
(lambda (v)
(mred:debug:printf 'rewrap
"rewrap: set-auto-set-wrap: ~a (canvases ~a)"
v canvases)
(set! auto-set-wrap? v)
(for-each (lambda (c) (send c resize-edit)) canvases))]
[rewrap
(lambda ()
(if auto-set-wrap?
(let* ([current-width (get-max-width)]
[w-box (box 0)]
[new-width
(mzlib:function:foldl
(lambda (canvas sofar)
(send canvas call-as-primary-owner
(lambda ()
(send (get-admin)
get-view null null
w-box (box 0))))
(max (unbox w-box) sofar))
0
canvases)])
(mred:debug:printf 'rewrap "rewrap: new-width ~a current-width ~a"
new-width current-width)
(when (and (not (= current-width new-width))
(< 0 new-width))
(set-max-width new-width)
(mred:debug:printf 'rewrap "rewrap: attempted to wrap to: ~a actually wrapped to ~a"
new-width (get-max-width))))
(begin
(mred:debug:printf 'rewrap "rewrap: wrapping to -1")
(set-max-width -1))))])
(public
[move/copy-to-edit
(lambda (dest-edit start end dest-position)
(let ([insert-edit (ivar dest-edit insert)])
(split-snip start)
(split-snip end)
(let loop ([snip (find-snip end wx:const-snip-before)])
(cond
[(or (null? snip) (< (get-snip-position snip) start))
(void)]
[else
(let ([prev (send snip previous)]
[released/copied (if (send snip release-from-owner)
snip
(let* ([copy (send snip copy)]
[snip-start (get-snip-position snip)]
[snip-end (+ snip-start (send snip get-count))])
(delete snip-start snip-end)
snip))])
'(wx:message-box (format "before: ~a" (eq? snip released/copied)))
(insert-edit released/copied dest-position dest-position)
'(wx:message-box (format "after: ~a" (eq? snip released/copied)))
(loop prev))]))))])
(public
[load-file
(opt-lambda ([filename null] [format wx:const-media-ff-guess])
(let ([filename (if (null? filename)
(mred:finder:get-file)
filename)])
(and filename
(if (file-exists? filename)
(super-load-file filename format)
(set-filename filename)))))])
(public
[autowrap-bitmap null])
(sequence
(apply super-init args)
(set-autowrap-bitmap autowrap-bitmap)
(let ([keymap (get-keymap)])
(mred:keymap:set-keymap-error-handler keymap)
(mred:keymap:set-keymap-implied-shifts keymap)
(send keymap chain-to-keymap mred:keymap:global-keymap #f))))))
(define make-searching-edit%
(lambda (super%)
(class super% args
(inherit get-end-position get-start-position last-position
find-string get-snip-position get-admin find-snip
get-keymap)
(public
[find-string-embedded
(opt-lambda (str [direction 1] [start -1]
[end -1] [get-start #t]
[case-sensitive? #t] [pop-out? #f])
(let/ec k
(let* ([start (if (= -1 start)
(if (= direction 1)
(get-end-position)
(get-start-position))
start)]
[end (if (= -1 end)
(if (= direction 1)
(last-position)
0)
end)]
[flat (find-string str direction
start end get-start
case-sensitive?)]
[end-test
(lambda (snip)
(cond
[(null? snip) flat]
[(and (not (= -1 flat))
(let* ([start (get-snip-position snip)]
[end (+ start (send snip get-count))])
(if (= direction 1)
(and (<= start flat)
(< flat end))
(and (< start flat)
(<= flat end)))))
flat]
[else #f]))]
[pop-out
(lambda ()
(let ([admin (get-admin)])
(if (is-a? admin wx:media-snip-media-admin%)
(let* ([snip (send admin get-snip)]
[edit-above (send (send snip get-admin) get-media)]
[pos (send edit-above get-snip-position snip)])
(send edit-above
find-string-embedded
str
direction
(if (= direction 1) (add1 pos) pos)
-1 get-start
case-sensitive? pop-out?))
(values this -1))))])
(let loop ([current-snip (find-snip start
(if (= direction 1)
wx:const-snip-after-or-null
wx:const-snip-before-or-null))])
(let ([next-loop
(lambda ()
(if (= direction 1)
(loop (send current-snip next))
(loop (send current-snip previous))))])
(cond
[(end-test current-snip) =>
(lambda (x)
(if (and (= x -1) pop-out?)
(pop-out)
(values this x)))]
[(is-a? current-snip wx:media-snip%)
(let-values ([(embedded embedded-pos)
(let ([media (send current-snip get-this-media)])
(and (not (null? media))
(send media find-string-embedded str
direction
(if (= 1 direction)
0
(send media last-position))
-1
get-start case-sensitive?)))])
(if (= -1 embedded-pos)
(next-loop)
(values embedded embedded-pos)))]
[else (next-loop)]))))))])
(sequence
(apply super-init args)
(let ([keymap (get-keymap)])
(mred:keymap:set-keymap-error-handler keymap)
(mred:keymap:set-keymap-implied-shifts keymap)
(send keymap chain-to-keymap mred:keymap:global-search-keymap #f))))))
(define make-file-buffer%
(lambda (super%)
(class super% args
(inherit get-keymap find-snip
get-filename lock get-style-list
modified? change-style set-modified
get-frame)
(rename [super-after-save-file after-save-file]
[super-after-load-file after-load-file])
(public [editing-this-file? #t])
(private
[check-lock
(lambda ()
(let* ([filename (get-filename)]
[lock? (and (not (null? filename))
(file-exists? filename)
(not (member
'write
(file-or-directory-permissions
filename))))])
(mred:debug:printf 'permissions
"locking: ~a (filename: ~a)"
lock?
filename)
(lock lock?)))])
(public
[after-save-file
(lambda (success)
(when success
(check-lock))
(super-after-save-file success))]
[after-load-file
(lambda (sucessful?)
(when sucessful?
(check-lock))
(super-after-load-file sucessful?))]
[autowrap-bitmap (mred:icon:get-autowrap-bitmap)])
(sequence
(apply super-init args)
(let ([keymap (get-keymap)])
(mred:keymap:set-keymap-error-handler keymap)
(mred:keymap:set-keymap-implied-shifts keymap)
(send keymap chain-to-keymap mred:keymap:global-file-keymap #f))))))
(define make-clever-file-format-edit%
(lambda (super%)
(class-asi super%
(inherit get-file-format set-file-format find-snip)
(rename [super-on-save-file on-save-file]
[super-after-save-file after-save-file])
(private [restore-file-format void])
(public
[after-save-file
(lambda (success)
(restore-file-format)
(super-after-save-file success))]
[on-save-file
(let ([has-non-text-snips
(lambda ()
(let loop ([s (find-snip 0 wx:const-snip-after)])
(cond
[(null? s) #f]
[(is-a? s wx:text-snip%)
(loop (send s next))]
[else #t])))])
(lambda (name format)
(when (and (or (= format wx:const-media-ff-same)
(= format wx:const-media-ff-copy))
(not (= (get-file-format)
wx:const-media-ff-std)))
(cond
[(= format wx:const-media-ff-copy)
(set! restore-file-format
(let ([f (get-file-format)])
(lambda ()
(set! restore-file-format void)
(set-file-format f))))
(set-file-format wx:const-media-ff-std)]
[(and (has-non-text-snips)
(or (not (mred:preferences:get-preference 'mred:verify-change-format))
(mred:gui-utils:get-choice "Save this file as plain text?" "No" "Yes")))
(set-file-format wx:const-media-ff-std)]
[else (void)]))
(or (super-on-save-file name format)
(begin
(restore-file-format)
#f))))]))))
(define make-backup-autosave-buffer%
(lambda (super-edit%)
(class super-edit% args
(inherit modified? get-filename save-file)
(rename [super-on-save-file on-save-file]
[super-on-change on-change]
[super-do-close do-close]
[super-set-modified set-modified])
(private
[auto-saved-name #f]
[auto-save-out-of-date? #t]
[auto-save-error? #f])
(public
[backup? #t]
[on-save-file
(lambda (name format)
(set! auto-save-error? #f)
(and (super-on-save-file name format)
(begin
(when (and backup?
(not (= format wx:const-media-ff-copy))
(file-exists? name))
(let ([back-name (mred:path-utils:generate-backup-name name)])
(copy-file name back-name)))
#t)))]
[do-close
(lambda ()
(super-do-close)
(remove-autosave)
(set! auto-save? #f))]
[on-change
(lambda ()
(super-on-change)
(set! auto-save-out-of-date? #t))]
[auto-save? #t]
[set-modified
(lambda (modified?)
(when auto-saved-name
(if (not modified?)
(begin
(delete-file auto-saved-name)
(set! auto-saved-name #f))
(set! auto-save-out-of-date? #t)))
(super-set-modified modified?))]
[do-autosave
(lambda ()
(when (and auto-save?
(not auto-save-error?)
(modified?)
(or (not auto-saved-name)
auto-save-out-of-date?))
(let* ([orig-name (get-filename)]
[auto-name (mred:path-utils:generate-autosave-name orig-name)]
[success (save-file auto-name wx:const-media-ff-copy)])
(if success
(begin
(when auto-saved-name
(delete-file auto-saved-name))
(set! auto-saved-name auto-name)
(set! auto-save-out-of-date? #f))
(begin
(wx:message-box
(format "Error autosaving ~s.~n~a~n~a"
(if (null? orig-name) "Untitled" orig-name)
"Autosaving is turned off"
"until the file is saved.")
"Warning")
(set! auto-save-error? #t))))))]
[remove-autosave
(lambda ()
(when auto-saved-name
(delete-file auto-saved-name)
(set! auto-saved-name #f)))])
(sequence
(apply super-init args)
(mred:autosave:register-autosave this)))))
(define make-return-edit%
(lambda (super%)
(class super% (return . args)
(rename [super-on-local-char on-local-char])
(public
[on-local-char
(lambda (key)
(let ([cr-code 13]
[lf-code 10]
[code (send key get-key-code)])
(or (and (or (= lf-code code)
(= cr-code code))
(return))
(super-on-local-char key))))])
(sequence
(apply super-init args)))))
(define make-info-edit%
(lambda (super-info-edit%)
(class-asi super-info-edit%
(inherit get-frame get-start-position get-end-position
position-line line-start-position)
(rename [super-after-set-position after-set-position]
[super-after-edit-sequence after-edit-sequence]
[super-on-edit-sequence on-edit-sequence]
[super-after-insert after-insert]
[super-after-delete after-delete]
[super-lock lock]
[super-set-overwrite-mode set-overwrite-mode]
[super-set-anchor set-anchor])
(private
[edit-sequence-depth 0]
[position-needs-updating #f]
[lock-needs-updating #f]
[anchor-needs-updating #f]
[overwrite-needs-updating #f]
[maybe-update-anchor
(lambda ()
(if (= edit-sequence-depth 0)
(let ([frame (get-frame)])
(when frame
(send frame anchor-status-changed)))
(set! anchor-needs-updating #t)))]
[maybe-update-overwrite
(lambda ()
(if (= edit-sequence-depth 0)
(let ([frame (get-frame)])
(when frame
(send frame overwrite-status-changed)))
(set! overwrite-needs-updating #t)))]
[maybe-update-lock-icon
(lambda ()
(if (= edit-sequence-depth 0)
(let ([frame (get-frame)])
(when frame
(send frame lock-status-changed)))
(set! lock-needs-updating #t)))]
[maybe-update-position-edit
(lambda ()
(if (= edit-sequence-depth 0)
(update-position-edit)
(set! position-needs-updating #t)))]
[update-position-edit
(lambda ()
(let ([frame (get-frame)])
(when frame
(send frame edit-position-changed))))])
(public
[set-anchor
(lambda (x)
(super-set-anchor x)
(maybe-update-anchor))]
[set-overwrite-mode
(lambda (x)
(super-set-overwrite-mode x)
(maybe-update-overwrite))]
[lock
(lambda (x)
(super-lock x)
(maybe-update-lock-icon))]
[after-set-position
(lambda ()
(maybe-update-position-edit)
(super-after-set-position))]
[after-insert
(lambda (start len)
(maybe-update-position-edit)
(super-after-insert start len))]
[after-delete
(lambda (start len)
(maybe-update-position-edit)
(super-after-delete start len))]
[after-edit-sequence
(lambda ()
(super-after-edit-sequence)
(set! edit-sequence-depth (sub1 edit-sequence-depth))
(when (= 0 edit-sequence-depth)
(let ([frame (get-frame)])
(when anchor-needs-updating
(set! anchor-needs-updating #f)
(send frame overwrite-status-changed))
(when position-needs-updating
(set! position-needs-updating #f)
(update-position-edit))
(when lock-needs-updating
(set! lock-needs-updating #f)
(send frame lock-status-changed)))))]
[on-edit-sequence
(lambda ()
(set! edit-sequence-depth (add1 edit-sequence-depth))
(super-on-edit-sequence))]))))
(define media-edit% (make-media-edit%
(make-std-buffer%
mred:connections:connections-media-edit%)))
(define searching-edit% (make-searching-edit% media-edit%))
(define info-edit% (make-info-edit% searching-edit%))
(define clever-file-format-edit% (make-clever-file-format-edit% info-edit%))
(define file-edit% (make-file-buffer% clever-file-format-edit%))
(define backup-autosave-edit% (make-backup-autosave-buffer% file-edit%))
(define edit% file-edit%)
(define return-edit% (make-return-edit% media-edit%))
(define pasteboard% (make-pasteboard%
mred:connections:connections-media-pasteboard%))
(define file-pasteboard% (make-file-buffer% pasteboard%))
(define backup-autosave-pasteboard% (make-backup-autosave-buffer%
file-pasteboard%)))

58
collects/mred/exit.ss
View File

@ -1,58 +0,0 @@
(unit/sig mred:exit^
(import mred:wx^
[mred:constants : mred:constants^]
[mred:preferences : mred:preferences^]
[mred:gui-utils : mred:gui-utils^])
(rename (-exit exit))
(mred:debug:printf 'invoke "mred:exit@")
(define exit-callbacks '())
(define insert-exit-callback
(lambda (f)
(set! exit-callbacks (cons f exit-callbacks))
f))
(define remove-exit-callback
(lambda (cb)
(set! exit-callbacks
(let loop ([cb-list exit-callbacks])
(cond
[(null? cb-list) ()]
[(eq? cb (car cb-list)) (cdr cb-list)]
[else (cons (car cb-list) (loop (cdr cb-list)))])))))
(define run-exit-callbacks
(lambda ()
(let*-values ([(w capW)
(if (eq? wx:platform 'windows)
(values "exit" "Exit")
(values "quit" "Quit"))]
[(message)
(string-append "Are you sure you want to "
w
"?")])
(let/ec k
(when (mred:preferences:get-preference 'mred:verify-exit)
(unless (mred:gui-utils:get-choice
message capW "Cancel")
(k #f)))
(let loop ([cb-list exit-callbacks])
(cond
[(null? cb-list) #t]
[(not ((car cb-list))) #f]
[else (loop (cdr cb-list))]))))))
(define -exit
(let*-values ([(exiting?) #f])
(opt-lambda ([just-ran-callbacks? #f])
(unless exiting?
(dynamic-wind
(lambda () (set! exiting? #t))
(lambda ()
(if (or just-ran-callbacks? (run-exit-callbacks))
(exit)
#f))
(lambda () (set! exiting? #f))))))))

560
collects/mred/finder.ss
View File

@ -1,560 +0,0 @@
(unit/sig mred:finder^
(import mred:wx^
[mred:constants : mred:constants^]
[mred:container : mred:container^]
[mred:preferences : mred:preferences^]
[mred:gui-utils : mred:gui-utils^]
[mred:edit : mred:edit^]
[mred:canvas : mred:canvas^]
[mzlib:string : mzlib:string^]
[mzlib:function : mzlib:function^]
[mzlib:file : mzlib:file^])
(mred:debug:printf 'invoke "mred:finder@")
(define filter-match?
(lambda (filter name msg)
(let-values ([(base name dir?) (split-path name)])
(if (mzlib:string:regexp-match-exact? filter name)
#t
(begin
(wx:message-box msg "Error")
#f)))))
(define last-directory #f)
(define make-relative
(lambda (s) s))
(define current-find-file-directory
(opt-lambda ([dir 'get])
(cond
[(eq? dir 'get)
(if (not last-directory)
(set! last-directory (current-directory)))
last-directory]
[(and (string? dir)
(directory-exists? dir))
(set! last-directory dir)
#t]
[else #f])))
(mred:preferences:set-preference-default 'mred:show-periods-in-dirlist #f
(lambda (x)
(or (not x)
(eq? x #t))))
(define finder-dialog%
(class mred:container:dialog-box% (save-mode? replace-ok? multi-mode?
result-box start-dir
start-name prompt
file-filter file-filter-msg)
(inherit new-line tab fit center
show
popup-menu)
(private
[WIDTH 500]
[HEIGHT 400]
dirs current-dir
last-selected
[select-counter 0])
(private
[set-directory
(lambda (dir) ; dir is normalied
(mred:gui-utils:show-busy-cursor
(lambda ()
(set! current-dir dir)
(set! last-directory dir)
(let-values
([(dir-list menu-list)
(let loop ([this-dir dir]
[dir-list ()]
[menu-list ()])
(let-values ([(base-dir in-dir dir?) (split-path this-dir)])
(if (eq? wx:platform 'windows)
(mzlib:string:string-lowercase! in-dir))
(let* ([dir-list (cons this-dir dir-list)]
[menu-list (cons in-dir menu-list)])
(if base-dir
(loop base-dir dir-list menu-list)
; No more
(values dir-list menu-list)))))])
(set! dirs (reverse dir-list))
(send* directory-edit
(begin-edit-sequence)
(erase)
(insert dir)
(end-edit-sequence))
(send dir-choice clear)
(let loop ([choices (reverse menu-list)])
(unless (null? choices)
(send dir-choice append (car choices))
(loop (cdr choices))))
(send dir-choice set-selection 0)
(send top-panel force-redraw))
(send name-list clear)
(send name-list set
(mzlib:function:quicksort
(let ([no-periods? (not (mred:preferences:get-preference
'mred:show-periods-in-dirlist))])
(let loop ([l (directory-list dir)])
(if (null? l)
null
(let ([s (car l)]
[rest (loop (cdr l))])
(cond
[(and no-periods?
(<= 1 (string-length s))
(char=? (string-ref s 0) #\.))
rest]
[(directory-exists? (build-path dir s))
(cons (string-append s
(case wx:platform
[(unix) "/"]
[(windows) "\\"]
[else ":"]))
rest)]
[(or (not file-filter)
(mzlib:string:regexp-match-exact? file-filter s))
(cons s rest)]
[else rest])))))
(if (eq? wx:platform 'unix) string<? string-ci<?)))
(set! last-selected -1))))])
(public
[do-period-in/exclusion
(lambda (button event)
(mred:preferences:set-preference 'mred:show-periods-in-dirlist
(send event checked?))
(set-directory current-dir))]
[do-dir
(lambda (choice event)
(let ([which (send event get-selection)])
(if (< which (length dirs))
(set-directory (list-ref dirs which)))))]
[do-name
(lambda (text event)
(if (eq? (send event get-event-type)
wx:const-event-type-text-enter-command)
(do-ok)))]
[do-name-list
(lambda args #f)]
[do-result-list
(lambda args #f)]
[do-into-dir
(lambda args
(let ([name (send name-list get-string-selection)])
(if (string? name)
(let ([name (build-path current-dir
(make-relative name))])
(if (directory-exists? name)
(set-directory (mzlib:file:normalize-path name)))))))]
[do-ok
(lambda args
(if multi-mode?
(let loop ([n (sub1 select-counter)][result ()])
(if (< n 0)
(begin
(set-box! result-box result)
(show #f))
(loop (sub1 n)
(cons (send result-list get-string n)
result))))
(let ([name
(if save-mode?
(send name-field get-value)
(send name-list get-string-selection))])
(cond
[(not (string? name)) 'nothing-selected]
[(string=? name "")
(wx:message-box "You must specify a file name"
"Error")]
[(and save-mode?
file-filter
(not (mzlib:string:regexp-match-exact? file-filter name)))
(wx:message-box file-filter-msg "Error")]
[else
(let ([file (build-path current-dir
(make-relative name))])
(if (directory-exists? file)
(if save-mode?
(wx:message-box
"That is the name of a directory."
"Error")
(set-directory (mzlib:file:normalize-path file)))
(if (or (not save-mode?)
(not (file-exists? file))
replace-ok?
(= (wx:message-box
(string-append
"The file "
name
" already exists. "
"Replace it?")
"Warning"
wx:const-yes-no)
wx:const-yes))
(begin
(set-box! result-box (mzlib:file:normalize-path file))
(show #f)))))]))))]
[add-one
(lambda (name)
(unless (or (directory-exists? name)
(> (send result-list find-string name) -1))
(set! select-counter (add1 select-counter))
(send result-list append (mzlib:file:normalize-path name))))]
[do-add
(lambda args
(let ([name (send name-list get-string-selection)])
(if (string? name)
(let ([name (build-path current-dir
(make-relative name))])
(add-one name)))))]
[do-add-all
(lambda args
(let loop ([n 0])
(let ([name (send name-list get-string n)])
(if (and (string? name)
(positive? (string-length name)))
(let ([name (build-path current-dir
(make-relative name))])
(add-one name)
(loop (add1 n)))))))]
[do-remove
(lambda args
(let loop ([n 0])
(if (< n select-counter)
(if (send result-list selected? n)
(begin
(send result-list delete n)
(set! select-counter (sub1 select-counter))
(loop n))
(loop (add1 n))))))]
[do-cancel
(lambda args
(set-box! result-box #f)
(show #f))]
[on-close (lambda () #f)])
(sequence
(super-init () (if save-mode? "Put File" "Get File")
#t 300 300 WIDTH HEIGHT))
(private
[main-panel (make-object mred:container:vertical-panel% this)]
[top-panel (make-object mred:container:horizontal-panel% main-panel)]
[_1 (make-object mred:container:message% top-panel prompt)]
[dir-choice (make-object mred:container:choice% top-panel do-dir '())]
[middle-panel (make-object mred:container:horizontal-panel% main-panel)]
[left-middle-panel (make-object mred:container:vertical-panel% middle-panel)]
[right-middle-panel (when multi-mode? (make-object mred:container:vertical-panel% middle-panel))]
[name-list%
(class-asi mred:container:list-box%
(public
[on-default-action
(lambda ()
(let* ([which (send name-list get-string-selection)]
[dir (build-path current-dir
(make-relative which))])
(if (directory-exists? dir)
(set-directory (mzlib:file:normalize-path dir))
(if save-mode?
(send name-field set-value which)
(if multi-mode?
(do-add)
(do-ok))))))]))]
[name-list (make-object name-list%
left-middle-panel do-name-list
() wx:const-single
-1 -1
(if multi-mode? (* 1/2 WIDTH) WIDTH) 300
() wx:const-needed-sb)]
[save-panel (when save-mode? (make-object mred:container:horizontal-panel% main-panel))]
[directory-panel (make-object mred:container:horizontal-panel% main-panel)]
[directory-edit (make-object (class-asi mred:edit:media-edit%
(rename [super-on-local-char on-local-char])
(public
[on-local-char
(lambda (key)
(let ([cr-code 13]
[lf-code 10]
[code (send key get-key-code)])
(if (or (= code cr-code)
(= code lf-code))
(do-go)
(super-on-local-char key))))])))]
[period-panel (when (eq? 'unix wx:platform)
(make-object mred:container:horizontal-panel% main-panel))]
[bottom-panel (make-object mred:container:horizontal-panel% main-panel)]
[result-list
(when multi-mode?
(make-object mred:container:list-box%
right-middle-panel do-result-list
()
(if (eq? wx:window-system 'motif)
wx:const-extended
wx:const-multiple)
-1 -1
(* 1/2 WIDTH) 300
() wx:const-needed-sb))]
[add-panel (when multi-mode? (make-object mred:container:horizontal-panel% left-middle-panel))]
[remove-panel (when multi-mode? (make-object mred:container:horizontal-panel% right-middle-panel))]
[do-go
(lambda ()
(let ([t (send directory-edit get-text)])
(cond
[(file-exists? t)
(set-box! result-box (mzlib:file:normalize-path t))
(show #f)]
[(directory-exists? t)
(set-directory (mzlib:file:normalize-path t))]
[else (wx:message-box (format "~a doesn't exist" t))])))])
(sequence
(when (eq? wx:platform 'unix)
(make-object mred:container:check-box% period-panel
do-period-in/exclusion
"Show files and directories that begin with a period")
(send period-panel stretchable-in-y #f))
(send directory-panel stretchable-in-y #f)
(let ([canvas (make-object mred:canvas:one-line-canvas% directory-panel -1 -1 -1 20 ""
(+ wx:const-mcanvas-hide-h-scroll
wx:const-mcanvas-hide-v-scroll))])
(send* canvas
(set-media directory-edit)
(set-focus)
(user-min-height 20)))
(make-object mred:container:button% directory-panel
(lambda (button evt) (do-go))
"Go")
(when multi-mode?
(send add-panel stretchable-in-y #f)
(send remove-panel stretchable-in-y #f)
(send result-list stretchable-in-x #t))
(send name-list stretchable-in-x #t)
(send top-panel stretchable-in-y #f)
(send bottom-panel stretchable-in-y #f)
(when save-mode?
(send save-panel stretchable-in-y #f)))
(private
[name-field
(when save-mode?
(let* ([% (class-asi mred:container:text%
(public
[on-default-action
(lambda ()
(do-ok))]))]
[v (make-object %
save-panel do-name
"Name: " ""
-1 -1
400 -1
wx:const-process-enter)])
(send v stretchable-in-x #t)
(if (string? start-name)
(send v set-value start-name))
(new-line)
v))]
[into-dir-button
(when save-mode?
(make-object mred:container:button%
save-panel do-into-dir "Open Directory"))]
[add-button (when multi-mode?
(make-object mred:container:horizontal-panel% add-panel)
(make-object mred:container:button%
add-panel do-add
"Add"))]
[add-all-button (when multi-mode?
(begin0
(make-object mred:container:button%
add-panel do-add-all
"Add All")
(make-object mred:container:horizontal-panel% add-panel)))]
[remove-button (when multi-mode?
(make-object mred:container:horizontal-panel% remove-panel)
(begin0
(make-object mred:container:button%
remove-panel do-remove
"Remove")
(make-object mred:container:horizontal-panel% remove-panel)))])
(sequence
(make-object mred:container:vertical-panel% bottom-panel))
(private
[cancel-button (make-object mred:container:button%
bottom-panel do-cancel
"Cancel")]
[ok-button
(let ([w (send cancel-button get-width)])
(make-object mred:container:button%
bottom-panel do-ok
"OK" -1 -1 w))])
(sequence
(cond
[(and start-dir
(not (null? start-dir))
(directory-exists? start-dir))
(set-directory (mzlib:file:normalize-path start-dir))]
[last-directory (set-directory last-directory)]
[else (set-directory (current-directory))])
(send ok-button user-min-width (send cancel-button get-width))
(center wx:const-both)
(show #t))))
(define make-common
(lambda (box-value make-dialog)
(let ([s (make-semaphore 1)]
[v (box box-value)]
[d #f])
(lambda x
(semaphore-wait s)
(if d
(let ([my-d d]
[my-v v])
(set! d #f)
(set! v #f)
(semaphore-post s)
(send my-d show #t)
(begin0 (unbox my-v)
(semaphore-wait s)
(set! d my-d)
(set! v my-v)
(semaphore-post s)))
(begin
(semaphore-post s)
(let* ([my-v (box box-value)]
[my-d (apply make-dialog my-v x)])
(semaphore-wait s)
(unless d
(set! d my-d)
(set! v my-v))
(begin0 (unbox my-v)
(semaphore-post s)))))))))
(define common-put-file
(make-common
#f
(opt-lambda (box
[name ()][directory ()][replace? #f]
[prompt "Select File"][filter #f]
[filter-msg "That name does not have the right form"])
(let* ([directory (if (and (null? directory)
(string? name))
(or (mzlib:file:path-only name) null)
directory)]
[name (or (and (string? name)
(mzlib:file:file-name-from-path name))
name)])
(make-object finder-dialog% #t replace? #f box
directory name prompt filter filter-msg)))))
(define common-get-file
(make-common
#f
(opt-lambda
(box [directory ()][prompt "Select File"][filter #f]
[filter-msg "Bad name"])
(make-object finder-dialog% #f #f #f box directory '() prompt
filter filter-msg))))
(define common-get-file-list
(make-common
null
(opt-lambda (box [directory ()][prompt "Select Files"][filter #f]
[filter-msg "Bad name"])
(make-object finder-dialog% #f #f #t box directory '() prompt
filter filter-msg))))
(define std-put-file
(opt-lambda ([name ()][directory ()][replace? #f][prompt "Select File"]
[filter #f]
[filter-msg
"That filename does not have the right form."])
(let* ([directory (if (and (null? directory)
(string? name))
(or (mzlib:file:path-only name) null)
directory)]
[name (or (and (string? name)
(mzlib:file:file-name-from-path name))
name)]
[f (wx:file-selector prompt directory name
'()
(if (eq? wx:platform 'windows)
"*.*"
"*")
wx:const-save)])
(if (or (null? f)
(and filter
(not (filter-match? filter
f
filter-msg))))
#f
(let* ([f (mzlib:file:normalize-path f)]
[dir (mzlib:file:path-only f)]
[name (mzlib:file:file-name-from-path f)])
(cond
[(not (and (string? dir) (directory-exists? dir)))
(wx:message-box "Error" "That directory does not exist.")
#f]
[(or (not name) (equal? name ""))
(wx:message-box "Error" "Empty filename.")
#f]
[else f]))))))
(define std-get-file
(opt-lambda ([directory ()][prompt "Select File"][filter #f]
[filter-msg
"That filename does not have the right form."])
(let ([f (wx:file-selector prompt directory)])
(if (null? f)
#f
(if (or (not filter) (filter-match? filter f filter-msg))
(let ([f (mzlib:file:normalize-path f)])
(cond
[(directory-exists? f)
(wx:message-box "Error"
"That is a directory name.")
#f]
[(not (file-exists? f))
(wx:message-box "That file does not exist.")
#f]
[else f]))
#f)))))
(mred:preferences:set-preference-default 'mred:file-dialogs
(if (eq? wx:platform 'unix)
'common
'std)
(lambda (x)
(or (eq? x 'common)
(eq? x 'std))))
(define put-file
(lambda args
(apply (case (mred:preferences:get-preference 'mred:file-dialogs)
[(std) std-put-file]
[(common) common-put-file])
args)))
(define get-file
(lambda args
(apply (case (mred:preferences:get-preference 'mred:file-dialogs)
[(std) std-get-file]
[(common) common-get-file])
args))))

948
collects/mred/keys.ss
View File

@ -1,948 +0,0 @@
(unit/sig mred:keymap^
(import mred:wx^
[mred:constants : mred:constants^]
[mred:preferences : mred:preferences^]
[mred:exit : mred:exit^]
[mred:finder : mred:finder^]
[mred:handler : mred:handler^]
[mred:find-string : mred:find-string^]
[mred:scheme-paren : mred:scheme-paren^]
[mred:gui-utils : mred:gui-utils^])
(mred:debug:printf 'invoke "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
; changed for different keyboards.
(define shifted-key-list
'("<" ">" "?" ":" "~" "\""
"{" "}"
"!" "@" "#" "$" "%" "^" "&" "*" "(" ")" "_" "+"
"|"))
(define keyerr
(lambda (str)
(display str (current-error-port))
(newline (current-error-port))))
(define (set-keymap-error-handler keymap)
(send keymap set-error-callback keyerr))
(define (set-keymap-implied-shifts keymap)
(map (lambda (k) (send keymap implies-shift k))
shifted-key-list))
(define (make-meta-prefix-list key)
(list (string-append "m:" key)
(string-append "c:[;" key)
(string-append "ESC;" key)))
(define send-map-function-meta
(lambda (keymap key func)
(for-each (lambda (key)
(send keymap map-function key func))
(make-meta-prefix-list key))))
(mred:preferences:set-preference-default 'mred:delete-forward?
(not (eq? wx:platform 'unix))
(lambda (x)
(or (not x)
(eq? x #t))))
(define setup-global-search-keymap
(let* ([find-frame
(lambda (event)
(let loop ([p (send event get-event-object)])
(if (is-a? p wx:frame%)
p
(loop (send p get-parent)))))]
[find-string-reverse
(lambda (edit event)
(send (find-frame event) search -1)
#t)]
[find-string
(lambda (edit event)
(send (find-frame event) search 1)
#t)]
[toggle-search-focus
(lambda (edit event)
(send (find-frame event) toggle-search-focus)
#t)])
(lambda (kmap)
(let* ([map (lambda (key func)
(send kmap map-function key func))]
[map-meta (lambda (key func)
(send-map-function-meta kmap key func))]
[add (lambda (name func)
(send kmap add-key-function name func))]
[add-m (lambda (name func)
(send kmap add-mouse-function name func))])
(add "initiate-search" toggle-search-focus)
(add "find-string" find-string)
(add "find-string-reverse" find-string-reverse)
(map "c:i" "initiate-search")
(map "c:s" "find-string")
(map "c:r" "find-string-reverse")
(map-meta "%" "find-string")))))
(define setup-global-file-keymap
(let* ([rcs
(let ([last-checkin-string ""])
(mred:preferences:set-preference-default
'rcs-pathname (list "/usr/local/RCS/" "/usr/bin/" "/usr/local/bin/")
(lambda (x)
(and (list? x)
(andmap string? x))))
(lambda (edit event)
(let/ec k
(let* ([rcs-binaries (list "ci" "co" "rlog")]
[rcs-pathname (let loop ([paths (mred:preferences:get-preference 'rcs-pathname)])
(cond
[(null? paths) (k (wx:message-box "could not find RCS binaries."))]
[else (if (andmap (lambda (b)
(file-exists? (build-path (car paths) b)))
rcs-binaries)
(car paths)
(loop (cdr paths)))]))]
[filename (send edit get-filename)]
[username (wx:get-user-id)])
(when (null? filename)
(k (wx:message-box "no file associated with this edit")))
(let-values ([(my-out my-in my-pid my-err)
(apply values (process* (build-path rcs-pathname "rlog")
"-L" "-R" (string-append "-l" username) filename))])
(let-values ([(their-out their-in their-pid their-err)
(apply values (process* (build-path rcs-pathname "rlog")
"-L" "-R" "-l" filename))])
(let ([my-lock? (not (eof-object? (read my-out)))]
[locked? (not (eof-object? (read their-out)))])
(for-each close-input-port (list my-out my-err their-out their-err))
(for-each close-output-port (list my-in their-in))
(cond
[(not (system* (build-path rcs-pathname "rlog") "-h" "-q" filename))
(system* (build-path rcs-pathname "ci") "-t-" filename)
(wx:message-box "Initial Checkin Completed")]
[my-lock?
(when (send edit modified?)
(case (mred:gui-utils:unsaved-warning (send edit get-filename) "Checkin" #t)
[(save) (send edit save-file (send edit get-filename)
(send edit get-file-format))]
[(cancel) (k (void))]
[else (void)]))
(let* ([msg (mred:gui-utils:get-text-from-user
"Please Enter Log Message"
"Check In"
last-checkin-string)]
[result (system* (build-path rcs-pathname "ci")
"-u" (string-append "-m" msg) filename)])
(set! last-checkin-string (or msg ""))
(if result
(send edit load-file
(send edit get-filename)
(send edit get-file-format))
(mred:gui-utils:message-box "Checkin Unsucessful")))]
[locked? (mred:gui-utils:message-box "Someone else has the lock")]
[else
(let ([current-dir (current-directory)])
(let-values ([(base name _) (split-path filename)])
(unless (eq? 'relative base)
(current-directory base))
(let ([res (system* (build-path rcs-pathname "co")
"-q" "-l" name)])
(current-directory current-dir)
(if res
(send edit load-file
(send edit get-filename)
(send edit get-file-format))
(wx:message-box "Checkout Failed")))))]))))))))]
[save-file-as
(lambda (edit event)
(let ([file (mred:finder:put-file)])
(if file
(send edit save-file file)))
#t)]
[save-file
(lambda (edit event)
(if (null? (send edit get-filename))
(save-file-as edit event)
(send edit save-file))
#t)]
[load-file
(lambda (edit event)
(mred:handler:open-file)
#t)])
(lambda (kmap)
(map (lambda (k) (send kmap implies-shift k)) shifted-key-list)
(let* ([map (lambda (key func)
(send kmap map-function key func))]
[map-meta (lambda (key func)
(send-map-function-meta kmap key func))]
[add (lambda (name func)
(send kmap add-key-function name func))]
[add-m (lambda (name func)
(send kmap add-mouse-function name func))])
(add "rcs" rcs)
(add "save-file" save-file)
(add "save-file-as" save-file-as)
(add "load-file" load-file)
(when (eq? wx:platform 'unix)
'(map "c:x;c:q" "rcs"))
(map "c:x;c:s" "save-file")
(map "d:s" "save-file")
(map "c:x;c:w" "save-file-as")
(map "c:x;c:f" "load-file")))))
; This installs the standard keyboard mapping
(define setup-global-keymap
; Define some useful keyboard functions
(let* ([ring-bell
(lambda (edit event)
(let ([c (send edit get-canvas)])
(when c
(let ([f (let loop ([f c])
(if (is-a? f wx:frame%)
f
(loop (send f get-parent))))])
(send f hide-search))))
(wx:bell))]
[toggle-anchor
(lambda (edit event)
(send edit set-anchor
(not (send edit get-anchor))))]
[center-view-on-line
(lambda (edit event)
(let ([new-mid-line (send edit position-line
(send edit get-start-position))]
[bt (box 0)]
[bb (box 0)])
(send edit get-visible-line-range bt bb)
(let* ([half (sub1 (quotient (- (unbox bb) (unbox bt)) 2))]
[top-pos (send edit line-start-position
(max (- new-mid-line half) 0))]
[bottom-pos (send edit line-start-position
(min (+ new-mid-line half)
(send edit position-line
(send edit last-position))))])
(send edit scroll-to-position
top-pos
#f
bottom-pos)))
#t)]
[flash-paren-match
(lambda (edit event)
(send edit on-default-char event)
(let ([pos (mred:scheme-paren:scheme-backward-match
edit
(send edit get-start-position)
0)])
(when pos
(send edit flash-on pos (+ 1 pos))))
#t)]
[collapse-variable-space
(lambda (leave-one? edit event)
(letrec ([find-nonwhite
(lambda (pos d)
(let ([c (send edit get-character pos)])
(cond
[(char=? #\newline c) pos]
[(char-whitespace? c)
(find-nonwhite (+ pos d) d)]
[else pos])))])
(let ([sel-start (send edit get-start-position)]
[sel-end (send edit get-end-position)])
(if (= sel-start sel-end)
(let ([start (+ (find-nonwhite (- sel-start 1) -1)
(if leave-one? 2 1))]
[end (find-nonwhite sel-start 1)])
(if (< start end)
(begin
(send edit begin-edit-sequence)
(send edit delete start end)
(if (and leave-one?
(not (char=? #\space
(send edit get-character
(sub1 start)))))
(send edit insert " " (sub1 start) start))
(send edit set-position start)
(send edit end-edit-sequence))
(if leave-one?
(let ([at-start
(send edit get-character sel-start)]
[after-start
(send edit get-character
(sub1 sel-start))])
(cond
[(char-whitespace? at-start)
(if (not (char=? at-start #\space))
(send edit insert " " sel-start
(add1 sel-start)))
(send edit set-position (add1 sel-start))]
[(char-whitespace? after-start)
(if (not (char=? after-start #\space))
(send edit insert " " (sub1 sel-start)
sel-start))]
[else (send edit insert " ")])))))))))]
[collapse-space
(lambda (edit event)
(collapse-variable-space #t edit event))]
[remove-space
(lambda (edit event)
(collapse-variable-space #f edit event))]
[collapse-newline
(lambda (edit event)
(letrec ([find-nonwhite
(lambda (pos d offset)
(call/ec
(lambda (escape)
(let ([max (if (> offset 0)
(send edit last-position)
-1)])
(let loop ([pos pos])
(if (= pos max)
(escape pos)
(let ([c (send edit get-character
(+ pos offset))])
(cond
[(char=? #\newline c)
(loop (+ pos d))
(escape pos)]
[(char-whitespace? c)
(loop (+ pos d))]
[else pos]))))))))])
(let ([sel-start (send edit get-start-position)]
[sel-end (send edit get-end-position)])
(if (= sel-start sel-end)
(let* ([pos-line
(send edit position-line sel-start #f)]
[pos-line-start
(send edit line-start-position pos-line)]
[pos-line-end
(send edit line-end-position pos-line)]
[whiteline?
(let loop ([pos pos-line-start])
(if (>= pos pos-line-end)
#t
(and (char-whitespace?
(send edit get-character pos))
(loop (add1 pos)))))]
[start (find-nonwhite pos-line-start -1 -1)]
[end (find-nonwhite pos-line-end 1 0)]
[start-line
(send edit position-line start #f)]
[start-line-start
(send edit line-start-position start-line)]
[end-line
(send edit position-line end #f)]
[end-line-start
(send edit line-start-position (add1 end-line))])
(cond
[(and whiteline?
(= start-line pos-line)
(= end-line pos-line))
; Special case: just delete this line
(send edit delete pos-line-start (add1 pos-line-end))]
[(and whiteline? (< start-line pos-line))
; Can delete before & after
(send* edit
(begin-edit-sequence)
(delete (add1 pos-line-end) end-line-start)
(delete start-line-start pos-line-start)
(end-edit-sequence))]
[else
; Only delete after
(send edit delete (add1 pos-line-end)
end-line-start)]))))))]
[open-line
(lambda (edit event)
(let ([sel-start (send edit get-start-position)]
[sel-end (send edit get-end-position)])
(if (= sel-start sel-end)
(send* edit
(insert #\newline)
(set-position sel-start)))))]
[transpose-chars
(lambda (edit event)
(let ([sel-start (send edit get-start-position)]
[sel-end (send edit get-end-position)])
(when (= sel-start sel-end)
(let ([sel-start
(if (= sel-start
(send edit line-end-position
(send edit position-line sel-start)))
(sub1 sel-start)
sel-start)])
(let ([s (send edit get-text
sel-start (add1 sel-start))])
(send* edit
(begin-edit-sequence)
(delete sel-start (add1 sel-start))
(insert s (- sel-start 1))
(set-position (add1 sel-start))
(end-edit-sequence)))))))]
[transpose-words
(lambda (edit event)
(let ([sel-start (send edit get-start-position)]
[sel-end (send edit get-end-position)])
(when (= sel-start sel-end)
(let ([word-1-start (box sel-start)])
(send edit find-wordbreak word-1-start ()
wx:const-break-for-caret)
(let ([word-1-end (box (unbox word-1-start))])
(send edit find-wordbreak () word-1-end
wx:const-break-for-caret)
(let ([word-2-end (box (unbox word-1-end))])
(send edit find-wordbreak () word-2-end
wx:const-break-for-caret)
(let ([word-2-start (box (unbox word-2-end))])
(send edit find-wordbreak word-2-start ()
wx:const-break-for-caret)
(let ([text-1 (send edit get-text
(unbox word-1-start)
(unbox word-1-end))]
[text-2 (send edit get-text
(unbox word-2-start)
(unbox word-2-end))])
(send* edit
(begin-edit-sequence)
(insert text-1
(unbox word-2-start)
(unbox word-2-end))
(insert text-2
(unbox word-1-start)
(unbox word-1-end))
(set-position (unbox word-2-end))
(end-edit-sequence))))))))))]
[capitalize-it
(lambda (edit all? char-case char-case2)
(let ([sel-start (send edit get-start-position)]
[sel-end (send edit get-end-position)]
[real-end (send edit last-position)])
(when (= sel-start sel-end)
(let ([end-box (box sel-start)])
(send edit find-wordbreak () end-box
wx:const-break-for-caret)
(dynamic-wind
(lambda ()
(send edit begin-edit-sequence))
(lambda ()
(let loop ([pos sel-start][char-case char-case])
(if (< pos real-end)
(let ([c (send edit get-character pos)])
(if (char-alphabetic? c)
(begin
(send edit insert
(list->string
(list (char-case c)))
pos (add1 pos))
(if (and all? (< (add1 pos)
(unbox end-box)))
(loop (add1 pos) char-case2)))
(loop (add1 pos) char-case))))))
(lambda ()
(send edit end-edit-sequence)))
(send edit set-position (unbox end-box))))))]
[capitalize-word
(lambda (edit event)
(capitalize-it edit #t char-upcase char-downcase))]
[upcase-word
(lambda (edit event)
(capitalize-it edit #t char-upcase char-upcase))]
[downcase-word
(lambda (edit event)
(capitalize-it edit #t char-downcase char-downcase))]
[kill-word
(lambda (edit event)
(let ([sel-start (send edit get-start-position)]
[sel-end (send edit get-end-position)])
(let ([end-box (box sel-end)])
(send edit find-wordbreak () end-box
wx:const-break-for-caret)
(send edit kill 0 sel-start (unbox end-box)))))]
[backward-kill-word
(lambda (edit event)
(let ([sel-start (send edit get-start-position)]
[sel-end (send edit get-end-position)])
(let ([start-box (box sel-start)])
(send edit find-wordbreak start-box ()
wx:const-break-for-caret)
(send edit kill 0 (unbox start-box) sel-end))))]
[region-click
(lambda (edit event f)
(when (send event button-down?)
(let ([x-box (box (send event get-x))]
[y-box (box (send event get-y))]
[eol-box (box #f)])
(send edit global-to-local x-box y-box)
(let ([click-pos (send edit find-position
(unbox x-box)
(unbox y-box)
eol-box)]
[start-pos (send edit get-start-position)]
[end-pos (send edit get-end-position)])
(let ([eol (unbox eol-box)])
(if (< start-pos click-pos)
(f click-pos eol start-pos click-pos)
(f click-pos eol click-pos end-pos)))))))]
[copy-click-region
(lambda (edit event)
(region-click edit event
(lambda (click eol start end)
(send edit flash-on start end)
(send edit copy #f 0 start end))))]
[cut-click-region
(lambda (edit event)
(region-click edit event
(lambda (click eol start end)
(send edit cut #f 0 start end))))]
[paste-click-region
(lambda (edit event)
(region-click edit event
(lambda (click eol start end)
(send edit set-position click)
(send edit paste 0 click))))]
[mouse-copy-clipboard
(lambda (edit event)
(send edit copy #f (send event get-time-stamp)))]
[mouse-paste-clipboard
(lambda (edit event)
(send edit paste (send event get-time-stamp)))]
[mouse-cut-clipboard
(lambda (edit event)
(send edit cut #f (send event get-time-stamp)))]
[select-click-word
(lambda (edit event)
(region-click edit event
(lambda (click eol start end)
(let ([start-box (box click)]
[end-box (box click)])
(send edit find-wordbreak
start-box
end-box
wx:const-break-for-selection)
(send edit set-position
(unbox start-box)
(unbox end-box))))))]
[select-click-line
(lambda (edit event)
(region-click edit event
(lambda (click eol start end)
(let* ([line (send edit position-line
click eol)]
[start (send edit line-start-position
line #f)]
[end (send edit line-end-position
line #f)])
(send edit set-position start end)))))]
[goto-line
(lambda (edit event)
(let ([num-str (mred:gui-utils:get-text-from-user
"Goto Line:"
"Goto Line")])
(if (string? num-str)
(let ([line-num (string->number num-str)])
(if line-num
(let ([pos (send edit line-start-position
(sub1 line-num))])
(send edit set-position pos))))))
#t)]
[goto-position
(lambda (edit event)
(let ([num-str (mred:gui-utils:get-text-from-user
"Goto Position:"
"Goto Position")])
(if (string? num-str)
(let ([pos (string->number num-str)])
(if pos
(send edit set-position (sub1 pos))))))
#t)]
[repeater
(lambda (n edit)
(let* ([km (send edit get-keymap)]
[done
(lambda ()
(send km set-break-sequence-callback void)
(send km remove-grab-key-function))])
(send km set-grab-key-function
(lambda (name local-km edit event)
(if (null? name)
(let ([k (send event get-key-code)])
(if (<= (char->integer #\0) k (char->integer #\9))
(set! n (+ (* n 10) (- k (char->integer #\0))))
(begin
(done)
(dynamic-wind
(lambda ()
(send edit begin-edit-sequence))
(lambda ()
(let loop ([n n])
(unless (zero? n)
(send edit on-char event)
(loop (sub1 n)))))
(lambda ()
(send edit end-edit-sequence))))))
(begin
(done)
(dynamic-wind
(lambda ()
(send edit begin-edit-sequence))
(lambda ()
(let loop ([n n])
(unless (zero? n)
(send local-km call-function name edit event)
(loop (sub1 n)))))
(lambda ()
(send edit end-edit-sequence)))))
#t))
(send km set-break-sequence-callback done)
#t))]
[make-make-repeater
(lambda (n)
(lambda (edit event)
(repeater n edit)))]
[current-macro '()]
[building-macro #f] [build-macro-km #f] [build-protect? #f]
[do-macro
(lambda (edit event)
; If c:x;e during record, copy the old macro
(when building-macro
(set! building-macro (append (reverse current-macro)
(cdr building-macro))))
(let ([bm building-macro]
[km (send edit get-keymap)])
(dynamic-wind
(lambda ()
(set! building-macro #f)
(send edit begin-edit-sequence))
(lambda ()
(let/ec escape
(for-each
(lambda (f)
(let ([name (car f)]
[event (cdr f)])
(if (null? name)
(send edit on-char event)
(if (not (send km call-function
name edit event #t))
(escape #t)))))
current-macro)))
(lambda ()
(send edit end-edit-sequence)
(set! building-macro bm))))
#t)]
[start-macro
(lambda (edit event)
(if building-macro
(send build-macro-km break-sequence)
(letrec* ([km (send edit get-keymap)]
[done
(lambda ()
(if build-protect?
(send km set-break-sequence-callback done)
(begin
(set! building-macro #f)
(send km set-break-sequence-callback void)
(send km remove-grab-key-function))))])
(set! building-macro '())
(set! build-macro-km km)
(send km set-grab-key-function
(lambda (name local-km edit event)
(dynamic-wind
(lambda ()
(set! build-protect? #t))
(lambda ()
(if (null? name)
(send edit on-default-char event)
(send local-km call-function name edit event)))
(lambda ()
(set! build-protect? #f)))
(when building-macro
(set! building-macro
(cons (cons name
(duplicate-key-event event))
building-macro)))
#t))
(send km set-break-sequence-callback done)))
#t)]
[end-macro
(lambda (edit event)
(when building-macro
(set! current-macro (reverse building-macro))
(set! build-protect? #f)
(send build-macro-km break-sequence))
#t)]
[delete-key
(lambda (edit event)
(let ([kmap (send edit get-keymap)])
(send kmap call-function
(if (mred:preferences:get-preference 'mred:delete-forward?)
"delete-next-character"
"delete-previous-character")
edit event #t)))]
[toggle-overwrite
(lambda (edit event)
(send edit set-overwrite-mode
(not (send edit get-overwrite-mode))))])
(lambda (kmap)
; Redirect keymapping error messages to stderr
(send kmap set-error-callback keyerr)
; Set the implied shifting map
(map (lambda (k) (send kmap implies-shift k)) shifted-key-list)
(let* ([map (lambda (key func)
(send kmap map-function key func))]
[map-meta (lambda (key func)
(send-map-function-meta kmap key func))]
[add (lambda (name func)
(send kmap add-key-function name func))]
[add-m (lambda (name func)
(send kmap add-mouse-function name func))])
; Standards
(wx:add-media-buffer-functions kmap)
(wx:add-media-editor-functions kmap)
(wx:add-media-pasteboard-functions kmap)
; Map names to keyboard functions
(add "toggle-overwrite" toggle-overwrite)
(add "exit" (lambda (edit event)
(let ([frame (send edit get-frame)])
(if frame
((ivar frame file-menu:quit))
(wx:bell)))))
(add "ring-bell" ring-bell)
(add "flash-paren-match" flash-paren-match)
(add "toggle-anchor" toggle-anchor)
(add "center-view-on-line" center-view-on-line)
(add "collapse-space" collapse-space)
(add "remove-space" remove-space)
(add "collapse-newline" collapse-newline)
(add "open-line" open-line)
(add "transpose-chars" transpose-chars)
(add "transpose-words" transpose-words)
(add "capitalize-word" capitalize-word)
(add "upcase-word" upcase-word)
(add "downcase-word" downcase-word)
(add "kill-word" kill-word)
(add "backward-kill-word" backward-kill-word)
(let loop ([n 9])
(unless (negative? n)
(let ([s (number->string n)])
(add (string-append "command-repeat-" s)
(make-make-repeater n))
(loop (sub1 n)))))
(add "do-saved-macro" do-macro)
(add "start-macro-record" start-macro)
(add "end-macro-record" end-macro)
(add-m "copy-clipboard" mouse-copy-clipboard)
(add-m "cut-clipboard" mouse-cut-clipboard)
(add-m "paste-clipboard" mouse-paste-clipboard)
(add-m "copy-click-region" copy-click-region)
(add-m "cut-click-region" cut-click-region)
(add-m "paste-click-region" paste-click-region)
(add-m "select-click-word" select-click-word)
(add-m "select-click-line" select-click-line)
(add "goto-line" goto-line)
(add "goto-position" goto-position)
(add "delete-key" delete-key)
; Map keys to functions
(map "c:g" "ring-bell")
(map-meta "c:g" "ring-bell")
(map "c:x;c:g" "ring-bell")
(map "c:c;c:g" "ring-bell")
(map ")" "flash-paren-match")
(map "]" "flash-paren-match")
(map "}" "flash-paren-match")
(map "\"" "flash-paren-match")
(map "c:p" "previous-line")
(map "up" "previous-line")
(map "s:c:p" "select-up")
(map "s:up" "select-up")
(map "c:n" "next-line")
(map "down" "next-line")
(map "s:c:n" "select-down")
(map "s:down" "select-down")
(map "c:e" "end-of-line")
(map "d:RIGHT" "end-of-line")
(map "m:RIGHT" "end-of-line")
(map "END" "end-of-line")
(map "d:s:RIGHT" "select-to-end-of-line")
(map "m:s:RIGHT" "select-to-end-of-line")
(map "s:END" "select-to-end-of-line")
(map "s:c:e" "select-to-end-of-line")
(map "c:a" "beginning-of-line")
(map "d:LEFT" "beginning-of-line")
(map "m:LEFT" "beginning-of-line")
(map "HOME" "beginning-of-line")
(map "d:s:LEFT" "select-to-beginning-of-line")
(map "m:s:LEFT" "select-to-beginning-of-line")
(map "s:HOME" "select-to-beginning-of-line")
(map "s:c:a" "select-to-beginning-of-line")
(map "c:f" "forward-character")
(map "right" "forward-character")
(map "s:c:f" "forward-select")
(map "s:right" "forward-select")
(map "c:b" "backward-character")
(map "left" "backward-character")
(map "s:c:b" "backward-select")
(map "s:left" "backward-select")
(map-meta "f" "forward-word")
(map "a:RIGHT" "forward-word")
(map "c:RIGHT" "forward-word")
(map-meta "s:f" "forward-select-word")
(map "a:s:RIGHT" "forward-select-word")
(map "c:s:RIGHT" "forward-select-word")
(map-meta "b" "backward-word")
(map "a:LEFT" "backward-word")
(map "c:left" "backward-word")
(map-meta "s:b" "backward-select-word")
(map "a:s:LEFT" "backward-select-word")
(map "c:s:left" "backward-select-word")
(map-meta "<" "beginning-of-file")
(map "d:UP" "beginning-of-file")
(map "c:HOME" "beginning-of-file")
(map "s:c:home" "select-to-beginning-of-file")
(map "s:d:up" "select-to-beginning-of-file")
(map-meta ">" "end-of-file")
(map "d:DOWN" "end-of-file")
(map "c:end" "end-of-file")
(map "s:c:end" "select-to-end-of-file")
(map "s:d:down" "select-to-end-of-file")
(map "c:v" "next-page")
(map "a:DOWN" "next-page")
(map "pagedown" "next-page")
(map "c:DOWN" "next-page")
(map "s:c:v" "select-page-down")
(map "a:s:DOWN" "select-page-down")
(map "s:pagedown" "select-page-down")
(map "s:c:DOWN" "select-page-down")
(map-meta "v" "previous-page")
(map "a:up" "previous-page")
(map "pageup" "previous-page")
(map "c:up" "previous-page")
(map-meta "s:v" "select-page-up")
(map "s:a:up" "select-page-up")
(map "s:pageup" "select-page-up")
(map "s:c:up" "select-page-up")
(map "c:h" "delete-previous-character")
(map "c:d" "delete-next-character")
(map "del" "delete-key")
(map-meta "d" "kill-word")
(map-meta "del" "backward-kill-word")
(map-meta "c" "capitalize-word")
(map-meta "u" "upcase-word")
(map-meta "l" "downcase-word")
(map "c:l" "center-view-on-line")
(map "c:k" "delete-to-end-of-line")
(map "c:y" "paste-clipboard")
(map-meta "y" "paste-next")
(map "a:v" "paste-clipboard")
(map "d:v" "paste-clipboard")
(map "c:_" "undo")
(map "c:+" "redo")
(map "a:z" "undo")
(map "d:z" "undo")
(map "c:x;u" "undo")
(map "c:w" "cut-clipboard")
(map "a:x" "cut-clipboard")
(map "d:x" "cut-clipboard")
(map-meta "w" "copy-clipboard")
(map "a:c" "copy-clipboard")
(map "d:c" "copy-clipboard")
(map-meta "space" "collapse-space")
(map-meta "\\" "remove-space")
(map "c:x;c:o" "collapse-newline")
(map "c:o" "open-line")
(map "c:t" "transpose-chars")
(map-meta "t" "transpose-words")
(map "c:space" "toggle-anchor")
(map "insert" "toggle-overwrite")
(map-meta "o" "toggle-overwrite")
(map-meta "g" "goto-line")
(map-meta "p" "goto-position")
(map "c:u" "command-repeat-0")
(let loop ([n 9])
(unless (negative? n)
(let ([s (number->string n)])
(map-meta s (string-append "command-repeat-" s))
(loop (sub1 n)))))
(map "c:x;e" "do-saved-macro")
(map "c:x;(" "start-macro-record")
(map "c:x;)" "end-macro-record")
(map "leftbuttontriple" "select-click-line")
(map "leftbuttondouble" "select-click-word")
(map "c:x;c:c" "exit")
(map "rightbutton" "copy-click-region")
(map "rightbuttondouble" "cut-click-region")
(map "middlebutton" "paste-click-region")
(map "c:rightbutton" "copy-clipboard")))))
(define global-keymap (make-object wx:keymap%))
(setup-global-keymap global-keymap)
(define global-file-keymap (make-object wx:keymap%))
(setup-global-file-keymap global-file-keymap)
(define global-search-keymap (make-object wx:keymap%))
(setup-global-search-keymap global-search-keymap))

82
collects/mred/panel.ss
View File

@ -1,82 +0,0 @@
(unit/sig mred:panel^
(import mred:wx^
[mred:constants : mred:constants^]
[mred:container : mred:container^]
[mred:canvas : mred:canvas^]
mzlib:function^)
(mred:debug:printf 'invoke "mred:panel@")
(define make-edit-panel%
(lambda (super%)
(class-asi super%
(rename [super-change-children change-children])
(inherit get-parent change-children children)
(public [get-canvas% (lambda () mred:canvas:frame-title-canvas%)])
(public
[collapse
(lambda (canvas)
(letrec* ([media (send canvas get-media)]
[helper
(lambda (canvas/panel)
(if (eq? canvas/panel this)
(begin (cond
[(and (= (length children) 1)
(eq? canvas (car children)))
(void)]
[(member canvas children)
(change-children (lambda (l) (list canvas)))]
[else
(change-children
(lambda (l)
(let ([c (make-object (object-class canvas) this)])
(send c set-media media)
(list c))))])
(wx:bell))
(let* ([parent (send canvas/panel get-parent)]
[parents-children (ivar parent children)]
[num-children (length parents-children)])
(if (<= num-children 1)
(helper parent)
(begin (send parent delete-child canvas/panel)
(send (car (ivar parent children)) set-focus))))))])
(send media remove-canvas canvas)
(helper canvas)))]
[split
(opt-lambda (canvas [panel% mred:container:horizontal-panel%])
(let* ([frame (ivar canvas frame)]
[media (send canvas get-media)]
[canvas% (object-class canvas)]
[parent (send canvas get-parent)]
[new-panel #f]
[left-split #f]
[right-split #f]
[before #t])
(dynamic-wind
(lambda ()
(set! before (send frame delay-updates))
(send frame delay-updates #t))
(lambda ()
(set! new-panel (make-object panel% parent))
(set! left-split (make-object canvas% new-panel))
(set! right-split (make-object canvas% new-panel))
(send parent change-children
(lambda (l)
(let ([before (remq new-panel l)])
(map (lambda (x) (if (eq? x canvas)
new-panel
x))
before)))))
(lambda () (send frame delay-updates before)))
(send* media (remove-canvas canvas)
(add-canvas left-split)
(add-canvas right-split))
(send* left-split (set-media media) (set-focus))
(send* right-split (set-media media))))]))))
(define horizontal-edit-panel%
(make-edit-panel% mred:container:horizontal-panel%))
(define vertical-edit-panel%
(make-edit-panel% mred:container:vertical-panel%)))

562
collects/mred/prefs.ss
View File

@ -1,562 +0,0 @@
;; need a preference for pconvert
(unit/sig mred:preferences^
(import mred:wx^
[mred:constants : mred:constants^]
[mred:exn : mred:exn^]
[mred : mred:container^]
[mred:exit : mred:exit^]
[mred:gui-utils : mred:gui-utils^]
[mred:edit : mred:edit^]
[mzlib:pretty-print : mzlib:pretty-print^]
[mzlib:function : mzlib:function^])
(mred:debug:printf 'invoke "mred:preferences@")
(define preferences-filename (wx:find-path 'pref-file))
(define preferences (make-hash-table))
(define marshall-unmarshall (make-hash-table))
(define callbacks (make-hash-table))
(define defaults (make-hash-table))
(define-struct un/marshall (marshall unmarshall))
(define-struct marshalled (data))
(define-struct pref (value))
(define-struct default (value checker))
(define guard
(lambda (when p value thunk)
(let ([h
(lambda (x)
(let ([msg
(format "exception raised ~a for ~a with ~a: ~a~n"
when p value
(exn-message x))])
(raise (mred:exn:make-exn:during-preferences
msg
((debug-info-handler))))))])
(with-handlers ([(lambda (x) #t) h])
(thunk)))))
(define unmarshall
(lambda (p marshalled)
(let/ec k
(let* ([data (marshalled-data marshalled)]
[unmarshall-fn (un/marshall-unmarshall (hash-table-get marshall-unmarshall
p
(lambda () (k data))))])
(guard "unmarshalling" p marshalled
(lambda () (unmarshall-fn data)))))))
(define get-callbacks
(lambda (p)
(hash-table-get callbacks
p
(lambda () null))))
(define add-preference-callback
(lambda (p callback)
(hash-table-put! callbacks p (append (get-callbacks p) (list callback)))
(lambda ()
(hash-table-put!
callbacks p
(mzlib:function:remove callback
(get-callbacks p)
eq?)))))
(define check-callbacks
(lambda (p value)
(andmap (lambda (x)
(guard "calling callback" p value
(lambda () (x p value))))
(get-callbacks p))))
(define get-preference
(lambda (p)
(let ([ans (hash-table-get preferences p
(lambda ()
(raise (mred:exn:make-exn:unknown-preference
(format "attempted to get unknown preference: ~a" p)
((debug-info-handler))))))])
(cond
[(marshalled? ans)
(let* ([default-s
(hash-table-get
defaults p
(lambda ()
(error 'get-preference
"no default pref for: ~a~n"
p)))]
[default (default-value default-s)]
[checker (default-checker default-s)]
[unmarshalled (let ([unmarsh (unmarshall p ans)])
(if (checker unmarsh)
unmarsh
(begin
(printf "WARNING: ~s rejecting invalid pref ~s in favor of ~s~n"
p unmarsh default)
default)))]
[_ (mred:debug:printf 'prefs "get-preference checking callbacks: ~a to ~a"
p unmarshalled)]
[pref (if (check-callbacks p unmarshalled)
unmarshalled
default)])
(hash-table-put! preferences p (make-pref pref))
(mred:debug:printf 'prefs "get-preference.1 returning ~a as ~a"
p pref)
pref)]
[(pref? ans)
(let ([ans (pref-value ans)])
(mred:debug:printf 'prefs "get-preference.2 returning ~a as ~a"
p ans)
ans)]
[else (error 'prefs.ss "robby error.1: ~a" ans)]))))
(define set-preference
(lambda (p value)
(let* ([pref (hash-table-get preferences p (lambda () #f))])
(cond
[(pref? pref)
(mred:debug:printf 'prefs "set-preference.1 checking callbacks: ~a to ~a" p value)
(when (check-callbacks p value)
(mred:debug:printf 'prefs "set-preference.1 setting ~a to ~a"
p value)
(set-pref-value! pref value))]
[(or (marshalled? pref)
(not pref))
(mred:debug:printf 'prefs "set-preference.2 checking callbacks: ~a to ~a" p value)
(when (check-callbacks p value)
(mred:debug:printf 'prefs "set-preference.2 setting ~a to ~a"
p value)
(hash-table-put! preferences p (make-pref value)))]
[else
(error 'prefs.ss "robby error.0: ~a" pref)]))))
(define set-preference-un/marshall
(lambda (p marshall unmarshall)
(hash-table-put! marshall-unmarshall p (make-un/marshall marshall unmarshall))))
(define restore-defaults
(lambda ()
(mred:debug:printf 'prefs "setting prefs to default values")
(hash-table-for-each
defaults
(lambda (p v) (set-preference p v)))
(mred:debug:printf 'prefs "finished setting prefs to default values")))
(define set-preference-default
(lambda (p value checker)
(mred:debug:printf 'prefs "setting default value for ~a to ~a" p value)
(hash-table-get preferences p
(lambda ()
(hash-table-put! preferences p (make-pref value))))
(hash-table-put! defaults p (make-default value checker))))
;; this is here becuase exit has to come before
;; prefs.ss in the loading order.
(set-preference-default 'mred:verify-exit #t
(lambda (x)
(or (not x)
(eq? x #t))))
(define save-user-preferences
(let ([marshall-pref
(lambda (p ht-value)
(cond
[(marshalled? ht-value) (list p (marshalled-data ht-value))]
[(pref? ht-value)
(let* ([value (pref-value ht-value)]
[marshalled
(let/ec k
(guard "marshalling" p value
(lambda ()
((un/marshall-marshall
(hash-table-get marshall-unmarshall p
(lambda ()
(k value))))
value))))])
(list p marshalled))]
[else (error 'prefs.ss "robby error.2: ~a" ht-value)]))])
(lambda ()
(mred:debug:printf 'prefs "saving user preferences")
(with-handlers ([(lambda (x) #t)
(lambda (exn)
(mred:gui-utils:message-box
(format "Error saving preferences~n~a"
(exn-message exn))
"Error saving preferences"))])
(call-with-output-file preferences-filename
(lambda (p)
(mzlib:pretty-print:pretty-print
(hash-table-map preferences marshall-pref) p))
'truncate 'text))
(mred:debug:printf 'prefs "saved user preferences"))))
(mred:exit:insert-exit-callback
(lambda ()
(with-handlers ([(lambda (x) #t)
(lambda (exn)
(mred:gui-utils:message-box
(format "Error saving preferences: ~a"
(exn-message exn))
"Saving Prefs"))])
(save-user-preferences))))
(define read-user-preferences
(let ([parse-pref
(lambda (p marshalled)
(let/ec k
(let* ([ht-pref (hash-table-get preferences p (lambda () #f))]
[unmarshall-struct (hash-table-get marshall-unmarshall p (lambda () #f))])
(mred:debug:printf 'prefs "read-user-preferences; p: ~a ht-pref: ~a; marshalled: ~a"
p ht-pref marshalled)
(cond
[(and (pref? ht-pref) unmarshall-struct)
(set-preference p ((un/marshall-unmarshall unmarshall-struct) marshalled))]
;; in this case, assume that no marshalling/unmarshalling
;; is going to take place with the pref, since an unmarshalled
;; pref was already there.
[(pref? ht-pref)
(set-preference p marshalled)]
[(marshalled? ht-pref) (set-marshalled-data! ht-pref marshalled)]
[(and (not ht-pref) unmarshall-struct)
(set-preference p ((un/marshall-unmarshall unmarshall-struct) marshalled))]
[(not ht-pref)
(hash-table-put! preferences p (make-marshalled marshalled))]
[else (error 'prefs.ss "robby error.3: ~a" ht-pref)]))))])
(lambda ()
(mred:debug:printf 'prefs "reading user preferences")
(let/ec k
(when (file-exists? preferences-filename)
(let ([err
(lambda (input msg)
(wx:message-box (let* ([max-len 150]
[s1 (format "~s" input)]
[ell "..."]
[s2 (if (<= (string-length s1) max-len)
s1
(string-append (substring s1 0 (- max-len
(string-length ell)))
ell))])
(format "found bad pref: ~a~n~a" msg s2))
"Preferences"))])
(let loop ([input (with-handlers
([(lambda (exn) #t)
(lambda (exn)
(wx:message-box
(format "Error reading preferences~n~a"
(exn-message exn))
"Error reading preferences")
(k #f))])
(call-with-input-file preferences-filename
read
'text))])
(cond
[(pair? input)
(let ([err-msg
(let/ec k
(let ([first (car input)])
(unless (pair? first)
(k "expected pair of pair"))
(let ([arg1 (car first)]
[t1 (cdr first)])
(unless (pair? t1)
(k "expected pair of two pairs"))
(let ([arg2 (car t1)]
[t2 (cdr t1)])
(unless (null? t2)
(k "expected null after two pairs"))
(parse-pref arg1 arg2)
(k #f)))))])
(when err-msg
(err input err-msg)))
(loop (cdr input))]
[(null? input) (void)]
[else (err input "expected a pair")])))))
(mred:debug:printf 'prefs "read user preferences"))))
(define-struct ppanel (title container panel))
(define font-families (list "Default" "Roman" "Decorative"
"Modern" "Swiss" "Script"))
(define font-size-entry "defaultFontSize")
(define font-default-string "Default Value")
(define font-default-size 12)
(define font-section "mred")
(define build-font-entry (lambda (x) (string-append "Screen" x "__")))
(define font-file (wx:find-path 'setup-file))
(define (build-font-preference-symbol family)
(string->symbol (string-append "mred:" family)))
(let ([set-default
(lambda (build-font-entry default pred)
(lambda (family)
(let ([name (build-font-preference-symbol family)]
[font-entry (build-font-entry family)])
(set-preference-default name
default
string?)
(add-preference-callback
name
(lambda (p new-value)
(wx:write-resource
font-section
font-entry
(if (and (string? new-value)
(string=? font-default-string new-value))
""
new-value)
font-file))))))])
(for-each (set-default build-font-entry
font-default-string
string?)
font-families)
((set-default (lambda (x) x)
font-default-size
number?)
font-size-entry))
(define ppanels
(list
(make-ppanel
"General"
(lambda (parent)
(let* ([main (make-object mred:vertical-panel% parent)]
[make-check
(lambda (pref title bool->pref pref->bool)
(let* ([callback
(lambda (_ command)
(set-preference pref (bool->pref (send command checked?))))]
[pref-value (get-preference pref)]
[initial-value (pref->bool pref-value)]
[h (make-object mred:horizontal-panel% main)]
[c (make-object mred:check-box% h callback title)]
[p (make-object mred:horizontal-panel% h)])
(send c set-value initial-value)
(add-preference-callback pref
(lambda (p v)
(send c set-value (pref->bool v))))))]
[id (lambda (x) x)])
(make-check 'mred:highlight-parens "Highlight between matching parens?" id id)
(make-check 'mred:fixup-parens "Correct parens?" id id)
(make-check 'mred:paren-match "Flash paren match?" id id)
(make-check 'mred:autosaving-on? "Auto-save files?" id id)
(make-check 'mred:delete-forward? "Map delete to backspace?" not not)
(make-check 'mred:file-dialogs "Use platform-specific file dialogs?"
(lambda (x) (if x 'std 'common))
(lambda (x) (eq? x 'std)))
(make-check 'mred:verify-exit "Verify exit?" id id)
(make-check 'mred:verify-change-format "Ask before changing save format?" id id)
(make-check 'mred:auto-set-wrap? "Wordwrap editor buffers?" id id)
(make-check 'mred:show-status-line "Show status-line?" id id)
(make-check 'mred:line-offsets "Count line and column numbers from one?" id id)
(make-check 'mred:menu-bindings "Enable keybindings in menus?" id id)
(unless (eq? wx:platform 'unix)
(make-check 'mred:print-output-mode "Automatically print to postscript file?"
(lambda (b) (if b 1 0))
(lambda (n) (= n 1))))
main))
#f)
(make-ppanel
"Default Fonts"
(lambda (parent)
(let* ([main (make-object mred:vertical-panel% parent)]
[fonts (cons font-default-string (wx:get-font-list))]
[make-family-panel
(lambda (name)
(let* ([pref-sym (build-font-preference-symbol name)]
[horiz (make-object mred:horizontal-panel% main
-1 -1 -1 -1 wx:const-border)]
[label (make-object mred:message% horiz name)]
[space (make-object mred:horizontal-panel% horiz)]
[_ (make-object mred:message% horiz
(let ([b (box "")])
(if (and (wx:get-resource
font-section
(build-font-entry name)
b)
(not (string=? (unbox b)
"")))
(unbox b)
font-default-string)))]
[button
(make-object
mred:button% horiz
(lambda (button evt)
(let ([new-value
(mred:gui-utils:get-single-choice
(format "Please choose a new ~a font"
name)
"Fonts"
fonts
null -1 -1 #t 300 400)])
(unless (null? new-value)
(set-preference pref-sym
new-value))))
"Change")])
(add-preference-callback
pref-sym
(lambda (p new-value)
(send horiz change-children
(lambda (l)
(list label space
(make-object
mred:message%
horiz
new-value)
button)))))
(void)))])
(for-each make-family-panel font-families)
(let ([size-panel (make-object mred:horizontal-panel% main -1 -1 -1 -1 wx:const-border)])
'(make-object mred:message% size-panel "Size")
'(make-object mred:horizontal-panel% size-panel)
(let* ([sym (build-font-preference-symbol
font-size-entry)]
[size-slider
(make-object mred:slider% size-panel
(lambda (slider evt)
(set-preference sym
(send slider get-value)))
"Size"
(let ([b (box 0)])
(if (wx:get-resource font-section
font-size-entry
b)
(unbox b)
font-default-size))
1 127 50)])
(add-preference-callback
sym
(lambda (p value)
(unless (= value (send size-slider get-value))
(send size-slider set-value value))))))
(make-object mred:message% main
"Restart to see font changes")
main))
#f)))
(define make-run-once
(lambda ()
(let ([semaphore (make-semaphore 1)])
(lambda (t)
(dynamic-wind (lambda () (semaphore-wait semaphore))
t
(lambda () (semaphore-post semaphore)))))))
(define run-once (make-run-once))
(define preferences-dialog #f)
(define add-preference-panel
(lambda (title container)
(run-once
(lambda ()
(let ([new-ppanel (make-ppanel title container #f)])
(set! ppanels
(let loop ([ppanels ppanels])
(cond
[(null? ppanels) (list new-ppanel)]
[(string=? (ppanel-title (car ppanels))
title)
(loop (cdr ppanels))]
[else (cons (car ppanels)
(loop (cdr ppanels)))])))
(when preferences-dialog
(send preferences-dialog added-pane)))))))
(define hide-preferences-dialog
(lambda ()
(run-once
(lambda ()
(when preferences-dialog
(send preferences-dialog show #f))))))
(define show-preferences-dialog
(lambda ()
(mred:gui-utils:show-busy-cursor
(lambda ()
(run-once
(lambda ()
(save-user-preferences)
(if preferences-dialog
(send preferences-dialog show #t)
(set! preferences-dialog
(let ([cursor-off (mred:gui-utils:delay-action
2 wx:begin-busy-cursor
wx:end-busy-cursor)])
(begin0 (make-preferences-dialog)
(cursor-off)))))))))))
(define make-preferences-dialog
(lambda ()
(letrec* ([frame
(make-object (class-asi mred:frame%
(public [added-pane (lambda ()
(ensure-constructed)
(refresh-menu)
(send popup-menu set-selection (sub1 (length ppanels)))
(send single-panel active-child
(ppanel-panel (car (list-tail ppanels (sub1 (length ppanels)))))))]))
'() "Preferences")]
[panel (make-object mred:vertical-panel% frame)]
[top-panel (make-object mred:horizontal-panel% panel)]
[single-panel (make-object mred:single-panel% panel -1 -1 -1 -1 wx:const-border)]
[bottom-panel (make-object mred:horizontal-panel% panel)]
[popup-callback
(lambda (choice command-event)
(send single-panel active-child
(ppanel-panel (list-ref ppanels (send command-event get-command-int)))))]
[make-popup-menu
(lambda ()
(let ([menu (make-object mred:choice% top-panel popup-callback
"Category" -1 -1 -1 -1
(map ppanel-title ppanels))])
(send menu stretchable-in-x #f)
menu))]
[top-left (make-object mred:vertical-panel% top-panel)]
[popup-menu (make-popup-menu)]
[top-right (make-object mred:vertical-panel% top-panel)]
[ensure-constructed
(lambda ()
(for-each (lambda (ppanel)
(unless (ppanel-panel ppanel)
(let ([panel ((ppanel-container ppanel) single-panel)])
(unless (is-a? panel mred:panel%)
(error 'preferences-dialog
"expected the preference panel to be a mred:panel%. Got ~a instead~n"
panel))
(set-ppanel-panel! ppanel panel))))
ppanels)
(send single-panel change-children (lambda (l) (map ppanel-panel ppanels)))
(send single-panel active-child (ppanel-panel (car ppanels))))]
[refresh-menu
(lambda ()
(let ([new-popup (make-popup-menu)])
(send new-popup set-selection (send popup-menu get-selection))
(set! popup-menu new-popup)
(send top-panel change-children
(lambda (l) (list top-left new-popup top-right)))))]
[ok-callback (lambda args
(save-user-preferences)
(hide-preferences-dialog))]
[_1 (make-object mred:panel% bottom-panel)]
[ok-button (make-object mred:button% bottom-panel ok-callback "OK")]
[cancel-callback (lambda args
(hide-preferences-dialog)
(read-user-preferences))]
[cancel-button (make-object mred:button% bottom-panel cancel-callback "Cancel")])
(send ok-button user-min-width (send cancel-button get-width))
(send bottom-panel stretchable-in-y #f)
(send top-panel stretchable-in-y #f)
(ensure-constructed)
(send popup-menu set-selection 0)
(send frame show #t)
frame)))
(read-user-preferences))

194
man/man1/mred.1
View File

@ -1,194 +0,0 @@
\" dummy line
.TH MRED 1 "8 June 1996"
.UC 4
.SH NAME
mred \- The Rice PLT Scheme GUI engine
.SH SYNOPSIS
.B mred
[-s
.I sysfile
]
[-a
.I unit-filename
.I sig-filename
]
[-w
.I filename
]
[-p
.I image-filename
.I splash-title
.I splash-count
]
[-b ]
[-q | --no-init-file]
[-nu ]
[-f
.I file
]
[-e
.I expr
]
[--
.I arguments
]
[
.I file
]
.SH DESCRIPTION
.I MrEd
is the Rice University PLT Scheme GUI
execution engine.
It extends
.I MzScheme
with graphics
and provides the underlying architecture for
.I DrScheme.
.PP
The -s flag directs
.I MrEd
to load the startup system from
a particular file. This overrides the system directory
search path described below in FILES and must come before all other
arguments.
.PP
The -a flag directs
.I MrEd
to look in the first file for a unit/sig (not a
definition of a unit, just a plain unit) and the second file for signatures
that the unit/sig needs. That unit will be used to start a new appliaction
built on top of
.I MrEd.
See the Toolbox manual for more information on how to write your own
application using
.I MrEd.
.PP
The -w flag causes filename to be written over with a Static Debugger
file, which can be used to analyze your application. You must use the -a
flag and have written a Static Debugger conformant application to use this
flag. See the Static Debugger and the Toolbox manuals for more information
on Static Debugger conformancy and the -a flag respectively.
.PP
The -p flag specifies a splash screen filename. The splash screen must be
an image file supported by wx:bitmap% objects. See the Toolbox manual for more
information on what image types are supported by wx:bitmap% objects. The
second argument to -p names the splash screen, and the third is a count
indicating how many files will be loaded.
.PP
The -b flags supresses the splash screen.
.PP
The -q or --no-init-file flag prevents
.I MrEd
from loading
the user's startup file ".mredrc" in the user's home
directory.
.PP
multiple -f
and -e flags can be specified. For each -e flag, the corresponding
expression is evaluated. For each -f flag, the corresponding file
is loaded (with its directory as the working cirectory).
.PP
If a file appears on the command line with no switches, then it is opened
for editing in
.I MrEd.
The -- flag means to treat the next argument as a file
to be opened for editing, even if it is "-e" or "-f".
.PP
The -nu flag specifies a non-unit startup. See the Toolbox Manual for more
details on
.I MrEd's
startup and how to build your own application with
.I MrEd.
.PP
Once all command line arguments are handled the scheme procedure
mred:startup is called. This procedure is defined by the standard
system, but it can be redefined with the -f or -e flags for
application-specific startup sequences.
.PP
For further information on
.I MrEd,
please consult the on-line
documentation in the Help menu of the console
and other information available at
.PP
.ce 1
http://www.cs.rice.edu/CS/PLT/packages/mred/
.SH FILES
If the -s flag is not specified,
.I MrEd
looks for its standard system file "mrsystem.ss" with the following
search path:
.IP
* the search path defined by the MREDSYS system evironment
variable
.IP
* "$PLTHOME/mred/system"
.IP
* "/usr/local/lib/plt/mred/system"
.IP
* "/usr/lib/plt/mred/system"
.IP
* "/usr/local/lib/mred/system"
.IP
* "/usr/lib/mred/system"
.PP
The standard system finds the
.I MrEd
collections directory and loads the
.I MrEd
library. The
I. MrEd
collections directory is
"../mred/collects" relative to the system's directory.
The standard system also finds the
.I MzScheme
collection
directory and loads the core
.I MzLib
library. The
.I MzScheme
collection directory is found with
the following search path:
.IP
* "$PLTHOME/mzscheme/collects/standard" (if PLTHOME is not defined,
/usr/local/lib/ is used as it's value).
.IP
* "../mzscheme/collects/" relative to the system's directory
.IP
* "../../mzscheme/collects/standard" relative to the system's directory
.IP
.PP
The `require-library-collections-paths' parameter is set
to a list containing the
.I MzScheme
collections
directory and the
.I MrEd
collections directory.
.I MrEd
also looks for Xresources in
.IP
* "~/.mred.resources"
.PP
Xresources in that file override any other resources settings.
.SH BUGS
Submit bug reports via
.ce 1
http://www.cs.rice.edu/CS/PLT/Gnats/ (encouraged)
or by e-mail to
.ce 1
plt-bugs@cs.rice.edu (discouraged)
.SH AUTHOR
.I MrEd
was implemented by Matthew Flatt (mflatt@cs.rice.edu) and Robby Findler
(robby@cs.rice.edu) using wxWindows by Julian Smart et al. and
the conservative garbage collector by Hans Boehm et al.
.SH SEE ALSO
.BR drscheme(1),
.BR mzscheme(1)

209
man/man1/mzscheme.1
View File

@ -1,209 +0,0 @@
.\" dummy line
.TH MZSCHEME 1 "31 May 1997"
.UC 4
.SH NAME
mzscheme \- The PLT Scheme implementation
.SH SYNOPSIS
.B mzscheme
[
.I flags
] [
.I arguments
]
.SH DESCRIPTION
.I MzScheme
is the Rice University PLT
Scheme implementation. It implements the language as
described in the
.I Revised^4 Report on
.I the Algorithmic Language Scheme,
plus numerous extensions.
.I MzScheme
is the underlying implementation for
.I DrScheme
and
.I MrEd.
.SH OPTIONS
Startup file and expression switches:
.TP
.BI \-e \ expr
Evaluates
.I expr
after
.I MzScheme
starts.
.TP
.BI \-f \ file
Loads
.I file
after
.I MzScheme
starts.
.TP
.BI \-d \ file
Load/cds
.I file
after
.I MzScheme
starts.
.TP
.B \-F
.br
Loads all remaining arguments after
.I MzScheme
starts.
.TP
.B \-D
.br
Load/cds all remaining arguments after
.I MzScheme
starts.
.TP
.B \-l \ file
Same as -e '(require-library "file")'.
.TP
.B \-r, --script
Script mode: use as last flag for scripts.
Same as -fmv-.
.TP
.B \-i, --script-cd
Like -r, but also sets the directory.
Same as -dmv-.
.TP
.B \-w, --awk
Same as -l awk.ss.
.PP
Initialization switches:
.TP
.B \-x, --no-lib-path
Does not try to set current-library-collection-paths.
.TP
.B \-q, --no-init-file
Does not try to load "~/.mzschemerc".
.PP
Language setting switches:
.TP
.B \-g, --case-sens
Identifiers and symbols are initially case-sensitive.
.TP
.B \-c, --esc-cont
Call/cc is replaced with call/ec.
.TP
.B \-k, --const-globs
Builtin globals are constant.
.TP
.B \-s, --set-undef
Set! works on undefined identifiers.
.TP
.B \-a, --no-auto-else
Fall-through cond or case is an error.
.TP
.B \-n, --no-key
Keywords are not enforced.
.TP
.B \-y, --hash-percent-syntax
Only #% syntactic forms are present.
.TP
.B \-p, --persistent
Catches AIX SIGDANGER (low page space) signal. (AIX only)
.PP
Miscellaneous switches:
.TP
.B \--
.br
No argument following this switch is used as a switch.
.TP
.B \-m, --mute-banner
Suppresses the startup banner.
.TP
.B \-v, --version
Suppresses the read-eval-print loop.
.TP
.B \-h, --help
Shows help for command-line arguments.
.TP
.BI \-R file, --restore \ file
Restores an image; must be the only switch.
.PP
Multiple single-letter switches can be collapsed, with arguments placed
after the collapsed switches; the first collapsed switch cannot be --.
E.g.: `-vfme file expr' is the same as `-v -f file -m -e expr'.
.PP
Extra arguments following the last switch are put into the Scheme global
variable `argv' as a vector of strings. The name used to start
.I MzScheme
is put into the global variable `program' as a string.
.PP
Extra arguments after a `--restore' file are returned as a vector of
strings to the continuation of the `write-image-to-file' call that created
the image.
.PP
Expressions/files are evaluated/loaded in order as provided.
.PP
The current-library-collections-path is automatically set before any
expressions/files are evaluated/loaded, unless the -x or --no-lib-path
switch is used.
.PP
.PP
For further information on
.I MzScheme,
please consult the on-line
documentation and other information available at
.PP
.ce 1
http://www.cs.rice.edu/CS/PLT/packages/mzscheme/
.SH FILES
The file "~/.mzschemerc" is loaded before any provided
expressions/files are evaluated/loaded, unless the -q or
--no-init-file switch is used. (Under Windows and MacOS, "mzscheme.rc"
is loaded from the start-up working directory.)
.PP
.I MzScheme
looks for the library collections directory using the
following search path:
.IP
If
.I MzScheme
was invoked with an absolute pathname, the directory
of the invoked executable is checked. If the executable
is a link, the directory of the referenced file is also
checked, recursively following links.
.IP
If
.I MzScheme
is invoked with a relative pathname, the
directories in the PATH environment variable containing
a file with the name of the program as invoked (usually
"mzscheme") are checked. Links are followed as in the
first case.
.IP
The path in the environment variable MZCOLS is tried.
.IP
The path in the environment variable PLTHOME is checked
for a "mzscheme" and then "collects" subdirectory.
.IP
The "/usr/local/lib/plt/mzscheme/collects" directory is
tried.
.PP
Please consult your local administrator to determine whether
the on-line documentation has been installed locally.
.SH BUGS
Submit bug reports via
.ce 1
http://www.cs.rice.edu/CS/PLT/Gnats/ (encouraged)
or by e-mail to
.ce 1
plt-bugs@cs.rice.edu (discouraged)
.SH AUTHOR
.I MzScheme
was implemented by Matthew Flatt (mflatt@cs.rice.edu).
It uses the conservative garbage collector implemented by Hans
Boehm and extended by John Ellis. MzScheme was originally based
on libscheme, written by Brent Benson.
.SH SEE ALSO
.BR drscheme(1),
.BR mred(1)