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