;; -*- mode: lisp; syntax: common-lisp -*-

(defun cantor-dust (stream length iteration)
  (if (= iteration 0)
      (format stream "~f 0 rlineto~%~
                      0 ~:*~f rlineto~%~
                      ~:*-~f 0 rlineto~%~
                      0 ~:*-~f rlineto~%" length)
      (let ((new-length (/ length 4.0)))
        (format stream "0 ~f rmoveto~%" new-length)
        (cantor-dust stream new-length (1- iteration))
        (format stream "~f ~f rmoveto~%" new-length (* 2 new-length))
        (cantor-dust stream new-length (1- iteration))
        (format stream "~f -~f rmoveto~%" (* 2 new-length) new-length)
        (cantor-dust stream new-length (1- iteration))
        (format stream "-~f -~f rmoveto~%" new-length (* 2 new-length))
        (cantor-dust stream new-length (1- iteration))
        (format stream "-~f 0 rmoveto~%" (* 2 new-length)))))

(defun koch-curve (stream direction length iteration)
  (if (= iteration 0)
      (format stream "~f ~f rlineto~%"
              (* (cos direction) length) (* (sin direction) length))
      (let ((new-length (/ length 3.0)))
        (koch-curve stream direction new-length (1- iteration))
        (koch-curve stream (- direction (/ pi 3.0)) new-length (1- iteration))
        (koch-curve stream (+ direction (/ pi 3.0)) new-length (1- iteration))
        (koch-curve stream direction new-length (1- iteration)))))

(defun random-koch-curve (stream direction length iteration)
  (if (= iteration 0)
      (format stream "~f ~f rlineto~%"
              (* (cos direction) length) (* (sin direction) length))
      (let ((new-length (/ length 3.0)))
        (random-koch-curve stream direction new-length (1- iteration))
        (if (= (random 2) 0)
            (progn
              (random-koch-curve stream (- direction (/ pi 3.0))
                                 new-length (1- iteration))
              (random-koch-curve stream (+ direction (/ pi 3.0))
                                 new-length (1- iteration)))
            (progn
              (random-koch-curve stream (+ direction (/ pi 3.0))
                                 new-length (1- iteration))
              (random-koch-curve stream (- direction (/ pi 3.0))
                                 new-length (1- iteration))))
        (random-koch-curve stream direction new-length (1- iteration)))))

(defun hilbert-curve (stream size base)
  (when (/= size 0)
    (hilbert-curve stream (1- size) (reverse base))
    (format stream "~{~f ~}rlineto~%" (reverse base))
    (hilbert-curve stream (1- size) base)
    (format stream "~{~f ~}rlineto~%" base)
    (hilbert-curve stream (1- size) base)
    (format stream "~{~f ~}rlineto~%" (mapcar #'- (reverse base)))
    (hilbert-curve stream (1- size) (mapcar #'- (reverse base)))))

;;; Logo-like movements
(defparameter *directions* '((1 0) (0 1) (-1 0) (0 -1)))
(defvar *dir*)
(defun turn-left () (setf *dir* (mod (1+ *dir*) 4)))
(defun turn-right () (setf *dir* (mod (1- *dir*) 4)))
(defun advance (stream distance)
  (format stream "~{~f ~}rlineto~%"
          (mapcar (lambda (x) (* x distance))
                  (elt *directions* *dir*))))

(defun sierpinski-curve (stream size length)
  "As in The (New) Turing Omnibus.
Assumes that SIZE is a power of 2."
  (labels ((zig (n)
             (cond ((= n 1)
                    (turn-left)
                    (advance stream length)
                    (turn-left)
                    (advance stream length))
                   (t (zig (/ n 2))
                      (zag (/ n 2))
                      (zig (/ n 2))
                      (zag (/ n 2)))))
           (zag (n)
             (cond ((= n 1)
                    (turn-right)
                    (advance stream length)
                    (turn-right)
                    (advance stream length)
                    (turn-left)
                    (advance stream length))
                   (t (zag (/ n 2))
                      (zag (/ n 2))
                      (zig (/ n 2))
                      (zag (/ n 2))))))
    (setf *dir* 0)
    (zig size)
    (zig size)))

(defun write-image (filename x y image-function &rest arguments)
  (with-open-file (stream filename :direction :output :if-exists :supersede)
    (format stream "%!PS~%~
                    newpath~%~
                    0.1 setlinewidth~%~
                    ~f ~f moveto~%" x y)
    (apply image-function stream arguments)
    (format stream "stroke~%")))

;; (write-image "dust.ps" 20 300 #'cantor-dust 520 5)
;; (write-image "koch.ps" 100 300 #'koch-curve 0.0 300 5)
;; (write-image "random-koch.ps" 100 300 #'random-koch-curve 0.0 300 5)
;; (write-image "hilbert.ps" 10 320 #'hilbert-curve 6 '(8 0))
;; (write-image "/tmp/sierpinski.ps" 550 220 #'sierpinski-curve 64 4)