Thursday, 24 April 2008

Mandelbrot generator in Common Lisp

A couple of months back I had a bad flu and couldn't really do much so of course I wrote a Mandelbrot generator. This took me between .5 hr to 1 hr so go easy on me. Just dug it up today b/c of a discussion I was having so thought I'd post it here. It uses cl-opengl.

(in-package #:cl-glut-examples)

(progn (setq glut::*argcp* (cffi:null-pointer) glut::*argv* (cffi:null-pointer)))(glut:init)

(defclass mandelbrot-window (glut:window)
((image :initform nil
:accessor image)
(width :initarg :width
:accessor width)
(height :initarg :height
:accessor height)
(need-recalc :initform t
:accessor need-recalc)
(real-extents :initarg :real-extents
:accessor real-extents)
(imag-extents :initarg :imag-extents
:accessor imag-extents))
(:default-initargs :pos-x 100 :pos-y 100
:mode '(:single :rgb) :title "mandelbrot.lisp"))

(defmethod glut:display-window :before ((w mandelbrot-window))
;; Select clearing color.
(gl:clear-color 0 0 0 0)
;; Initialize viewing values.
(gl:matrix-mode :projection)
(gl:ortho 0 1 0 1 -1 1))

(defmethod glut:display ((w mandelbrot-window))
(gl:clear :color-buffer)
(gl:raster-pos 0 0)
(when (need-recalc w)
(format t "Need to recalc...~%")
(format t "Real: ~A Imag: ~A~%" (real-extents w) (imag-extents w))
(setf (image w) (calculate-mandelbrot-image (width w) (height w) :real (real-extents w) :imag (imag-extents w) :max-iterations 256))
(setf (need-recalc w) nil)
(format t "Done...~%"))
(gl:draw-pixels (image-width (image w)) (image-height (image w)) :rgb :unsigned-byte (image-1darray (image w)))

(defun rb-mandelbrot (width height &key (max-iterations 1000) (real '(-1.5 1.5)) (imag '(-1.5 1.5)))
(make-instance 'mandelbrot-window
:width width :height height
:real-extents real :imag-extents imag)))
; :image (calculate-mandelbrot-image width height :real real :imag imag :max-iterations max-iterations))))

