(declaim (optimize debug))

(defvar *bucket*)
(defvar *pos*)
(defvar *mark*)
(defvar *delta*)
(defvar *tbucket* nil)
(defvar *bitmaps* nil)

(defparameter pipiiic (lambda ()
                        (push (list 0 0 0) *bucket*)))
(defparameter pipiiip (lambda ()
                        (push (list 255 0 0) *bucket*)))
(defparameter pipiicc (lambda ()
                        (push (list 0 255 0) *bucket*)))
(defparameter pipiicf (lambda ()
                        (push (list 255 255 0) *bucket*)))
(defparameter pipiicp (lambda ()
                        (push (list 0 0 255) *bucket*)))
(defparameter pipiifc (lambda ()
                        (push (list 255 0 255) *bucket*)))
(defparameter pipiiff (lambda ()
                        (push (list 0 255 255) *bucket*)))
(defparameter pipiipc (lambda ()
                        (push (list 255 255 255) *bucket*)))
(defparameter pipiipf (lambda ()
                        (push 0 *tbucket*)))
(defparameter pipiipp (lambda ()
                        (push 255 *tbucket*)))

(defparameter piipicp (lambda ()
                        (setf *bucket* nil *tbucket* nil)))

(defparameter piiiiip (lambda ()
                        (setf (car *pos*) (mod (+ (car *pos*)
                                                  (car *delta*))
                                               600)
                              (cdr *pos*) (mod (+ (cdr *pos*)
                                                  (cdr *delta*))
                                               600))))

(defparameter pcccccp (lambda ()
                        (rotatef (car *delta*) (cdr *delta*))
                        (setf (car *delta*) (- (car *delta*)))))

(defparameter pfffffp (lambda ()
                        (rotatef (car *delta*) (cdr *delta*))
                        (setf (cdr *delta*) (- (cdr *delta*)))))

(defparameter pcciffp (lambda ()
                        (setf *mark* (cons (car *pos*) (cdr *pos*)))))

(defparameter pfficcp (lambda ()
                        (let* ((deltax (- (car *mark*)
                                          (car *pos*)))
                               (deltay (- (cdr *mark*)
                                          (cdr *pos*)))
                               (d (max (abs deltax) (abs deltay)))
                               (c (if (<= (* deltax deltay) 0)
                                      1
                                      0))
                               (x (+ (* (car *pos*) d)
                                     (truncate (- d c) 2)))
                               (y (+ (* (cdr *pos*) d)
                                     (truncate (- d c) 2)))
                               (color (current-pixel)))
                          (declare (fixnum deltax deltay d c x y))
                          (dotimes (i d)
                            (setf (aref (the (simple-array
                                              (unsigned-byte 32)
                                              (600 600))
                                          (car *bitmaps*))
                                        (truncate x d)
                                        (truncate y d))
                                  color)
                            (incf x deltax)
                            (incf y deltay))
                          (setf (aref (the (simple-array
                                            (unsigned-byte 32)
                                            (600 600))
                                        (car *bitmaps*))
                                      (car *mark*)
                                      (cdr *mark*))
                                color))))


(defparameter piipiip
  (lambda ()
    (declare (optimize debug))
    (let* ((color (current-pixel))
           (bitmap (car *bitmaps*))
           (x (car *pos*))
           (y (cdr *pos*))
           (orig-color (aref bitmap x y)))
      (declare (type (simple-array (unsigned-byte 32)
                                   (600 600))
                     bitmap))
      (unless (eql color orig-color)
        (let ((queue (list (cons x y)))
              (count 0))
          (loop while queue
                for (x . y) = (pop queue)
                do (when (eql (aref bitmap x y) orig-color)
                     (incf count)
                     (setf (aref bitmap x y) color)
                     (when (> x 0) (push (cons (1- x) y) queue))
                     (when (< x 599) (push (cons (1+ x) y) queue))
                     (when (> y 0) (push (cons x (1- y)) queue))
                     (when (< y 599) (push (cons x (1+ y)) queue)))))))))

