blob: 737c12d1ee4f18b7ca453b05ee821f6c4771fa05 (
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
151
152
153
154
155
156
157
|
;;;; 14-canvas-paint.lisp
(defpackage #:ww.examples/14
(:use #:cl)
(:export #:start))
(in-package #:ww.examples/14)
(defclass pixel-whomp (ww:application)
((canvas-size :initarg :size :initform 800 :reader canvas-size)))
(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)
(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))))
(ww::defhandler canvas-mousebutton-up
(ww::on-mouseup (target)
(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)))
(setf (pen-down-pos target) nil)))
(defvar *last-draw-time* 0)
(defvar *draw-sample-pause* 40)
(setf *draw-sample-pause* 40)
(defun is-time-to-draw-p ()
(let ((ticks (sdl2:get-ticks)))
(when (<= (+ *last-draw-time* *draw-sample-pause*) ticks)
(setf *last-draw-time* ticks))))
(defun draw (canvas x y)
(when (is-time-to-draw-p)
(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 canvas-mouse-move
(ww::on-mousemotion (target x y)
(setf (car *last-mouse-pos*) x
(cadr *last-mouse-pos*) 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 (canvas-size app)
:pixel-height (canvas-size app))))
(setf *last-draw-time* 0)
(ww:add-unit canvas)))
(defun start (&key (size 800) (window 800))
(ww:start
(make-instance
'pixel-whomp
:width window
:height window
:title "Not a Pixel Art Editor"
:size size)
:x 2350))
|
