「プログラムでシダを描画する」をCommon Lispで描画する

fern.lisp

;;;; Last modified: 2014-05-31 11:11:23 tkych

;;====================================================================
;; Plot Fern
;;====================================================================
;;
;; Usage
;; -----
;;
;;  * (load (compile-file "./fern.lisp"))
;;  * (fern:plot 20 "./fern.png")
;;
;;
;; References
;; ----------
;;
;;  - プログラムでシダを描画する - 強火で進め
;;    http://d.hatena.ne.jp/nakamura001/20140505/1399316565
;;
;;  - ZPNG - Create PNG files from Common Lisp
;;    http://www.xach.com/lisp/zpng/
;; 
;;--------------------------------------------------------------------

(in-package #:cl-user)

(eval-when (:compile-toplevel :load-toplevel :execute)
  (ql:quickload "ZPNG"))

(defpackage #:fern
  (:use #:cl)
  (:export #:plot)
  (:import-from #:zpng
                #:png
                #:data-array
                #:write-png))

(in-package #:fern)

;;--------------------------------------------------------------------

(defun W1x (x y) (+ (*  0.836 x) (*  0.044 y)))
(defun W1y (x y) (+ (* -0.044 x) (*  0.836 y) 0.169))
(defun W2x (x y) (+ (* -0.141 x) (*  0.302 y)))
(defun W2y (x y) (+ (*  0.302 x) (*  0.141 y) 0.127))
(defun W3x (x y) (+ (*  0.141 x) (* -0.302 y)))
(defun W3y (x y) (+ (*  0.302 x) (*  0.141 y) 0.169))
(defun W4x (x y) (declare (ignore x y)) 0)
(defun W4y (x y) (declare (ignore x)) (* 0.175337 y))

(defun plot (n file &key (width 500) (height 500))
  (let* ((png (make-instance 'zpng:png :width width :height height
                                       :color-type :truecolor-alpha))
         (data (zpng:data-array png)))
    (labels ((f (k x y)
               (if (plusp k)
                   (progn
                     (f (1- k) (W1x x y) (W1y x y))
                     (when (< (random 10) 3)
                       (f (1- k) (W2x x y) (W2y x y)))
                     (when (< (random 10) 3)
                       (f (1- k) (W3x x y) (W3y x y)))
                     (when (< (random 10) 3)
                       (f (1- k) (W4x x y) (W4y x y))))
                   (let* ((s 490)
                          (xi (floor (+ (* x s) (* 0.5 width))))
                          (yi (floor (- height (* y s)))))
                     ;; RGBA: Red=0, Green=1, Blue=2, Alpha=3
                     (setf (aref data xi yi 1) 255)
                     (setf (aref data xi yi 3) 255)))))
      (f n 0 0))
    (zpng:write-png png file)))


;;====================================================================