(defun midpoint (lst)
(/ (+ (first lst) (second lst))

(defmethod glut:keyboard ((w mandelbrot-window) key x y)
(with-slots (real-extents imag-extents) w
(let ((imag-delta (* 4 (/ (- (second imag-extents) (first imag-extents)) (height w))))
(real-delta (* 4 (/ (- (second real-extents) (first real-extents)) (width w))))
(imag-midpoint (midpoint imag-extents))
(real-midpoint (midpoint real-extents)))
(case key
(incf (first imag-extents) imag-delta)
(incf (second imag-extents) imag-delta))
(incf (first imag-extents) (* 10 imag-delta))
(incf (second imag-extents) (* 10 imag-delta)))
(incf (first imag-extents) (- imag-delta))
(incf (second imag-extents) (- imag-delta)))
(incf (first imag-extents) (* 10 (- imag-delta)))
(incf (second imag-extents) (* 10 (- imag-delta))))
(incf (first real-extents) (- real-delta))
(incf (second real-extents) (- real-delta)))
(incf (first real-extents) real-delta)
(incf (second real-extents) real-delta))
(let ((imag-midpoint-distance (- imag-midpoint (first imag-extents)))
(real-midpoint-distance (- real-midpoint (first real-extents))))
(setf (first imag-extents) (- (first imag-extents) imag-midpoint-distance))
(setf (second imag-extents) (+ (second imag-extents) imag-midpoint-distance))
(setf (first real-extents) (- (first real-extents) real-midpoint-distance))
(setf (second real-extents) (+ (second real-extents) real-midpoint-distance))))
(setf (first imag-extents) (midpoint (list (first imag-extents)
(setf (second imag-extents) (midpoint (list imag-midpoint
(second imag-extents))))
(setf (first real-extents) (midpoint (list (first real-extents)
(setf (second real-extents) (midpoint (list real-midpoint
(second real-extents))))))
(case key
((#\w #\s #\a #\d #\W #\D #\A #\S)
(setf (need-recalc w) t)
(setf (real-extents w) real-extents)
(setf (imag-extents w) imag-extents)))))

(defun make-image (w h)
(let* ((underlying-array (make-array (* w h 3) :element-type '(unsigned-byte 8)
:initial-element 0))
(displaced-array (make-array (list w h 3) :element-type '(unsigned-byte 8)
:displaced-to underlying-array)))

(list w h underlying-array displaced-array)))

(defun image-width (image)
(first image))

(defun image-height (image)
(second image))

(defun image-1darray (image)
(third image))

(defun image-3darray (image)
(fourth image))

(defun set-colour (image x y iterations-taken max-iterations)
(let (depth)
(if (= iterations-taken max-iterations)
(setf depth 0)
(setf depth (truncate (* 255 (/ iterations-taken 1000))))))
(let ((r (min 180 (* 20 depth)))
(g (min 180 (* 5 depth)))
(b (min 180 (* 1 depth)))
(data (image-3darray image)))
(setf (aref data x y 0) r)
(setf (aref data x y 1) g)
(setf (aref data x y 2) b))))

(defun within-radius (z)
(let ((r (realpart z))
(i (imagpart z)))
(<= (+ (* r r) (* i i))

(defun calculate-mandelbrot-image (width height &key (max-iterations 1000)
(real '(-1.5 1.5))
(imag '(-1.5 1.5)))
(let* ((image (make-image width height))
(low-real (first real))
(high-real (second real))
(low-imag (first imag))
(high-imag (second imag))
(real-length (- high-real low-real))
(imag-length (- high-imag low-imag))
(real-by (/ real-length width))
(imag-by (/ imag-length height)))
(flet ((do-it (start-x end-x start-cr)
for x from start-x to end-x
for cr from start-cr by real-by
for y below height
for ci from low-imag by imag-by
(let* ((c (complex cr ci))
for z = c then (+ (* z z) c)
for iteration from 0 below max-iterations
while (within-radius z)
count iteration)))
(set-colour image (truncate x) (truncate y) iterations-taken max-iterations))))))
(let* ((end-x (truncate (/ width 2)))
(threads (list (sb-thread:make-thread (lambda ()
(do-it 0 end-x low-real)))
(sb-thread:make-thread (lambda ()
(do-it (1+ end-x) (1- width) (+ (* end-x real-by) low-real)))))))
(loop for thread in threads
do (sb-thread:join-thread thread))))

Monday, 21 April 2008

The secret to making money online

The secret to making money online.

I know I haven't posted on it much, but this guy says it all.

Sunday, 13 April 2008

Weblocks: Presentations

When Slava set out to write Weblocks, he claims to have a goal to never write HTML again. The way he proposed to accomplish this was through the use of presentations. You can see an example of his UI-DSL. I don't claim to understand the UI-DSL but I do understand how presentations work and I like them!

I set out to add support for money for something I am working on. So first, I wanted to be able to validate/display a number. Simple enough. First thing I did was define a new type so I can change it later into something that handles currencies properly:

(deftype money () 

There are basically two things you need to be able to do (depending on context): parse and display. Obviously, presentations are responsible for the display while parsers are responsible for ... parsing!
(defun parse-money (string)
(read-from-string string))

(defun format-money-display (amount)
;; Note the extra "$"
(format nil "$~4$" amount))

(defun format-money-input (amount)
(format nil "~d" amount))

The reason there are two format functions is that you need to format the value for display or for editing. The latter is named format-money-input.

The protocol calls the generic functions weblocks:typespec->view-field-presentation and weblocks:typespec->form-view-field-parser depending on what the scaffold is rendering. The purpose of these functions is to take a typespec and create the corresponding presentation or parser.

You can have form scaffolds in addition to the regular scaffold. You would use the form scaffold when the method of display would be different. For example, for a boolean input you would use a checkbox for form input, whereas when simply rendering for display, you could use "true" or "false" or "yes" or "no".

In this case, I don't need anything this drastic, so I defined the functions as follows:
(defmethod weblocks:typespec->view-field-presentation (scaffold
(typespec (eql 'money)) args)
(values t (make-instance 'money-presentation)))

(defmethod weblocks:typespec->form-view-field-parser ((scaffold form-scaffold)
(typespec (eql 'money)) args)
(values t (make-instance 'money-parser)))

In this case, the money-presentation and money-parser types are just tags to make the generic function machinery work. The types are defined as follows:

(defclass money-presentation (weblocks:text-presentation weblocks:input-presentation)

(defclass money-parser (parser)
(:default-initargs :error-message "a money value (for example, 100.51 or 4.52)")
(:documentation "A parser designed to parse strings into

Using :default-initargs you can define an error message that will be seen when parsing fails (for whatever reason).

When Weblocks has your parser and presentation types, it then calls the following generic functions depending on the rendering context:

  • weblocks:print-view-field-value

  • weblocks:parse-view-field-value

  • weblocks:render-view-field-value

You won't believe it, but there is barely any HTML involved. I love it!

(defmethod weblocks:print-view-field-value (value
(presentation money-presentation)
field view widget obj &rest args)
(declare (ignore args))
(format-money-display value))

(defmethod weblocks:parse-view-field-value ((parser money-parser)
value obj
(view form-view) (field form-view-field)
&rest args)
(declare (ignore args))
(declare (optimize safety))
(let* ((presentp (text-input-present-p value))
(money-value (when presentp
(parse-money value))))
(values t presentp money-value))))

(defmethod weblocks:render-view-field-value (value (presentation money-presentation)
(field form-view-field)
(view form-view)
widget obj &rest args)
(declare (ignore args))
(render-text-input (view-field-slot-name field)
(format-money-input value)
:maxlength 50))

An example of usage would be:
(defclass transaction ()
((id :accessor transaction-id)
(date :initform (get-universal-time)
:accessor transaction-date
:initarg :date)
(amount :initform *default-money-value*
:accessor transaction-amount
:initarg :amount
:type money)))

And that is all you need to add your own reusable type to Weblocks. Not bad. Haven't added a date type yet, but will soon.