1 2;; Simple editor implementation; provides new-text-frame 3;; and new-pasteboard-frame 4 5(module edit mzscheme 6 (require mzlib/class 7 mred 8 mzlib/etc) 9 10 (provide new-text-frame 11 new-pasteboard-frame 12 new-frame) 13 14 (define (new-text-frame file) (new-frame text% file)) 15 (define (new-pasteboard-frame file) (new-frame pasteboard% file)) 16 17 (define new-frame 18 (opt-lambda (editor% file [editor-canvas% editor-canvas%]) 19 (define f (make-object (class frame% 20 (inherit modified) 21 (define/augment (can-close?) 22 (and (or (not (modified)) 23 (let ([r (message-box/custom 24 "Editor Modified" 25 "The editor has been modified. Really close it?" 26 "Close" 27 "Cancel" 28 "Save and Close" 29 this 30 '(default=2 disallow-close))]) 31 (or (and (= r 3) 32 (send e save-file)) 33 (= r 1)))) 34 (inner #t can-close?))) 35 (super-new)) 36 "MrEdIt" #f 620 450)) 37 (define c (make-object editor-canvas% f)) 38 (send c set-scroll-via-copy #t) 39 (define e (make-object (class editor% 40 (define/override (set-modified mod?) 41 (send f modified mod?) 42 (super set-modified mod?)) 43 (super-new)))) 44 (define mb (make-object menu-bar% f)) 45 46 (define file-menu (make-object menu% "File" mb)) 47 (define edit-menu (make-object menu% "Edit" mb)) 48 (define font-menu (make-object menu% "Font" mb)) 49 (define para-menu (make-object menu% "Paragraph" mb)) 50 51 (make-object menu-item% "New Text Frame" file-menu 52 (lambda (item event) 53 (new-text-frame #f)) 54 #\N) 55 (make-object menu-item% "New Pasteboard Frame" file-menu 56 (lambda (item event) 57 (new-pasteboard-frame #f))) 58 59 (make-object menu-item% "Open..." file-menu 60 (lambda (item event) 61 (send e load-file "")) 62 #\O) 63 (make-object menu-item% "Save As..." file-menu 64 (lambda (item event) 65 (send e save-file "")) 66 #\S) 67 (when (eq? editor% text%) 68 (make-object menu-item% "Save As Text..." file-menu 69 (lambda (item event) 70 (send e save-file "" 'text)))) 71 (make-object separator-menu-item% file-menu) 72 (when (can-get-page-setup-from-user?) 73 (make-object menu-item% "Page Setup..." file-menu 74 (lambda (item event) 75 (let ([s (get-page-setup-from-user #f f)]) 76 (when s 77 (send (current-ps-setup) copy-from s)))) 78 #\P 79 #f void 80 (cons 'shift (get-default-shortcut-prefix)))) 81 (make-object menu-item% "Print..." file-menu 82 (lambda (item event) 83 (send e print)) 84 #\P) 85 (make-object separator-menu-item% file-menu) 86 (make-object menu-item% "Close" file-menu 87 (lambda (item event) 88 (when (send f can-close?) 89 (send f on-close) 90 (send f show #f))) 91 #\Q) 92 93 (append-editor-operation-menu-items edit-menu #f) 94 (when (eq? editor% text%) 95 (make-object separator-menu-item% edit-menu) 96 (make-object checkable-menu-item% "Wrap Lines" edit-menu 97 (lambda (item event) 98 (send e auto-wrap (send item is-checked?))))) 99 100 (append-editor-font-menu-items font-menu) 101 (let ([m (make-object menu% "Smoothing" font-menu)]) 102 (let ([mk (lambda (name v) 103 (make-object menu-item% name m 104 (lambda (i e) 105 (let* ([o (send f get-edit-target-object)]) 106 (and o 107 (o . is-a? . editor<%>) 108 (send o change-style 109 (make-object style-delta% 'change-smoothing v)))))))]) 110 (mk "Default" 'default) 111 (mk "Partly Smoothed" 'partly-smoothed) 112 (mk "Smoothed" 'smoothed) 113 (mk "Not Smoothed" 'unsmoothed))) 114 115 (make-object menu-item% "Set Margins..." para-menu 116 (lambda (i ev) 117 (let* ([d (make-object dialog% "Margins" f)] 118 [mk-txt (lambda (label) (make-object 119 text-field% 120 label 121 d 122 void 123 "0.0"))] 124 [first-left (mk-txt "First Left")] 125 [rest-left (mk-txt "Rest Left")] 126 [right (mk-txt "Right")] 127 [button-panel (new horizontal-pane% 128 [parent d] 129 [alignment '(right center)])] 130 [ok (make-object button% "Ok" button-panel 131 (lambda (b ev) 132 (let* ([get (lambda (field) 133 (let ([n (string->number (send field get-value))]) 134 (and n (real? n) (not (negative? n)) n)))] 135 [first-left (get first-left)] 136 [rest-left (get rest-left)] 137 [right (get right)]) 138 (if (and first-left 139 rest-left 140 right) 141 (let ([start (send e position-paragraph 142 (send e get-start-position))] 143 [end (send e position-paragraph 144 (send e get-end-position))]) 145 (let loop ([i start]) 146 (unless (i . > . end) 147 (send e set-paragraph-margins 148 i first-left rest-left right) 149 (loop (add1 i))) 150 (send d show #f))) 151 (bell)))) 152 '(border))] 153 [cancel (make-object button% "Cancel" button-panel 154 (lambda (b e) 155 (send d show #f)))]) 156 (send d show #t)))) 157 158 ((current-text-keymap-initializer) (send e get-keymap)) 159 (send c set-editor e) 160 161 (when file 162 (if (regexp-match "[.](gif|bmp|jpe?g|xbm|xpm|png)$" (string-downcase file)) 163 (send e insert (make-object image-snip% file)) 164 (send e load-file file))) 165 166 (send e set-max-undo-history 'forever) 167 168 (send f show #t) 169 f))) 170