Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 344 lines (297 sloc) 12.942 kb
96f497f @mental finish rebranding
mental authored
1 ; inkly - a little drawing app of modest aspirations
bdacf87 @mental add licence headers to files
mental authored
2 ;
3 ; Copyright (c) 2009 MenTaLguY <mental@rydia.net>
4 ;
5 ; Permission is hereby granted, free of charge, to any person obtaining
6 ; a copy of this software and associated documentation files (the
7 ; "Software"), to deal in the Software without restriction, including
8 ; without limitation the rights to use, copy, modify, merge, publish,
9 ; distribute, sublicense, and/or sell copies of the Software, and to
10 ; permit persons to whom the Software is furnished to do so, subject to
11 ; the following conditions:
12 ;
13 ; The above copyright notice and this permission notice shall be
14 ; included in all copies or substantial portions of the Software.
15 ;
16 ; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
17 ; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
18 ; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
19 ; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
20 ; LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
21 ; OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
22 ; WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
96f497f @mental finish rebranding
mental authored
23 (ns inkly
b025c4b @mental allow setting drawing color
mental authored
24 (:import [javax.swing SwingUtilities JFrame JPanel WindowConstants
25 JToolBar JToggleButton ButtonGroup]
4b15ee1 @mental permanent drawing with live preview
mental authored
26 [java.awt Dimension Color Rectangle AlphaComposite
b025c4b @mental allow setting drawing color
mental authored
27 RenderingHints BorderLayout]
4b15ee1 @mental permanent drawing with live preview
mental authored
28 [java.awt.geom Path2D Path2D$Float]
b025c4b @mental allow setting drawing color
mental authored
29 [java.awt.event MouseEvent KeyEvent ActionListener]
62c5739 @mental factor out input stuff
mental authored
30 [java.awt.image BufferedImage]
31 java.lang.Math)
96f497f @mental finish rebranding
mental authored
32 (:use [org.inkscape.inkly.input :only [make-input-behavior
31e21f6 @mental try to make things a little prettier
mental authored
33 compose-input-behaviors
605f359 @mental infix math, yay
mental authored
34 make-input-listener]]
35 [org.inkscape.inkly.syntax :only [infix-math]])
567b8d9 @mental put in some bits for compilation
mental authored
36 (:gen-class))
983efe9 @mental scribble of main window
mental authored
37
dc2e3ff @mental very primitive drawing
mental authored
38 (def +canvas-width+ 494)
39 (def +canvas-height+ 400)
983efe9 @mental scribble of main window
mental authored
40 (def +canvas-dimensions+ (new Dimension +canvas-width+ +canvas-height+))
11cd66a @mental support keyboard input as well
mental authored
41 (def +canvas-rect+ (new Rectangle +canvas-dimensions+))
0e4b320 @mental mess with pen width and motion epsilon a bit
mental authored
42 (def +pen-width+ (double 30))
43 (def +half-pen-width+ (/ +pen-width+ 2.0))
b0c0377 @mental better join angles
mental authored
44 (def +motion-epsilon+ (double 2.0))
983efe9 @mental scribble of main window
mental authored
45
2270220 @mental start abstracting out image buffers
mental authored
46 (defstruct <buffer> :image :g)
47
48 (defn make-buffer []
49 (let [image (new BufferedImage +canvas-width+ +canvas-height+
50 BufferedImage/TYPE_INT_ARGB_PRE)
51 g (.createGraphics image)]
52 (struct-map <buffer> :image image :g g)))
53
54 (defstruct <model> :canvas-buffer :overlay-buffer :update-fns)
0d7fdb0 @mental overlay versus canvas backing stores, and transient stroke images
mental authored
55
56 (declare clear-canvas!)
57 (declare clear-overlay!)
dc2e3ff @mental very primitive drawing
mental authored
58
59 (defn make-model []
2270220 @mental start abstracting out image buffers
mental authored
60 (let [canvas-buffer (make-buffer)
61 overlay-buffer (make-buffer)
b025c4b @mental allow setting drawing color
mental authored
62 model (struct-map <model> :current-color (atom Color/BLACK)
63 :canvas-buffer canvas-buffer
2270220 @mental start abstracting out image buffers
mental authored
64 :overlay-buffer overlay-buffer
0d7fdb0 @mental overlay versus canvas backing stores, and transient stroke images
mental authored
65 :update-fns (atom ()))]
66 (clear-canvas! model)
67 (clear-overlay! model)
dc2e3ff @mental very primitive drawing
mental authored
68 model))
69
0d7fdb0 @mental overlay versus canvas backing stores, and transient stroke images
mental authored
70 (defn invoke-update-fns [model rect]
71 (doseq [f @(model :update-fns)] (f rect)))
72
dc2e3ff @mental very primitive drawing
mental authored
73 (defn render-model [model g]
0d7fdb0 @mental overlay versus canvas backing stores, and transient stroke images
mental authored
74 (.setComposite g AlphaComposite/Src)
2270220 @mental start abstracting out image buffers
mental authored
75 (.drawImage g ((model :canvas-buffer) :image) 0 0 nil)
0d7fdb0 @mental overlay versus canvas backing stores, and transient stroke images
mental authored
76 (.setComposite g AlphaComposite/SrcOver)
2270220 @mental start abstracting out image buffers
mental authored
77 (.drawImage g ((model :overlay-buffer) :image) 0 0 nil))
dc2e3ff @mental very primitive drawing
mental authored
78
0d7fdb0 @mental overlay versus canvas backing stores, and transient stroke images
mental authored
79 (defn clear-canvas! [model]
2270220 @mental start abstracting out image buffers
mental authored
80 (let [g ((model :canvas-buffer) :g)]
0d7fdb0 @mental overlay versus canvas backing stores, and transient stroke images
mental authored
81 (.setColor g Color/WHITE)
82 (.setComposite g AlphaComposite/Src)
4b15ee1 @mental permanent drawing with live preview
mental authored
83 (.setRenderingHint g RenderingHints/KEY_ANTIALIASING
84 RenderingHints/VALUE_ANTIALIAS_OFF)
0d7fdb0 @mental overlay versus canvas backing stores, and transient stroke images
mental authored
85 (.fillRect g 0 0 +canvas-width+ +canvas-height+)
86 (.setComposite g AlphaComposite/SrcOver)
4b15ee1 @mental permanent drawing with live preview
mental authored
87 (.setRenderingHint g RenderingHints/KEY_ANTIALIASING
88 RenderingHints/VALUE_ANTIALIAS_ON)
0d7fdb0 @mental overlay versus canvas backing stores, and transient stroke images
mental authored
89 (invoke-update-fns model +canvas-rect+)))
dc2e3ff @mental very primitive drawing
mental authored
90
0d7fdb0 @mental overlay versus canvas backing stores, and transient stroke images
mental authored
91 (defn clear-overlay! [model]
2270220 @mental start abstracting out image buffers
mental authored
92 (let [g ((model :overlay-buffer) :g)]
0d7fdb0 @mental overlay versus canvas backing stores, and transient stroke images
mental authored
93 (.setComposite g AlphaComposite/Clear)
94 (.fillRect g 0 0 +canvas-width+ +canvas-height+)
95 (.setComposite g AlphaComposite/SrcOver)
96 (invoke-update-fns model +canvas-rect+)))
11cd66a @mental support keyboard input as well
mental authored
97
b025c4b @mental allow setting drawing color
mental authored
98 (defn set-current-color! [model color]
99 (reset! (model :current-color) color)
100 nil)
101
0d7fdb0 @mental overlay versus canvas backing stores, and transient stroke images
mental authored
102 (defn add-update-fn! [model callback]
103 (swap! (model :update-fns) conj callback))
11cd66a @mental support keyboard input as well
mental authored
104
4b15ee1 @mental permanent drawing with live preview
mental authored
105 (defn make-polygon [points]
106 (let [path (new Path2D$Float)]
107 (.setWindingRule path Path2D/WIND_NON_ZERO)
108 (when (not (empty? points))
109 (let [[initial-point & remaining-points] points
110 move-to (fn [[x y]] (.moveTo path x y))
111 line-to (fn [[x y]] (.lineTo path x y))]
112 (move-to initial-point)
113 (dorun (map line-to remaining-points)))
114 (.closePath path))
115 path))
116
b025c4b @mental allow setting drawing color
mental authored
117 (defn draw-overlay-quad! [model color p0 p1 p2 p3]
4b15ee1 @mental permanent drawing with live preview
mental authored
118 (let [poly (make-polygon [p0 p1 p2 p3])
2270220 @mental start abstracting out image buffers
mental authored
119 g ((model :overlay-buffer) :g)
4b15ee1 @mental permanent drawing with live preview
mental authored
120 bounds (.getBounds poly)]
b025c4b @mental allow setting drawing color
mental authored
121 (.setColor g color)
4b15ee1 @mental permanent drawing with live preview
mental authored
122 (.fill g poly)
123 (invoke-update-fns model bounds)))
124
b025c4b @mental allow setting drawing color
mental authored
125 (defn draw-canvas-polygon! [model color points]
4b15ee1 @mental permanent drawing with live preview
mental authored
126 (let [poly (make-polygon points)
2270220 @mental start abstracting out image buffers
mental authored
127 g ((model :canvas-buffer) :g)
4b15ee1 @mental permanent drawing with live preview
mental authored
128 bounds (.getBounds poly)]
b025c4b @mental allow setting drawing color
mental authored
129 (.setColor g color)
4b15ee1 @mental permanent drawing with live preview
mental authored
130 (.fill g poly)
131 (invoke-update-fns model bounds)))
11cd66a @mental support keyboard input as well
mental authored
132
b0c0377 @mental better join angles
mental authored
133 (defn vadd [[x0 y0] [x1 y1]]
134 [(+ x0 x1) (+ y0 y1)])
135
136 (defn vsub [[x0 y0] [x1 y1]]
137 [(- x0 x1) (- y0 y1)])
138
139 (defn vmag [[x y]]
605f359 @mental infix math, yay
mental authored
140 (infix-math (Math/sqrt ((x * x) + (y * y)))))
b0c0377 @mental better join angles
mental authored
141
142 (defn vscale [s [x y]] [(* s x) (* s y)])
143
144 (defn vscaleinv [s [x y]] [(/ x s) (/ y s)])
145
146 (defn vnorm [v]
147 (let [m (vmag v)]
148 (if (= m 0.0)
149 [(double 0.0) (double 0.0)]
150 (vscaleinv m v))))
1ba7c46 @mental primitive stroke drawing
mental authored
151
b0c0377 @mental better join angles
mental authored
152 ; anti-clockwise in screen coordinate system
153 (defn rot90 [[x y]] [(- y) x])
154
9b95ac2 @mental add bowtie detection
mental authored
155 (defn segments-intersect? [[[x0 y0] [x1 y1]] [[x2 y2] [x3 y3]]]
156 (let [x0 (double x0) y0 (double y0)
157 x1 (double x1) y1 (double y1)
158 x2 (double x2) y2 (double y2)
159 x3 (double x3) y3 (double y3)
160 dx0 (- x1 x0) dx1 (- x3 x2)
161 dy0 (- y1 y0) dy1 (- y3 y2)
162 denom (- (* dy1 dx0) (* dx1 dy0))
163 relx (- x0 x2) rely (- y0 y2)
164 num0 (- (* dx1 rely) (* dy1 relx))
165 num1 (- (* dx0 rely) (* dy0 relx))]
166 (if (= denom 0.0)
167 ; parallel or coincident
168 false
169 ; else, intersecting lines
170 (let [t0 (/ num0 denom) t1 (/ num1 denom)]
171 ; check if intersections lie within segments
172 (and (and (>= t0 0.0) (<= t0 1.0))
173 (and (>= t1 0.0) (<= t1 1.0)))))))
174
b0c0377 @mental better join angles
mental authored
175 (defn stroke-points [pos vin vout]
26fd9cc @mental don't worry about storing input history for now, but do accumulate path ...
mental authored
176 (let [stroke-angle (rot90 (vnorm (vadd vin vout)))
b0c0377 @mental better join angles
mental authored
177 stroke-offset (vscale +half-pen-width+ stroke-angle)]
178 [(vsub pos stroke-offset) (vadd pos stroke-offset)]))
179
b025c4b @mental allow setting drawing color
mental authored
180 (defstruct <stroke-builder> :color :previous-pos :previous-vel :stroke-sides)
b0c0377 @mental better join angles
mental authored
181
b025c4b @mental allow setting drawing color
mental authored
182 (defn make-stroke-builder [color x y]
183 (struct-map <stroke-builder> :color color
184 :previous-pos [x y]
b0c0377 @mental better join angles
mental authored
185 :previous-vel [(double 0.0) (double 0.0)]
26fd9cc @mental don't worry about storing input history for now, but do accumulate path ...
mental authored
186 :stroke-sides []))
1ba7c46 @mental primitive stroke drawing
mental authored
187
188 (defn add-stroke-sample! [model builder x y]
b0c0377 @mental better join angles
mental authored
189 (let [pos [(double x) (double y)]
26fd9cc @mental don't worry about storing input history for now, but do accumulate path ...
mental authored
190 old-pos (builder :previous-pos)
b0c0377 @mental better join angles
mental authored
191 vel (vsub pos old-pos)
192 mvel (vmag vel)]
193 (if (< mvel +motion-epsilon+)
1ba7c46 @mental primitive stroke drawing
mental authored
194 builder
4ee004b @mental add comment for readability
mental authored
195 ; else
b0c0377 @mental better join angles
mental authored
196 (let [old-vel (builder :previous-vel)
197 [p2 p3] (stroke-points old-pos old-vel vel)
26fd9cc @mental don't worry about storing input history for now, but do accumulate path ...
mental authored
198 stroke-sides (builder :stroke-sides)
b025c4b @mental allow setting drawing color
mental authored
199 builder (assoc builder :previous-pos pos
200 :previous-vel vel
201 ; note order: [p3 p2] become [p0 p1]
202 :stroke-sides (cons [p3 p2]
203 stroke-sides))]
26fd9cc @mental don't worry about storing input history for now, but do accumulate path ...
mental authored
204 (when (not (empty? stroke-sides))
205 (let [[p0 p1] (first stroke-sides)]
9b95ac2 @mental add bowtie detection
mental authored
206 (when (segments-intersect? [p0 p3] [p1 p2])
207 (println (.concat "Side bowtie: " (str [[p0 p3] [p1 p2]]))))
208 (when (segments-intersect? [p0 p1] [p2 p3])
209 (println (.concat "Longitudinal bowtie: " (str [[p0 p1] [p2 p3]]))))
b025c4b @mental allow setting drawing color
mental authored
210 (draw-overlay-quad! model (builder :color) p0 p1 p2 p3)))
1ba7c46 @mental primitive stroke drawing
mental authored
211 builder))))
212
b0c0377 @mental better join angles
mental authored
213 (defn complete-stroke! [model builder]
214 (let [old-vel (builder :previous-vel)
26fd9cc @mental don't worry about storing input history for now, but do accumulate path ...
mental authored
215 old-pos (builder :previous-pos)
b0c0377 @mental better join angles
mental authored
216 [p2 p3] (stroke-points old-pos old-vel old-vel)
26fd9cc @mental don't worry about storing input history for now, but do accumulate path ...
mental authored
217 stroke-sides (builder :stroke-sides)]
218 (when (not (empty? stroke-sides))
4b15ee1 @mental permanent drawing with live preview
mental authored
219 (clear-overlay! model)
220 (let [points (concat (map first stroke-sides)
221 (map second (reverse stroke-sides)))]
b025c4b @mental allow setting drawing color
mental authored
222 (draw-canvas-polygon! model (builder :color) points)))))
b0c0377 @mental better join angles
mental authored
223
62c5739 @mental factor out input stuff
mental authored
224 (defn with-just-xy [f]
225 (fn [behavior event] (f behavior (.getX event) (.getY event))))
226
227 (defn guard-button [button f]
228 (fn [behavior event]
229 (if (= (.getButton event) button)
230 (f behavior event)
231 behavior)))
232
338ea20 @mental use forward declaration macro
mental authored
233 (declare make-draw-stroke-active-behavior)
1ba7c46 @mental primitive stroke drawing
mental authored
234
235 (defn make-draw-stroke-idle-behavior [model previous-pos]
31e21f6 @mental try to make things a little prettier
mental authored
236 (let [on-mouse-pressed
237 (guard-button MouseEvent/BUTTON1 (with-just-xy
238 (fn [behavior x y]
239 (let [[previous-x previous-y] (get behavior :previous-pos [x y])
b025c4b @mental allow setting drawing color
mental authored
240 builder (make-stroke-builder @(model :current-color) x y)
31e21f6 @mental try to make things a little prettier
mental authored
241 builder (add-stroke-sample! model builder x y)]
242 (make-draw-stroke-active-behavior model builder)))))
243
244 on-mouse-moved
245 (with-just-xy
246 (fn [behavior x y] (assoc behavior :previous-pos [x y])))]
247
248 (make-input-behavior :on-mouse-pressed on-mouse-pressed
249 :on-mouse-moved on-mouse-moved
250 :on-mouse-dragged on-mouse-moved
251 :previous-pos previous-pos)))
1ba7c46 @mental primitive stroke drawing
mental authored
252
253 (defn make-draw-stroke-active-behavior [model builder]
31e21f6 @mental try to make things a little prettier
mental authored
254 (let [on-mouse-released
255 (guard-button MouseEvent/BUTTON1 (with-just-xy
256 (fn [behavior x y]
b0c0377 @mental better join angles
mental authored
257 (let [builder (add-stroke-sample! model (behavior :builder) x y)]
258 (complete-stroke! model builder)
259 (make-draw-stroke-idle-behavior model [x y])))))
31e21f6 @mental try to make things a little prettier
mental authored
260
261 on-mouse-dragged
262 (with-just-xy
263 (fn [behavior x y]
264 (let [builder (add-stroke-sample! model (behavior :builder) x y)]
265 (assoc behavior :builder builder))))]
266
267 (make-input-behavior :on-mouse-released on-mouse-released
268 :on-mouse-dragged on-mouse-dragged
269 :builder builder)))
1ba7c46 @mental primitive stroke drawing
mental authored
270
271 (defn make-draw-stroke-behavior [model] (make-draw-stroke-idle-behavior model nil))
272
11cd66a @mental support keyboard input as well
mental authored
273 (defn make-clear-canvas-behavior [model]
31e21f6 @mental try to make things a little prettier
mental authored
274 (let [on-key-pressed
275 (fn [behavior event]
276 (when (= (.getKeyCode event) KeyEvent/VK_ESCAPE)
277 (clear-canvas! model))
278 behavior)]
279 (make-input-behavior :on-key-pressed on-key-pressed)))
11cd66a @mental support keyboard input as well
mental authored
280
dc2e3ff @mental very primitive drawing
mental authored
281 (defn make-canvas-component [model]
983efe9 @mental scribble of main window
mental authored
282 (let [p (proxy [JPanel] []
283 (paintComponent [g]
284 (proxy-super paintComponent g)
dc2e3ff @mental very primitive drawing
mental authored
285 (render-model model g))
983efe9 @mental scribble of main window
mental authored
286 (getMinimumSize [] +canvas-dimensions+)
dc2e3ff @mental very primitive drawing
mental authored
287 (getPreferredSize [] +canvas-dimensions+))
11cd66a @mental support keyboard input as well
mental authored
288 behaviors (compose-input-behaviors (make-clear-canvas-behavior model)
289 (make-draw-stroke-behavior model))
62c5739 @mental factor out input stuff
mental authored
290 listener (make-input-listener behaviors)]
983efe9 @mental scribble of main window
mental authored
291 (.setBackground p Color/WHITE)
31e21f6 @mental try to make things a little prettier
mental authored
292 (add-update-fn! model #(.repaint p (.x %) (.y %) (.width %) (.height %)))
dc2e3ff @mental very primitive drawing
mental authored
293 (.addMouseListener p listener)
294 (.addMouseMotionListener p listener)
11cd66a @mental support keyboard input as well
mental authored
295 (.addKeyListener p listener)
296 (.setFocusable p true)
983efe9 @mental scribble of main window
mental authored
297 p))
298
b025c4b @mental allow setting drawing color
mental authored
299 (defn make-toolbar-color-button [model group color]
300 (let [button (new JToggleButton (str color))
301 listener (proxy [ActionListener] []
302 (actionPerformed [e]
303 (set-current-color! model color)))]
304 (.add group button)
305 (.addActionListener (.getModel button) listener)
306 button))
307
308 (defn make-toolbar-component [model]
309 (let [toolbar (new JToolBar)
310 color-button-group (new ButtonGroup)
311 make-color-button #(make-toolbar-color-button model color-button-group %)
312 white-button (make-color-button Color/WHITE)
313 black-button (make-color-button Color/BLACK)]
314 (.setFloatable toolbar false)
315 (.setRollover toolbar true)
316 (.add toolbar black-button)
317 (.add toolbar white-button)
318 (.setSelected (.getModel black-button) true)
319 toolbar))
320
983efe9 @mental scribble of main window
mental authored
321 (defn make-toplevel-window []
322 (let [w (new JFrame)
dc2e3ff @mental very primitive drawing
mental authored
323 model (make-model)
b025c4b @mental allow setting drawing color
mental authored
324 canvas (make-canvas-component model)
325 toolbar (make-toolbar-component model)]
cbe0d70 @mental a little more character for the title
mental authored
326 (.setTitle w "~Inkly~")
b025c4b @mental allow setting drawing color
mental authored
327 (.setLayout w (new BorderLayout))
328 (.add w toolbar BorderLayout/NORTH)
329 (.add w canvas BorderLayout/CENTER)
983efe9 @mental scribble of main window
mental authored
330 (.pack w)
331 (.setBackground w Color/WHITE)
332 (.setDefaultCloseOperation w WindowConstants/DISPOSE_ON_CLOSE)
333 (.setResizable w false)
334 (.setVisible w true)
335 w))
336
567b8d9 @mental put in some bits for compilation
mental authored
337 (defn -main [& args] ())
338
339 (defn main [& args]
340 (SwingUtilities/invokeAndWait make-toplevel-window))
341
342 (when (not *compile-files*)
343 (apply main *command-line-args*))
Something went wrong with that request. Please try again.