/[mcclim]/mcclim/Doc/Guided-Tour/draw-frame.lisp
ViewVC logotype

Contents of /mcclim/Doc/Guided-Tour/draw-frame.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.2 - (show annotations)
Thu Feb 9 13:20:38 2006 UTC (8 years, 2 months ago) by cfruhwirth
Branch: MAIN
CVS Tags: mcclim-0-9-4, McCLIM-0-9-5, McCLIM-0-9-4, McCLIM-0-9-6, McCLIM-0-9-3, McCLIM-0-9-2, HEAD
Changes since 1.1: +1 -1 lines
* Incorporate suggestions from Christophe Rhodes & Luis Oliveira.
* Parenthesis error in draw-frame.
1 (eval-when (:compile-toplevel)
2 (asdf:oos 'asdf:load-op :clim)
3 (asdf:oos 'asdf:load-op :clim-clx))
4 (in-package :clim-user)
5
6 ; LTAG-start:draw-frame-def-app
7 (define-application-frame draw-frame ()
8 ((lines :accessor lines :initform nil) ;; lines of drawing
9 (strings :accessor strings :initform nil)) ;; texts of drawing
10 (:panes (draw-pane (make-pane 'draw-pane))
11 (interactor :interactor))
12 (:layouts (default-default (vertically ()
13 draw-pane
14 interactor)))
15 (:menu-bar t)
16 (:command-definer t)
17 (:top-level (default-frame-top-level)))
18
19 (defclass draw-pane
20 (standard-extended-input-stream ; must have precedence over basic-pane
21 basic-pane
22 permanent-medium-sheet-output-mixin)
23 ())
24
25 (defmethod handle-repaint ((pane draw-pane) region)
26 (with-application-frame (frame)
27 (call-next-method) ; Paints the background
28 (dolist (line (lines frame))
29 (draw-line pane (car line) (cdr line)))
30 (dolist (pair (strings frame))
31 (draw-text pane (cdr pair) (car pair)))))
32 ; LTAG-end
33 (defmethod frame-standard-output ((frame draw-frame))
34 (get-frame-pane frame 'interactor))
35
36 ; LTAG-start:draw-frame-commands
37 (define-draw-frame-command (com-draw-add-string :menu t :name t)
38 ((string 'string) (x 'integer) (y 'integer))
39 (push (cons (make-point x y) string)
40 (strings *application-frame*))
41 (update-draw-pane))
42
43 (define-draw-frame-command (com-draw-add-line :menu t :name t)
44 ((x1 'integer) (y1 'integer) (x2 'integer) (y2 'integer))
45 (with-slots (lines) *application-frame*
46 (push (cons (make-point x1 y1) (make-point x2 y2))
47 lines))
48 (update-draw-pane))
49
50 (define-draw-frame-command (com-draw-clear :menu t :name t) ()
51 (with-slots (lines strings) *application-frame*
52 (setf lines nil strings nil))
53 (update-draw-pane))
54
55 ;; Auxilary Method
56 (defun update-draw-pane ()
57 (repaint-sheet (find-pane-named *application-frame* 'draw-pane) +everywhere+))
58 ; LTAG-end
59
60 ; LTAG-start:draw-frame-interfacing
61 (defmethod handle-event ((pane draw-pane) (event pointer-button-press-event))
62 ;; Start line tracking when left pointer button is pressed
63 (when (eql (pointer-event-button event) +pointer-left-button+)
64 (track-line-drawing pane
65 (pointer-event-x event)
66 (pointer-event-y event))))
67
68 (defmethod handle-event ((pane draw-pane) (event key-press-event))
69 (when (keyboard-event-character event)
70 (multiple-value-bind (x y) (stream-pointer-position pane)
71 ;; Start with empty string, as a key release event will be received anyway
72 (track-text-drawing pane "" x y)))
73 (update-draw-pane))
74
75 (defun track-line-drawing (pane startx starty)
76 (let ((lastx startx)
77 (lasty starty))
78 (with-drawing-options (pane :ink +flipping-ink+)
79 (draw-line* pane startx starty lastx lasty)
80 (tracking-pointer (pane)
81 (:pointer-motion (&key window x y)
82 (draw-line* pane startx starty lastx lasty) ; delete old
83 (draw-line* pane startx starty x y) ; draw new
84 (setq lastx x lasty y))
85 (:pointer-button-release (&key event x y)
86 (when (eql (pointer-event-button event) +pointer-left-button+)
87 (draw-line* pane startx starty lastx lasty)
88 (execute-frame-command *application-frame*
89 `(com-draw-add-line ,startx ,starty ,x ,y))
90 (return-from track-line-drawing nil)))))))
91
92 (defun track-text-drawing (pane current-string current-x current-y)
93 (tracking-pointer (pane)
94 (:pointer-motion (&key window x y)
95 ;; We can't use flipping ink for text, hence redraw.
96 (handle-repaint pane +everywhere+)
97 (setq current-x x current-y y)
98 (draw-text* pane current-string x y))
99 (:keyboard (&key gesture)
100 (when (and (typep gesture 'key-release-event)
101 (keyboard-event-character gesture))
102 (setf current-string
103 (concatenate 'string
104 current-string
105 (string (keyboard-event-character gesture))))
106 (handle-repaint pane +everywhere+)
107 (draw-text* pane current-string current-x current-y)))
108 (:pointer-button-release (&key event x y)
109 (when (eql (pointer-event-button event) +pointer-left-button+)
110 (execute-frame-command *application-frame*
111 `(com-draw-add-string ,current-string ,x ,y))
112 (return-from track-text-drawing nil)))))
113 ; LTAG-end:draw-frame-part2

  ViewVC Help
Powered by ViewVC 1.1.5