Initial commit
[yotta-zoomer.git] / yotta-zoomer.lisp
blob2d8f10a5ebc2cdaf9e6e0f2aa07fc407baa58201
2 (in-package :yotta-zoomer)
4 (declaim (optimize (speed 0) (safety 3) (debug 3) (compilation-speed 0)))
6 (defmacro with-gensyms ((&rest names) &body body)
7 `(let ,(loop for n in names collect `(,n (gensym)))
8 ,@body))
10 (defmacro once-only ((&rest names) &body body)
11 (let ((gensyms (loop for n in names collect (gensym))))
12 `(let (,@(loop for g in gensyms collect `(,g (gensym))))
13 `(let (,,@(loop for g in gensyms for n in names collect ``(,,g ,,n)))
14 ,(let (,@(loop for n in names for g in gensyms collect `(,n ,g)))
15 ,@body)))))
17 (defmacro with-opengl (&body forms)
18 (with-gensyms (error-sym)
19 `(progn ,@forms
20 (let ((,error-sym (gl:get-error)))
21 (unless ,error-sym
22 (error "OpenGL Error ~A~%"
23 (case ,error-sym
24 (gl:+INVALID-ENUM+ "Invalid Enum")
25 (gl:+INVALID-VALUE+ "Invalid value")
26 (gl:+INVALID-OPERATION+ "Invalid Operation")
27 (gl:+OUT-OF-MEMORY+ "Out of memory")
28 (gl:+STACK-OVERFLOW+ "Stack overflow")
29 (gl:+STACK-UNDERFLOW+ "Stack underflow"))))))))
31 (defconstant +squared-limit+ 4.0)
32 (defparameter *max-iterations* 16)
34 (defclass rgba-image ()
35 ((name :accessor name-of)
36 (width :accessor width-of :initform 0)
37 (height :accessor height-of :initform 0)
38 (format :reader format-of :initform gl:+rgba+)
39 (bpp :reader bpp-of :initform 4)
40 (data :accessor data-of)
41 (size :accessor size-of))
42 (:documentation "Data for an opengl RGBA texture"))
44 (defmethod make-image ((self rgba-image) &key width height)
45 "Create a sized rgba texture"
46 (setf (width-of self) width)
47 (setf (height-of self) height)
48 (setf (slot-value self 'name) (cffi:foreign-alloc :uint32))
49 (with-opengl
50 (gl:gen-textures 1 (name-of self))
51 (gl:bind-texture gl:+texture-2d+ (cffi::mem-ref (name-of self) :uint32))
52 (gl:tex-parameter-i gl:+texture-2d+ gl:+texture-wrap-s+ gl:+repeat+)
53 (gl:tex-parameter-i gl:+texture-2d+ gl:+texture-wrap-t+ gl:+repeat+)
54 (gl:tex-parameter-i gl:+texture-2d+ gl:+texture-mag-filter+ gl:+linear+)
55 (gl:tex-parameter-i gl:+texture-2d+ gl:+texture-min-filter+ gl:+linear+)
56 (gl:pixel-store-i gl:+unpack-alignment+ 1)
57 (gl:tex-env-f gl:+texture-env+ gl:+texture-env-mode+ gl:+decal+))
58 (setf (slot-value self 'data)
59 (cffi:foreign-alloc :uint32
60 :count (* (width-of self) (height-of self))
61 :initial-element 0)))
63 (defmethod update-image ((self rgba-image))
64 "Upload an RGBA texture"
65 (with-opengl
66 (gl:bind-texture gl:+texture-2d+ (cffi::mem-ref (name-of self) :uint32))
67 (gl:tex-image-2d gl:+texture-2d+ 0 gl:+rgba+
68 (width-of self) (height-of self)
69 0 gl:+rgba+ gl:+unsigned-byte+ (data-of self))))
72 (defgeneric render (self &key target))
74 (defmethod render ((self rgba-image) &key target)
75 "Render an RGBA texture"
76 (declare (ignore target))
77 (with-opengl
78 (gl:bind-texture gl:+texture-2d+ (cffi::mem-ref (name-of self) :uint32))
79 (gl:tex-env-f gl:+texture-env+ gl:+texture-env-mode+ gl:+decal+)
80 (gl:with-begin gl:+quads+
81 (gl:tex-coord-2i 0 0)
82 (gl:vertex-2f -0.5 -0.5) ;; top lhs
83 (gl:tex-coord-2i 1 0)
84 (gl:vertex-2f 0.5 -0.5) ;; top rhs
85 (gl:tex-coord-2i 1 1)
86 (gl:vertex-2f 0.5 0.5) ;; bot rhs
87 (gl:tex-coord-2i 0 1)
88 (gl:vertex-2f -0.5 0.5)))) ;; bot lhs
90 (defmethod destroy-image ((self rgba-image))
91 "Release the memory used by an RGBA texture"
92 (setf (width-of self) 0)
93 (setf (height-of self) 0)
94 (with-opengl
95 (gl:delete-textures 1 (name-of self))
96 (cffi:foreign-free (name-of self))
97 (cffi:foreign-free (data-of self))))
101 (defmethod image-size ((image rgba-image))
102 "Overall RGBA texture size in bytes"
103 (* (width-of image) (height-of image)))
105 (defmethod pixel ((image rgba-image) i)
106 "Access a pixel in an RGBA texture"
107 (cffi:mem-aref (data-of image) :uint32 i))
109 (defmethod (setf pixel) (pixel (image rgba-image) i)
110 "Set a pixel in an RGBA texture"
111 (setf (cffi:mem-aref (data-of image) :uint32 i) pixel))
113 (defmethod indexxy ((image rgba-image) index)
114 "Map an i index to an x,y index of a RGBA texure"
115 (values (mod index (width-of image))
116 (rem index (width-of image))))
118 (defmethod xyindex ((image rgba-image) x y)
119 "Map an x,y index to an i index of a RGBA texure"
120 (+ x (* (width-of image) y)))
122 (defun map-color-to-pixel (r g b)
123 "Convert rgb values to a pixel uint32"
124 (declare ((unsigned-byte 8) r g b))
125 (logior
126 (ash r 24)
127 (ash g 16)
128 (ash b 8)
129 #X0))
132 ;; FIRST THINGS FIRST -- make a slow zoom into 0,0 work
133 ;; make a colormap work
134 ;; then take samples :-)
136 (declaim (ftype
137 (function (fixnum fixnum)
138 (simple-array (unsigned-byte 8) *)) make-iteration-map))
140 (defclass iteration-map ()
141 ((width :reader width-of :initarg :width)
142 (height :reader height-of :initarg :height)
143 (map :reader map-of))
144 (:documentation "A map of the results of iterating a function over a fixed range of values"))
146 (defmethod initialize-instance :after ((self iteration-map) &rest args)
147 (declare (ignore args))
148 (setf (slot-value self 'map) (make-array (* (width-of self) (height-of self)) :element-type '(unsigned-byte 8))))
150 (defmethod result ((image iteration-map) i)
151 (aref (map-of image) i))
153 (defmethod (setf result) (value (image iteration-map) i)
154 (setf (aref (map-of image) i) value))
156 (defmethod indexxy ((image iteration-map) index)
157 (values (mod index (width-of image))
158 (rem index (width-of image))))
160 (defmethod xyindex ((image iteration-map) x y)
161 (+ x (* (width-of image) y)))
164 (defun make-iteration-mapper (iteration-map
165 iterated-function
166 escape-function)
167 "Create an function to creat an iteration map of function on the given surface,
168 in a region interpoalated between two region extents,"
169 #'(lambda (region-fn alpha max-evaluations)
170 (declare (type single-float alpha) (type fixnum max-evaluations))
171 (labels
172 ((evaluate-point (c)
173 "Evaluate the iteration function for a given point"
174 (declare (type (complex single-float) c))
175 (let ((z #C(0.0 0.0)))
176 (loop for eval-count of-type fixnum from 0 below max-evaluations
177 until (funcall escape-function z)
178 do (setf z (funcall iterated-function z c))
179 finally (return eval-count)))))
180 ;; work out the region we sample
181 (multiple-value-bind
182 (top-left bottom-right)
183 (funcall region-fn alpha)
184 (let*
185 ((difference (- bottom-right top-left))
186 (real-step (complex (/ (realpart difference)
187 (width-of iteration-map))
188 (- (imagpart difference))))
189 (imag-step (complex 0.0
190 (/ (imagpart difference)
191 (height-of iteration-map))))
192 (c top-left))
193 ;; iterate over the region
194 (dotimes (x (width-of iteration-map))
195 (dotimes (y (height-of iteration-map))
196 (setf (result iteration-map (xyindex iteration-map x y)) (evaluate-point c))
197 (incf c imag-step))
198 (incf c real-step))))
199 (values))))
201 ;; to do -- zoom in on a defined region via lerping to a target
202 ;; to do -- construct iteration map line by line
205 (defun make-limit-interpolator (&key start-top-left start-bottom-right
206 fin-top-left fin-bottom-right)
207 "Construct a function to lerp between two sets of limits"
208 (format t "Creating interpolator for ~A ~A ~A ~A~%"
209 start-top-left start-bottom-right fin-top-left fin-bottom-right)
210 #'(lambda (alpha)
211 (declare (type single-float alpha))
212 (values
213 ;; max
214 (+ start-top-left
215 (* (- fin-top-left start-top-left) alpha))
216 ;; to do -- min
217 (+ start-bottom-right
218 (* (- fin-bottom-right start-bottom-right) alpha)))))
220 (defun print-iteration-map (iteration-map width height)
221 (dotimes (y width)
222 (dotimes (x height)
223 (if (>= (result iteration-map (xyindex iteration-map x y)) *max-iterations*)
224 (format t "~C" #\*)
225 (format t "~C" #\Space)))
226 (format t "~%")))
228 ;;; TO DO -- update this and test sampling
229 ;; ;; quicky test
230 ;; (defun iteration-mapper-test (i-m width height max-iter)
231 ;; (let*
232 ;; ((interpolator (make-limit-interpolator
233 ;; :start-top-left #C(-2.0 -2.0)
234 ;; :start-bottom-right #C(2.0 2.0)
235 ;; :fin-top-left #C(-1.0 -1.0)
236 ;; :fin-bottom-right #C(1.0 1.0)))
237 ;; (i-mapper (make-iteration-mapper i-m #'mandelbrot width height max-iter
238 ;; interpolator)))
240 ;; (funcall i-mapper 0.0)
241 ;; (print-iteration-map i-m 64 64 max-iter)
242 ;; (funcall i-mapper 1.0)
243 ;; (print-iteration-map i-m 64 64 max-iter)))
245 ;; color maps
247 (defun get-red (color-list)
248 (cadr (assoc :red color-list)))
250 (defun get-green (color-list)
251 (cadr (assoc :green color-list)))
253 (defun get-blue (color-list)
254 (cadr (assoc :blue color-list)))
256 (defun get-point (color-list)
257 (cadr (assoc :point color-list)))
259 (defun calc-normal-alpha (start end alpha)
260 (* (- alpha start) (/ 1.0 (- end start))))
262 (defun lerp (v0 v1 alpha)
263 (round (+ v0
264 (* (- v1 v0) alpha))))
266 (defun add-point-to-color-list (color-list point &key red green blue)
267 (list
268 `((:red . ,red)
269 (:green . ,green)
270 (:blue . ,blue)
271 (:point . ,point))
272 color-list))
274 (defun add-points-to-color-list (color-list points)
275 (append
276 (loop
277 for point in points
278 collect
279 (destructuring-bind
280 (p &key red green blue)
281 point
282 `((:red ,red)
283 (:green ,green)
284 (:blue ,blue)
285 (:point ,p))))
286 color-list))
289 (defun sort-color-list (color-list)
290 (sort color-list
291 #'(lambda (x y)
292 (< (cadr (assoc :point x))
293 (cadr (assoc :point y))))))
295 (defun make-color-list-interpolator (color-list)
296 (let
297 ((sorted-color-list (sort-color-list color-list)))
298 (lambda (alpha)
299 (destructuring-bind
300 (start end)
301 (loop
302 for next-color in sorted-color-list
303 and color = nil then next-color
304 when (<= alpha (cadr (assoc :point next-color)))
305 return
306 (list color next-color))
307 (let
308 ((normal-alpha
309 (calc-normal-alpha
310 (get-point start)
311 (get-point end)
312 alpha)))
313 (values
314 (lerp (get-red start) (get-red end) normal-alpha)
315 (lerp (get-green start) (get-green end) normal-alpha)
316 (lerp (get-blue start) (get-blue end) normal-alpha)))))))
320 (defun render-fractal-map (iteration-map image color-interpolator)
321 (let
322 ((width (width-of image))
323 (height (height-of image))
324 (iter-limit (coerce *max-iterations* 'single-float)))
325 (loop for x from 0 below width do
326 (loop for y from 0 below height do
327 (multiple-value-bind
328 (red green blue)
329 (funcall color-interpolator
330 (/ (result iteration-map (xyindex iteration-map x y)) iter-limit))
331 (setf (pixel image (xyindex image x y))
332 (map-color-to-pixel
333 red green blue))))))
334 (update-image image)
335 (render image))
337 ;; to do -- check real == x & imag == y
338 (defun calc-iteration-map-limits (width height
339 sample-x sample-y
340 sample-width sample-height
341 top-left bottom-right)
342 "Given an iteration map with the given width and height, and a sample
343 at the given position and size, work out the real and imaginary
344 dimensions of the sample and return a suitable interpolation fn"
345 (let*
346 ((real-width
347 (realpart (- bottom-right top-left)))
348 (imag-width
349 (imagpart (- bottom-right top-left)))
350 (real-scale (/ real-width width))
351 (imag-scale (/ imag-width height)))
353 (make-limit-interpolator
354 :start-top-left top-left
355 :start-bottom-right bottom-right
356 :fin-top-left
357 (complex (* sample-x real-scale)
358 (* sample-y imag-scale))
359 :fin-bottom-right
360 (complex
362 (* sample-x real-scale)
363 (* sample-width real-scale))
365 (* sample-y imag-scale)
366 (* sample-height imag-scale))))))
368 (defclass sample (iteration-map)
369 ((x :accessor x-of :initarg :sample-x)
370 (y :accessor y-of :initarg :sample-y)
371 (colour-count :accessor colours-in :initform 0)))
373 ;; to do -- wouldn't it be better to pass in a function to this
374 ;; to operate on the sample and return a result, rather than
375 ;; building a huje list of samples?
376 (defun take-map-sample (iteration-map x y
377 sample-width sample-height)
378 "Return an sampled area in the iteration map"
379 (let
380 ((sample (make-instance 'sample
381 :sample-x x
382 :sample-y y
383 :width sample-width
384 :height sample-height)))
385 (dotimes (dx sample-width)
386 (dotimes (dy sample-height)
387 (setf (pixel sample (xyindex sample dx dy))
388 (pixel iteration-map (xyindex iteration-map (+ x dx) (+ y dy))))))
389 sample))
392 (defun sample-map (iteration-map width height sample-width sample-height sample-count)
393 "Return a list of random samples of areas of a given size in the
394 iteration map"
395 (iterate
396 (for sample-index from 0 below sample-count)
397 (for sample-x = (random (- width sample-width)))
398 (for sample-y = (random (- height sample-height)))
399 (collect
400 (take-map-sample iteration-map
401 sample-x sample-y sample-width sample-height))))
403 (defun sample-frequency (sample)
404 "Return the number of distinct colours in the sample"
405 (dotimes (color-index 255)
406 (when (find color-index (map-of sample))
407 (incf (colours-in sample)))))
410 (defun mandelbrot (z c)
411 "Evaluate an iteration of the mandelbrot set function."
412 (declare ((complex single-float) z c))
413 (the (complex single-float)
414 (+ (expt z 2) c)))
417 (defun norm-squared-escape (z)
418 "Return the squared normal of the complex number"
419 (declare ((complex single-float) z))
420 (let ((real-part (realpart z))
421 (imag-part (imagpart z)))
422 (declare (single-float real-part imag-part))
423 (>= (the single-float
424 (+ (expt real-part 2)
425 (expt imag-part 2)))
426 +squared-limit+)))
428 (defvar *esc-pressed* nil)
430 (cffi:defcallback key-callback :void ((key :int) (action :int))
431 (when (eql action glfw:+press+)
432 (cond
433 ((eql key glfw:+key-esc+) (setf *esc-pressed* t)
434 ))))
436 (cffi:defcallback window-size-callback :void ((width :int) (height :int))
437 (gl:viewport 0 0 width height))
443 ;; (sdl::update-surface :surface video-surface)
444 ;; (sdl::update-display video-surface)
445 ;; (when (= sample-index samples-between-extents)
446 ;; (let*
447 ;; ((sample-width (round (/ width 128)))
448 ;; (sample-height (round (/ height 128)))
449 ;; (sample-area (* sample-width sample-height)))
450 ;; (format t "Resampling using 42 samples of ~D x ~D pixels~%" sample-width sample-height)
451 ;; ;; time to resample
452 ;; (let*
453 ;; ((samples
454 ;; (sort
455 ;; (sample-map iteration-map width height
456 ;; sample-width sample-height
457 ;; 42)
458 ;; #'(lambda (sample0 sample1)
459 ;; (> (sample-frequency sample1)
460 ;; (sample-frequency sample0)))))
461 ;; (selected-sample
462 ;; (car samples)))
463 ;; (format t "Picking sample with frequency ~D~%"
464 ;; (sample-frequency (car samples)))
465 ;; (let*
466 ;; ((sample-x (cadr (assoc :sample-x selected-sample)))
467 ;; (sample-y (cadr (assoc :sample-y selected-sample))))
468 ;; (multiple-value-bind
469 ;; (start-top-left start-bottom-right)
470 ;; (funcall interpolator-fn 1.0)
471 ;; (setf interpolator-fn
472 ;; (calc-iteration-map-limits
473 ;; width height
474 ;; sample-x sample-y
475 ;; sample-width sample-height
476 ;; start-top-left start-bottom-right))
477 ;; (setf sample-index 0)))))))
480 (defparameter *texture-names* nil)
482 (defun init-gl ()
483 ;; Disable stuff that's likely to slow down glRenderPixels.
484 ;; (Omit as much of this as possible, when you know in advance
485 ;; that the OpenGL state will already be set correctly.)
486 (gl:enable gl:+texture-2d+)
487 (gl:matrix-mode gl:+projection+)
488 (gl:load-identity)
489 (gl:matrix-mode gl:+modelview+)
490 (gl:load-identity))
493 (defun end-gl ()
496 (defparameter *frame-count* 0)
497 (defparameter *height* 480)
498 (defparameter *width* 640)
499 (defparameter *max-iterations* 16)
502 (defparameter *max-frames* 128)
504 (defun pixel-toast ()
505 (glfw:with-init-window
506 ("Mandelbrot" *width* *height*)
507 (glfw::enable glfw:+key-repeat+)
508 (glfw:set-window-size-callback (cffi:callback window-size-callback))
509 (init-gl)
510 (glfw:set-key-callback (cffi:callback key-callback))
511 (glfw:swap-interval 1)
512 (let*
513 ((frame 0)
514 (image (make-instance 'rgba-image))
515 (iteration-map (make-instance 'iteration-map :width *width* :height *height*))
516 (color-list
517 (add-points-to-color-list
519 '((0.0 :red 255 :green 255 :blue 255)
520 (0.1 :red 64 :green 0 :blue 64)
521 (0.5 :red 0 :green 64 :blue 64)
522 (1.0 :red 64 :green 63 :blue 0))))
523 (color-interpolator
524 (make-color-list-interpolator color-list))
525 (region-fn
526 (make-limit-interpolator :start-top-left #C(-2.0 -2.0)
527 :start-bottom-right #C(2.0 2.0)
528 :fin-top-left #C(-1.0 -1.0)
529 :fin-bottom-right #C(1.0 1.0)))
530 (fractal-mapper (make-iteration-mapper
531 iteration-map
532 #'mandelbrot
533 #'norm-squared-escape)))
534 (setf cowl:*root-widget* (cowl::make-label "Yotta zoomer" :x 128 :y 128))
535 (make-image image :width *width* :height *height*)
536 (iterate
537 (while (and (not *esc-pressed*)
538 (eql (glfw:get-window-param glfw:+opened+) gl:+true+)
539 (< frame *max-frames*)))
540 (gl:clear gl:+color-buffer-bit+)
541 (setf (pixel image (xyindex image (random *width*) (random *height*))) (map-color-to-pixel 255 0 0))
542 (funcall fractal-mapper region-fn (coerce (/ frame *max-frames*) 'single-float) *max-iterations*)
543 (render-fractal-map iteration-map image color-interpolator)
544 (update-image image)
545 (render image)
546 (incf frame)
547 (cowl:layout-root)
548 (cowl:draw-root)
549 (glfw:swap-buffers)
550 (cl:sleep 0.1)
551 (format *debug-io* "Frame ~A ~%" frame))
552 (destroy-image image)
553 (end-gl)
554 (if (eql (glfw:get-window-param glfw:+opened+) gl:+true+)
555 (glfw:close-window))
556 (glfw:terminate))))
559 ;; (defparameter *image* nil)
560 ;; (glfw:with-init-window ("A Simple Example" 640 480)
561 ;; (gl:with-setup-projection
562 ;; (glu:perspective 45 4/3 0.1 50)
563 ;; (setf *image* (make-instance 'rgba-image))
564 ;; (make-image *image* :width 320 :height 200))
565 ;; (iterate
566 ;; (while (= cl-glfw:+true+ (cl-glfw:get-window-param cl-glfw:+opened+)))
567 ;; (gl:clear gl:+color-buffer-bit+)
568 ;; (gl:load-identity)
569 ;; (gl:translate-f 0 0 -5)
570 ;; (gl:rotate-f (* 10 (glfw:get-time)) 1 1 0)
571 ;; (gl:rotate-f (* 90 (glfw:get-time)) 0 0 1)
572 ;; (render *image*)
573 ;; (gl:with-begin gl:+triangles+
574 ;; (gl:color-3f 1 0 0) (gl:vertex-3f 1 0 0)
575 ;; (gl:color-3f 0 1 0) (gl:vertex-3f -1 1 0)
576 ;; (gl:color-3f 0 0 1) (gl:vertex-3f -1 -1 0))
577 ;; (cl-glfw:swap-buffers)))
579 ;; (defun pixel-toast (width height frames-between-samples)
580 ;; (glfw:with-open-window
581 ;; ("Mandelbrot" width height)
582 ;; (glfw::enable glfw:+key-repeat+)
583 ;; (glfw:swap-interval 0)
584 ;; (glfw:set-window-size-callback (cffi:callback window-size-callback))
585 ;; (glfw:set-key-callback (cffi:callback key-callback))
586 ;; (init-gl)
587 ;; (let*
588 ;; ((frame 0)
590 ;; )
594 ;; ;; to do -- maybe pass in interpolator to iteration-mapper
595 ;; ;; to do -- maybe have a n pass iteration map - do the escapes for 1 limit, then 2 limit
596 ;; (dglDrefun fractal-toast (width height samples-between-extents fn-iterations)
597 ;; (let*
598 ;; ((sample-index 0)
599 ;; (iteration-map (make-iteration-map
600 ;; ;; to do
601 ;; width height))
602 ;; (color-list
603 ;; (add-points-to-color-list
604 ;; nil
605 ;; '((0.0 :red 255 :green 255 :blue 255)
606 ;; (0.1 :red 64 :green 0 :blue 64)
607 ;; (0.5 :red 0 :green 64 :blue 64)
608 ;; (1.0 :red 64 :green 63 :blue 0))))
609 ;; (color-interpolator
610 ;; (make-color-list-interpolator color-list))
611 ;; (interpolator-fn
612 ;; (make-limit-interpolator :start-top-left #C(-2.0 -2.0)
613 ;; :start-bottom-right #C(2.0 2.0)
614 ;; :fin-top-left #C(-1.0 -1.0)
615 ;; :fin-bottom-right #C(1.0 1.0)))
616 ;; (iteration-mapper
617 ;; (make-iteration-mapper
618 ;; iteration-map
619 ;; #'mandelbrot
620 ;; #'norm-squared-escape
621 ;; width height
622 ;; fn-iterations
623 ;; interpolator-fn)))
624 ;; (declare (fixnum width height sample-index))
625 ;; (glfw:do-window ("Mandelbrot")
626 ;; ((glfw::enable glfw:+key-repeat+)
627 ;; (glfw:swap-interval 0)
628 ;; (glfw:set-window-size-callback (cffi:callback window-size-callback))
629 ;; (glfw:set-key-callback (cffi:callback key-callback))
630 ;; (init-gl))
631 ;; (render iteration-mapper (/ sample-index samples-between-extents))
632 ;; (incf sample-index)
633 ;; (glfw::swap-buffers))))