/[mcclim]/mcclim/text-editor-gadget.lisp
ViewVC logotype

Contents of /mcclim/text-editor-gadget.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.13 - (show annotations)
Sun Jun 14 18:33:45 2009 UTC (4 years, 10 months ago) by ahefner
Branch: MAIN
CVS Tags: HEAD
Changes since 1.12: +1 -1 lines
Fix :fixed text style choice.
1 ;;; -*- Mode: Lisp; Package: CLIM-INTERNALS -*-
2
3 ;;; (c) copyright 2000 by
4 ;;; Arthur Lemmens (lemmens@simplex.nl),
5 ;;; Iban Hatchondo (hatchond@emi.u-bordeaux.fr)
6 ;;; and Julien Boninfante (boninfan@emi.u-bordeaux.fr)
7 ;;; (c) copyright 2001 by
8 ;;; Lionel Salabartan (salabart@emi.u-bordeaux.fr)
9 ;;; (c) copyright 2001 by Michael McDonald (mikemac@mikemac.com)
10 ;;; (c) copyright 2001 by Gilbert Baumann <unk6@rz.uni-karlsruhe.de>
11 ;;; (c) copyright 2006 by Troels Henriksen (athas@sigkill.dk)
12
13 ;;; This library is free software; you can redistribute it and/or
14 ;;; modify it under the terms of the GNU Library General Public
15 ;;; License as published by the Free Software Foundation; either
16 ;;; version 2 of the License, or (at your option) any later version.
17 ;;;
18 ;;; This library is distributed in the hope that it will be useful,
19 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
20 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
21 ;;; Library General Public License for more details.
22 ;;;
23 ;;; You should have received a copy of the GNU Library General Public
24 ;;; License along with this library; if not, write to the
25 ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
26 ;;; Boston, MA 02111-1307 USA.
27
28 ;;; This file contains the concrete implementation of the text-field
29 ;;; and text-editor gadgets. It is loaded rather late, because it
30 ;;; requires Drei. Half of the complexity here is about working around
31 ;;; annoying Goatee quirks, generalising it to three editor substrates
32 ;;; is nontrivial.
33
34 (in-package :clim-internals)
35
36 ;;; The text editor gadget(s) is implemented as a class implementing
37 ;;; the text editor gadget protocol, but containing an editor
38 ;;; substrate object that takes care of the actual editing logic,
39 ;;; redisplay, etc. The substrates need to be gadgets themselves and
40 ;;; are defined here.
41
42 (defparameter *default-text-field-text-style*
43 (make-text-style :fix :roman :normal))
44
45 (defclass editor-substrate-mixin (value-gadget)
46 ((activation-gestures :reader activation-gestures
47 :initarg :activation-gestures)
48 (user :reader user-gadget
49 :initarg :user-gadget
50 :documentation "The editor gadget using this editor substrate."
51 :initform (error "Editor substrates must have a user.")))
52 (:documentation "A mixin class for text editor gadget substrates.")
53 (:default-initargs :activation-gestures '()))
54
55 (defmethod gadget-id ((gadget editor-substrate-mixin))
56 (gadget-id (user-gadget gadget)))
57
58 (defmethod (setf gadget-id) (value (gadget editor-substrate-mixin))
59 (setf (gadget-id (user-gadget gadget)) value))
60
61 (defmethod gadget-client ((gadget editor-substrate-mixin))
62 (gadget-client (user-gadget gadget)))
63
64 (defmethod (setf gadget-client) (value (gadget editor-substrate-mixin))
65 (setf (gadget-client (user-gadget gadget)) value))
66
67 (defmethod gadget-armed-callback ((gadget editor-substrate-mixin))
68 (gadget-armed-callback (user-gadget gadget)))
69
70 (defmethod gadget-disarmed-callback ((gadget editor-substrate-mixin))
71 (gadget-disarmed-callback (user-gadget gadget)))
72
73 (defclass text-field-substrate-mixin (editor-substrate-mixin)
74 ()
75 (:documentation "A mixin class for editor substrates used for text field gadgets."))
76
77 (defclass text-editor-substrate-mixin (editor-substrate-mixin)
78 ((ncolumns :reader text-editor-ncolumns
79 :initarg :ncolumns
80 :initform nil
81 :type (or null integer))
82 (nlines :reader text-editor-nlines
83 :initarg :nlines
84 :initform nil
85 :type (or null integer)))
86 (:documentation "A mixin class for editor substrates used for text editor gadgets."))
87
88 ;;; Now, define the Drei substrate.
89
90 (defclass drei-editor-substrate (drei:drei-gadget-pane
91 editor-substrate-mixin)
92 ()
93 (:metaclass esa-utils:modual-class)
94 (:documentation "A class for Drei-based editor substrates."))
95
96 (defmethod (setf gadget-value) :after (value (gadget drei-editor-substrate)
97 &key invoke-callback)
98 (declare (ignore invoke-callback))
99 ;; Hm! I wonder if this can cause trouble. I think not.
100 (drei:display-drei gadget))
101
102 (defclass drei-text-field-substrate (text-field-substrate-mixin
103 drei-editor-substrate)
104 ()
105 (:metaclass esa-utils:modual-class)
106 (:documentation "The class for Drei-based text field substrates."))
107
108 (defmethod drei:handle-gesture ((drei drei-text-field-substrate) gesture)
109 (if (with-activation-gestures ((activation-gestures drei))
110 (activation-gesture-p gesture))
111 (activate-callback drei (gadget-client drei) (gadget-id drei))
112 (call-next-method)))
113
114 (defmethod compose-space ((pane drei-text-field-substrate) &key width height)
115 (declare (ignore width height))
116 (with-sheet-medium (medium pane)
117 (let ((as (text-style-ascent (medium-text-style medium) medium))
118 (ds (text-style-descent (medium-text-style medium) medium))
119 (w (text-size medium (gadget-value pane))))
120 (let ((width w)
121 (height (+ as ds)))
122 (make-space-requirement :height height :max-height height :min-height height
123 :min-width width :width width)))))
124
125 (defclass drei-text-editor-substrate (text-editor-substrate-mixin
126 drei-editor-substrate)
127 ()
128 (:metaclass esa-utils:modual-class)
129 (:documentation "The class for Drei-based text editor substrates."))
130
131 (defmethod compose-space ((pane drei-text-editor-substrate) &key width height)
132 (with-sheet-medium (medium pane)
133 (let* ((text-style (medium-text-style medium))
134 (line-height (+ (text-style-height text-style medium)
135 (stream-vertical-spacing pane)))
136 (column-width (text-style-width text-style medium)))
137 (with-accessors ((ncolumns text-editor-ncolumns)
138 (nlines text-editor-nlines)) pane
139 (apply #'space-requirement-combine* #'(lambda (req1 req2)
140 (or req2 req1))
141 (call-next-method)
142 (let ((width (if ncolumns
143 (+ (* ncolumns column-width))
144 width))
145 (height (if nlines
146 (+ (* nlines line-height))
147 height)))
148 (list
149 :width width :max-width width :min-width width
150 :height height :max-height height :min-height height)))))))
151
152 (defmethod allocate-space ((pane drei-text-editor-substrate) w h)
153 (resize-sheet pane w h))
154
155 ;;; Now, define the Goatee substrate.
156
157 (defclass goatee-editor-substrate (editor-substrate-mixin
158 text-field
159 clim-stream-pane)
160 ((area :accessor area
161 :initform nil
162 :documentation "The Goatee area used for text editing.")
163 ;; This hack is necessary because the Goatee editing area is not
164 ;; created until the first redisplay... yuck.
165 (value :documentation "The initial value for the Goatee area."))
166 (:default-initargs
167 :text-style *default-text-field-text-style*))
168
169 (defmethod initialize-instance :after ((pane goatee-editor-substrate) &rest rest)
170 (declare (ignore rest))
171 (setf (medium-text-style (sheet-medium pane))
172 (slot-value pane 'text-style)))
173
174 ;; Is there really a benefit to waiting until the first painting to
175 ;; create the goatee instance? Why not use INITIALIZE-INSTANCE?
176 (defmethod handle-repaint :before ((pane goatee-editor-substrate) region)
177 (declare (ignore region))
178 (unless (area pane)
179 (multiple-value-bind (cx cy)
180 (stream-cursor-position pane)
181 (setf (cursor-visibility (stream-text-cursor pane)) nil)
182 (setf (area pane) (make-instance 'goatee:simple-screen-area
183 :area-stream pane
184 :x-position cx
185 :y-position cy
186 :initial-contents (slot-value pane 'value))))
187 (stream-add-output-record pane (area pane))))
188
189 ;;; This implements click-to-focus-keyboard-and-pass-click-through
190 ;;; behaviour.
191 (defmethod handle-event :before
192 ((gadget goatee-editor-substrate) (event pointer-button-press-event))
193 (let ((previous (stream-set-input-focus gadget)))
194 (when (and previous (typep previous 'gadget))
195 (disarmed-callback previous (gadget-client previous) (gadget-id previous)))
196 (armed-callback gadget (gadget-client gadget) (gadget-id gadget))))
197
198 (defmethod armed-callback :after ((gadget goatee-editor-substrate) client id)
199 (declare (ignore client id))
200 (handle-repaint gadget +everywhere+) ;FIXME: trigger initialization
201 (let ((cursor (cursor (area gadget))))
202 (letf (((cursor-state cursor) nil))
203 (setf (cursor-appearance cursor) :solid))))
204
205 (defmethod disarmed-callback :after ((gadget goatee-editor-substrate) client id)
206 (declare (ignore client id))
207 (handle-repaint gadget +everywhere+) ;FIXME: trigger initialization
208 (let ((cursor (cursor (area gadget))))
209 (letf (((cursor-state cursor) nil))
210 (setf (cursor-appearance cursor) :hollow))))
211
212 (defmethod handle-event
213 ((gadget goatee-editor-substrate) (event key-press-event))
214 (let ((gesture (convert-to-gesture event))
215 (*activation-gestures* (activation-gestures gadget)))
216 (when (activation-gesture-p gesture)
217 (activate-callback gadget (gadget-client gadget) (gadget-id gadget))
218 (return-from handle-event t))
219 (goatee:execute-gesture-command gesture
220 (area gadget)
221 goatee::*simple-area-gesture-table*)
222 (let ((new-value (goatee::buffer-string (goatee::buffer (area gadget)))))
223 (unless (string= (gadget-value gadget) new-value)
224 (setf (slot-value gadget 'value) new-value)
225 (value-changed-callback gadget
226 (gadget-client gadget)
227 (gadget-id gadget)
228 new-value)))))
229
230 (defmethod (setf gadget-value) :after (new-value (gadget goatee-editor-substrate)
231 &key invoke-callback)
232 (declare (ignore invoke-callback))
233 (let* ((area (area gadget))
234 (buffer (goatee::buffer area))
235 (start (goatee::buffer-start buffer))
236 (end (goatee::buffer-end buffer)))
237 (goatee::delete-region buffer start end)
238 (goatee::insert buffer new-value :position start)
239 (goatee::redisplay-area area)))
240
241 #+nil
242 (defmethod handle-repaint ((pane goatee-editor-substrate) region)
243 (declare (ignore region))
244 (with-special-choices (pane)
245 (with-sheet-medium (medium pane)
246 (multiple-value-bind (x1 y1 x2 y2) (bounding-rectangle* (sheet-region pane))
247 (display-gadget-background pane (gadget-current-color pane) 0 0 (- x2 x1) (- y2 y1))
248 (draw-text* pane (gadget-value pane)
249 x1
250 (+ y1 (text-style-ascent (medium-text-style medium) medium))
251 :align-x :left
252 :align-y :baseline)))))
253
254 (defclass goatee-text-field-substrate (text-field-substrate-mixin
255 goatee-editor-substrate)
256 ()
257 (:documentation "The class for Goatee-based text field substrates."))
258
259 (defmethod compose-space ((pane goatee-text-field-substrate) &key width height)
260 (declare (ignore width height))
261 (with-sheet-medium (medium pane)
262 (let ((as (text-style-ascent (medium-text-style medium) medium))
263 (ds (text-style-descent (medium-text-style medium) medium))
264 (w (text-size medium (gadget-value pane))))
265 (let ((width w)
266 (height (+ as ds)))
267 (make-space-requirement :width width :height height
268 :max-width width :max-height height
269 :min-width width :min-height height)))))
270
271 (defclass goatee-text-editor-substrate (text-editor-substrate-mixin
272 goatee-editor-substrate)
273 ()
274 (:documentation "The class for Goatee-based text field substrates."))
275
276 (defmethod compose-space ((pane goatee-text-editor-substrate) &key width height)
277 (with-sheet-medium (medium pane)
278 (let* ((text-style (medium-text-style medium))
279 (line-height (+ (text-style-height text-style medium)
280 (stream-vertical-spacing pane)))
281 (column-width (text-style-width text-style medium)))
282 (with-accessors ((ncolumns text-editor-ncolumns)
283 (nlines text-editor-nlines)) pane
284 (apply #'space-requirement-combine* #'(lambda (req1 req2)
285 (or req2 req1))
286 (call-next-method)
287 (let ((width (if ncolumns
288 (+ (* ncolumns column-width))
289 width))
290 (height (if nlines
291 (+ (* nlines line-height))
292 height)))
293 (list :width width :max-width width :min-width width
294 :height height :max-height height :min-height height)))))))
295
296 (defmethod allocate-space ((pane goatee-text-editor-substrate) w h)
297 (resize-sheet pane w h))
298
299 (defun make-text-field-substrate (user &rest args)
300 "Create an appropriate text field gadget editing substrate object."
301 (let* ((substrate (apply #'make-pane (if *use-goatee*
302 'goatee-text-field-substrate
303 'drei-text-field-substrate)
304 :user-gadget user args))
305 (sheet substrate))
306 (values substrate sheet)))
307
308 (defun make-text-editor-substrate (user &rest args &key scroll-bars value
309 &allow-other-keys)
310 "Create an appropriate text editor gadget editing substrate
311 object. Returns two values, the first is the substrate object,
312 the second is the sheet that should be adopted by the user
313 gadget."
314 (let* ((minibuffer (when (and (not *use-goatee*) scroll-bars)
315 (make-pane 'drei::drei-minibuffer-pane)))
316 (substrate (apply #'make-pane (if *use-goatee*
317 'goatee-text-editor-substrate
318 'drei-text-editor-substrate)
319 :user-gadget user
320 :minibuffer minibuffer args))
321 (sheet (if scroll-bars
322 (scrolling (:scroll-bars scroll-bars)
323 substrate)
324 substrate)))
325 (if *use-goatee*
326 (setf (slot-value substrate 'value) value)
327 (setf (gadget-value substrate) value))
328 (values substrate (if minibuffer
329 (vertically ()
330 sheet
331 minibuffer)
332 sheet))))
333
334 ;;; The class for using these substrates in the gadgets.
335
336 (defclass editor-substrate-user-mixin (value-gadget)
337 ((substrate :accessor substrate
338 :documentation "The editing substrate used for this
339 text field."))
340 (:documentation "A mixin class for creating gadgets using
341 editor substrates."))
342
343 (defmethod gadget-value ((gadget editor-substrate-user-mixin))
344 (gadget-value (substrate gadget)))
345
346 (defmethod (setf gadget-value) (value (gadget editor-substrate-user-mixin)
347 &key invoke-callback)
348 (declare (ignore invoke-callback))
349 (setf (gadget-value (substrate gadget)) value))
350
351 ;;; ------------------------------------------------------------------------------------------
352 ;;; 30.4.8 The concrete text-field Gadget
353
354 (defclass text-field-pane (text-field
355 vrack-pane editor-substrate-user-mixin)
356 ((activation-gestures :accessor activation-gestures
357 :initarg :activation-gestures
358 :documentation "A list of gestures that
359 cause the activate callback to be called."))
360 (:default-initargs
361 :activation-gestures *standard-activation-gestures*))
362
363 (defmethod initialize-instance :after ((object text-field-pane)
364 &key id client armed-callback
365 disarmed-callback
366 activation-gestures activate-callback
367 value value-changed-callback)
368 ;; Make an editor substrate object for the gadget.
369 (let ((substrate (make-text-field-substrate
370 object :id id :client client :armed-callback armed-callback
371 :disarmed-callback disarmed-callback
372 :activation-gestures activation-gestures
373 :activate-callback activate-callback
374 :value value
375 :value-changed-callback value-changed-callback)))
376 (setf (substrate object) substrate)
377 (sheet-adopt-child object substrate)))
378
379 ;;; ------------------------------------------------------------------------------------------
380 ;;; 30.4.9 The concrete text-editor Gadget
381
382 (defclass text-editor-pane (text-editor
383 vrack-pane editor-substrate-user-mixin)
384 ()
385 (:default-initargs :activation-gestures '()))
386
387 (defmethod initialize-instance :after ((object text-editor-pane)
388 &key id client armed-callback
389 disarmed-callback
390 activation-gestures scroll-bars
391 ncolumns nlines value)
392 ;; Make an editor substrate object for the gadget.
393 (multiple-value-bind (substrate sheet)
394 (make-text-editor-substrate object
395 :id id :client client :armed-callback armed-callback
396 :disarmed-callback disarmed-callback
397 :activation-gestures activation-gestures
398 :scroll-bars scroll-bars
399 :ncolumns ncolumns :nlines nlines
400 :value value)
401 (setf (substrate object) substrate)
402 (sheet-adopt-child object sheet)))

  ViewVC Help
Powered by ViewVC 1.1.5