blob: 3db904e840ec2c8beab37a976145c1819b943b2b (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
|
;;;; 14-canvas-paint.lisp
(defpackage #:ww.examples/14
(:use #:cl)
(:export #:start))
(in-package #:ww.examples/14)
(defclass pixel-whomp (ww:application)
())
(defclass pwcanvas (ww:canvas)
((pen-down-pos :accessor pen-down-pos :initform nil)
(mode :initform :draw :accessor mode)
(pen-width :initform 1 :accessor pen-width)))
(defun scale-pos-to-canvas (can ex ey)
(let
((scale (ww::scale-x can))
(x (ww:x can))
(y (ww:y can)))
(values (/ (- ex x) scale)
(/ (- ey y) scale))))
(defun set-pen-position (can ex ey)
"x and y are as received from mouse events. adjust the pen position
to account for scale, or set to nil of x and y are curren toff the
canvas"
(let
((pos
(or (pen-down-pos can)
(list 0 0))))
(multiple-value-bind (nx ny) (scale-pos-to-canvas can ex ey)
(setf (car pos) nx
(cadr pos) ny
(pen-down-pos can) pos))
pos))
(defun shift-mod-p (mods)
(or (member :rshift mods)
(member :lshift mods)))
(ww::defhandler keyboard-commands
(ww::on-keydown (target scancode mods)
(format t "~a~%"
(list :code scancode :mods mods))
(case scancode
(:scancode-equals
(when (shift-mod-p mods)
(incf (pen-width target))))
(:scancode-minus
(setf (pen-width target)
(max 0 (1- (pen-width target))))))))
(ww::defhandler change-mode-start
(ww::on-keydown ()
(case scancode
((:scancode-lshift :scancode-rshift)
(setf (mode target) :drag)))))
(ww::defhandler change-mode-stop
(ww::on-keyup ()
(setf (mode target) :draw)))
(ww::defhandler zoom
(ww::on-mousewheel (u h v)
(multiple-value-bind
(ox oy)
(apply #'scale-pos-to-canvas u *last-mouse-pos*)
(ww:scale-by u (if (plusp v) 1.1 0.9))
(multiple-value-bind
(nx ny)
(apply #'scale-pos-to-canvas u *last-mouse-pos*)
(incf (ww:x u) (* (ww:scale-x u) (- nx ox)))
(incf (ww:y u) (* (ww:scale-x u) (- ny oy)))))))
(ww:defhandler canvas-mousebutton-down
(ww:on-mousedown (target x y clicks button winx winy)
(unless (pen-down-pos target)
(set-pen-position target x y)
(when (eq :draw (mode target))
(ww::with-canvas target
(ww:with-pen (:width (pen-width target))
(apply 'ww:apply-pen-at (mapcar #'floor (pen-down-pos target))))
(ww:blit target))))))
(ww::defhandler canvas-mousebutton-up
(ww::on-mouseup (target)
(setf (pen-down-pos target) nil)))
(defun draw (canvas x y)
(let ((old-pos (copy-seq (pen-down-pos canvas))))
(destructuring-bind (nx ny) (set-pen-position canvas x y)
(ww:with-canvas canvas
(ww:with-pen (:position old-pos :width (pen-width canvas))
(ww:stroke-to nx ny))))
(ww:blit canvas)))
(defun drag (canvas x y)
(multiple-value-bind (cx cy) (scale-pos-to-canvas canvas x y)
(destructuring-bind (px py) (pen-down-pos canvas)
(let ((tx (* (ww:scale-x canvas)
(- cx px)))
(ty (* (ww:scale-x canvas)
(- cy py))))
(incf (ww:x canvas) tx)
(incf (ww:y canvas) ty)))))
(defvar *last-mouse-pos* (list 0 0))
(ww::defhandler moust-tracker
(ww::on-mousemotion (target x y)
(setf (car *last-mouse-pos*) x
(cadr *last-mouse-pos*) y)))
(ww::defhandler canvas-mouse-move
(ww::on-mousemotion (target x y)
(when (pen-down-pos target)
(ecase (mode target)
(:draw (draw target x y))
(:drag (drag target x y))))))
(defmethod initialize-instance :after ((ob pwcanvas) &key)
(ww:add-handler ob #'keyboard-commands)
(ww:add-handler ob #'change-mode-start)
(ww:add-handler ob #'change-mode-stop)
(ww:add-handler ob #'zoom)
(ww:add-handler ob #'canvas-mousebutton-up)
(ww:add-handler ob #'canvas-mousebutton-down)
(ww:add-handler ob #'canvas-mouse-move))
(defmethod ww:boot ((app pixel-whomp))
(let ((canvas
(make-instance 'pwcanvas
:pixel-width 800
:pixel-height 800)))
(ww:add-handler app #'moust-tracker)
(ww:add-handler canvas #'moust-tracker)
(ww:add-unit canvas)))
(defun start ()
(ww:start
(make-instance 'pixel-whomp)
:x 2350))
|
