/[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.1 - (hide annotations)
Mon Jan 30 16:14:01 2006 UTC (8 years, 2 months ago) by cfruhwirth
Branch: MAIN
Move docs/guided-tour to Doc/Guided-Tour.
Add line-breaks to guided-tour.tex.
1 cfruhwirth 1.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