blob: 35c74ba4b4573db6b9a5e708ee549c68e9976831 (
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
|
;;;; 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 (target h v)
(format t "v: ~a~% " v)
(ww:scale-by target
(if (plusp v) 1.1 0.9))))
(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))
(format t "foo")
(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)))))
(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-unit canvas)))
(defun start ()
(ww:start
(make-instance 'pixel-whomp)
:x 2350))
|
