XOR texture in Common Lisp

xor_texture.lisp

(require :lispbuilder-sdl)

(defun run ()
  (sdl:with-init ()
    (sdl:window 320 240)
    (draw-xor-texture)
    (sdl:with-events ()
      (:quit-event () t)
      (:idle
       (sdl:update-display)))))

(defun draw-xor-texture ()
  (iter (for x below 320)
	(iter (for y below 240)
	      (let* ((c (bit-vector->integer
			 (bit-xor (adjust-array (integer->bit-vector x) '(8))
				  (adjust-array (integer->bit-vector y) '(8)))))
		     (color (sdl:color :r c :g c :b c)))
		(sdl:draw-pixel-* x y :clipping t :color color)))))

;;;; these 2 functions by edgar-rft taken from:
;;;; http://www.lispforum.com/viewtopic.php?f=2&t=1205#p6269

(defun bit-vector->integer (bit-vector)
  "Create a positive integer from a bit-vector."
  (reduce #'(lambda (first-bit second-bit)
              (+ (* first-bit 2) second-bit))
          bit-vector))

(defun integer->bit-vector (integer)
  "Create a bit-vector from a positive integer."
  (labels ((integer->bit-list (int &optional accum)
             (cond ((> int 0)
                    (multiple-value-bind (i r) (truncate int 2)
                      (integer->bit-list i (push r accum))))
                   ((null accum) (push 0 accum))
                   (t accum))))
    (coerce (integer->bit-list integer) 'bit-vector)))