From 558a3464f14492498feef6917e0c7b56b08d32cd Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Fri, 1 Nov 1996 17:12:12 +0000 Subject: [PATCH] added connections original commit: d7e01eee7b44b76345cc32b58356743ca0e853f2 --- collects/mred/edit.ss | 48 ++++++++------------------------------ collects/mred/keys.ss | 11 ++++++++- collects/mred/panel.ss | 52 ++++++++++++++++++++++-------------------- collects/mred/prefs.ss | 10 ++++---- 4 files changed, 53 insertions(+), 68 deletions(-) diff --git a/collects/mred/edit.ss b/collects/mred/edit.ss index ebce5bd6..5febb020 100644 --- a/collects/mred/edit.ss +++ b/collects/mred/edit.ss @@ -1,6 +1,8 @@ + (define mred:edit@ (unit/sig mred:edit^ (import [mred:debug : mred:debug^] + [mred:connections : mred:connections^] [mred:finder : mred:finder^] [mred:path-utils : mred:path-utils^] [mred:mode : mred:mode^] @@ -18,11 +20,13 @@ (define-struct range (start end b/w-bitmap color)) (define-struct rectangle (left top width height b/w-bitmap color)) + (mred:preferences:set-preference-default 'mred:auto-set-wrap? #f) + (define make-std-buffer% (lambda (buffer%) (class buffer% args (sequence (mred:debug:printf 'creation "creating a buffer")) - (inherit modified? get-filename save-file + (inherit modified? get-filename save-file canvases get-max-width get-admin) (rename [super-set-filename set-filename] @@ -52,18 +56,13 @@ v '())))] - [auto-set-wrap? #f] + [auto-set-wrap? (mred:preferences:get-preference 'mred:auto-set-wrap?)] [set-auto-set-wrap (lambda (v) (mred:debug:printf 'rewrap "set-auto-set-wrap: ~a~n" v) (set! auto-set-wrap? v) (rewrap))] - [active-canvas #f] - [set-active-canvas - (lambda (c) - (set! active-canvas c))] - [rewrap (let ([do-wrap (lambda (new-width) @@ -93,14 +92,6 @@ 0 canvases))) (do-wrap -1))))] - [canvases '()] - [add-canvas - (lambda (canvas) - (set! canvases (cons canvas canvases)))] - [remove-canvas - (lambda (canvas) - (set! canvases (mzlib:function:remove canvas canvases)))] - [mode #f] [set-mode (lambda (m) @@ -170,25 +161,7 @@ (let ([back-name (mred:path-utils:generate-backup-name name)]) (unless (file-exists? back-name) (rename-file name back-name)))) - #t)))] - - [get-canvas - (lambda () - (cond - [(and active-canvas - (member active-canvas canvases)) - active-canvas] - [(null? canvases) #f] - [else (car canvases)]))] - [get-frame - (lambda () - (let ([c (get-canvas)]) - (if c - (let ([f (ivar c frame)]) - (if (null? f) - #f - f)) - #f)))]) + #t)))]) (sequence (apply super-init args))))) @@ -234,7 +207,7 @@ [super-after-set-size-constraint after-set-size-constraint]) (private [styles-fixed-edit-modified? #f] - [restore-file-format void]) ; the function void, not # + [restore-file-format void]) (public [on-save-file (let ([has-non-text-snips @@ -515,8 +488,7 @@ (mred:keymap:set-keymap-implied-shifts keymap) (send keymap chain-to-keymap mred:keymap:global-keymap #f)))))) - (define edit% (make-edit% wx:media-edit%)) + (define edit% (make-edit% mred:connections:connections-media-edit%)) (define make-pasteboard% make-std-buffer%) - - (define pasteboard% (make-pasteboard% wx:media-pasteboard%)))) + (define pasteboard% (make-pasteboard% mred:connections:connections-media-pasteboard%)))) diff --git a/collects/mred/keys.ss b/collects/mred/keys.ss index 38be6ecf..e7989d7e 100644 --- a/collects/mred/keys.ss +++ b/collects/mred/keys.ss @@ -647,7 +647,11 @@ (if (mred:preferences:get-preference 'mred:delete-forward?) "delete-next-character" "delete-previous-character") - edit event #t)))]) + 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) @@ -668,6 +672,8 @@ (wx:add-media-pasteboard-functions kmap) ; Map names to keyboard functions + (add "toggle-overwrite" toggle-overwrite) + (add "rcs" rcs) (add "exit" (lambda (edit event) @@ -873,6 +879,9 @@ (map "c:space" "toggle-anchor") + (map "insert" "toggle-overwrite") + (map-meta "o" "toggle-overwrite") + (map-meta "g" "goto-line") (map-meta "p" "goto-position") diff --git a/collects/mred/panel.ss b/collects/mred/panel.ss index 014c6e20..46c2b72a 100644 --- a/collects/mred/panel.ss +++ b/collects/mred/panel.ss @@ -12,7 +12,7 @@ (class-asi super% (rename [super-change-children change-children]) (inherit children get-parent) - (public [get-canvas% (lambda () mred:canvas:editor-canvas%)]) + (public [get-canvas% (lambda () mred:canvas:frame-title-canvas%)]) (private [edit-mapping (make-hash-table)] [bind @@ -30,7 +30,6 @@ p))]) (hash-table-get edit-mapping child add-new)) child))]) - (public ; this contains the edits and panels that are children of @@ -38,7 +37,6 @@ ; necessarily immediate children, since they may be split. [actual-children null] - [collapse (lambda (canvas) (letrec* ([media (send canvas get-media)] @@ -60,30 +58,34 @@ [split (opt-lambda (canvas [panel% mred:container:horizontal-panel%]) - (let ([frame (ivar canvas frame)]) + (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]) (dynamic-wind (lambda () (send frame set-perform-updates #f)) - (lambda () (letrec* ([media (send canvas get-media)] - [canvas% (object-class canvas)] - [parent (send canvas get-parent)] - [new-panel (make-object panel% parent)] - [left-split (make-object canvas% new-panel)] - [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)))) - (send* media (remove-canvas canvas) - (add-canvas left-split) - (add-canvas right-split)) - (send* left-split (set-media media) (set-frame frame) (set-focus)) - (send* right-split (set-media media) (set-frame frame)) - (when (eq? this parent) - (bind media new-panel)))) - (lambda () (send frame set-perform-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 set-perform-updates #t))) + (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)) + (when (eq? this parent) + (bind media new-panel))))] [change-children (lambda (f) (let ([new-children (f actual-children)]) diff --git a/collects/mred/prefs.ss b/collects/mred/prefs.ss index 04899826..96bfd175 100644 --- a/collects/mred/prefs.ss +++ b/collects/mred/prefs.ss @@ -15,10 +15,11 @@ (mred:debug:printf 'invoke "mred:preferences@") (define preferences-filename - (case wx:platform - [(unix) (build-path (expand-path "~") ".mred.prefs")] - [(macintosh) "MrEd Preferences"] - [else "mred.pre"])) ;; windows + (build-path (wx:find-directory 'pref) + (case wx:platform + [(unix) ".mred.prefs"] + [(macintosh) "MrEd Preferences"] + [else "mred.pre"]))) (define preferences (make-hash-table)) (define marshall-unmarshall (make-hash-table)) @@ -237,6 +238,7 @@ (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) main))))) (define make-run-once