(defparameter pccpffp (lambda ()
                        (when (< (length (the list *bitmaps*)) 10)
                          (push (make-bitmap)
                                *bitmaps*))))

(defvar *counter* 0)

(defparameter pffpccp
  (lambda ()
    (declare (optimize speed))
    (unless (null (cdr *bitmaps*))
      (let ((b1 (pop *bitmaps*))
            (b2 (car *bitmaps*)))
        (declare (type (simple-array (unsigned-byte 32) (600 600)) b1 b2))
        (dotimes (x 600)
          (dotimes (y 600)
            (let* ((v1 (aref b1 x y))
                   (v2 (aref b2 x y))
                   (alpha (ldb (byte 8 24) v1)))
              (setf (aref b2 x y)
                    (macrolet ((x (n)
                                 `(ash (+ (ldb (byte 8 ,n) v1)
                                          (truncate (* (ldb (byte 8 ,n) v2)
                                                       (- 255 alpha))
                                                    255))
                                       ,n)))
                      (logior (x 0)
                              (x 8)
                              (x 16)
                              (x 24)))))))))))

(defparameter pfficcf
  (lambda ()
    (declare (optimize speed))
    (unless (null (cdr *bitmaps*))
      (let ((b1 (pop *bitmaps*))
            (b2 (car *bitmaps*)))
        (declare (type (simple-array (unsigned-byte 32) (600 600)) b1 b2))
        (dotimes (x 600)
          (dotimes (y 600)
            (let* ((v1 (aref b1 x y))
                   (v2 (aref b2 x y))
                   (alpha (ldb (byte 8 24) v1)))
              (setf (aref b2 x y)
                    (macrolet ((x (n)
                                 `(ash (truncate (* (ldb (byte 8 ,n) v2)
                                                    alpha)
                                                 255)
                                       ,n)))
                      (logior (x 0)
                              (x 8)
                              (x 16)
                              (x 24)))))))))))

(defun current-pixel ()
  (flet ((average (list default key)
           (if list
               (truncate (reduce #'+ list :key key)
                         (length list))
               default)))
    (let ((ac (average *tbucket* 255 #'identity)))
      (logior (truncate (* ac (average *bucket* 0 #'first)) 255)
              (ash (truncate (* ac (average *bucket* 0 #'second)) 255) 8)
              (ash (truncate (* ac (average *bucket* 0 #'third)) 255) 16)
              (ash ac 24)))))

(defun make-bitmap ()
  (make-array '(600 600) :initial-element 0 :element-type '(unsigned-byte 32)))

(defmacro with-rna-env (ops &body body)
  (declare (ignore ops))
  `(let ((*bucket* nil)
         (*tbucket* nil)
         (*counter* 0)
         (*pos* (cons 0 0))
         (*mark* (cons 0 0))
         (*bitmaps* (list (make-bitmap)))
         (*delta* (cons 0 1)))
     ,@body))

(defun handle-rna (rna)
  (let ((symbol (intern (coerce rna 'simple-base-string))))
    (if (boundp symbol)
        (funcall (symbol-value symbol))
        #+nil
        (format t "% ~a~%" symbol))))

(defun write-bitmap (file bitmap)
  (with-open-file (out file :direction :output :if-exists :supersede :if-does-not-exist :create :element-type '(unsigned-byte 32))
    (declare (type (simple-array (unsigned-byte 32) (600 600)) bitmap))
    (dotimes (x 600)
      (dotimes (y 600)
        (let ((color (aref bitmap x y)))
          (write-byte (ldb (byte 24 0) color)
                      out))))))

(defun write-raw ()
  (write-bitmap "/home/jsnell/prog/omat/lisp/icfp2007/build-new.raw.new"
                (car *bitmaps*))
  (rename-file "/home/jsnell/prog/omat/lisp/icfp2007/build-new.raw.new"
               "/home/jsnell/prog/omat/lisp/icfp2007/build-new.raw"))

(defun build ()
  (with-rna-env ()
    (dolist (rna (reverse *rna*))
      (handle-rna rna))
    (write-raw)))