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

17357 ワード
オブジェクト指向 emacs-lisp lisp プログラミング Emacs Emacs テキストリンク

「プログラムでシダを描画する」記事たちに触発されて、Emacs Lispで書いてみました。
sida.el をロードして、M-x sida で描画されます。
(バグとかご意見ありましたら https://twitter.com/akmiyoshi までお願いします)

sida.el
(require 'cl)
(require 'eieio)

(defconst *sida-inverted-xbm-image*
  (or (eq system-type 'windows-nt)
      (and (eq system-type 'cygwin) (string= (getenv "DISPLAY") "w32"))))
(defconst *sida-foreground-color* "green")
(defconst *sida-background-color* "white")

(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) 0)
(defun W4y ($x $y) (* 0.175337 $y))

(defclass <sida> ()
  ((width :initarg :width)
   (height :initarg :height)
   (bitmap :initarg :bitmap)
   (image :initarg :image)))

(defmethod initialize-instance :after ((this <sida>) &rest $slots)
  (assert (slot-boundp this 'width))
  (assert (slot-boundp this 'height))
  (with-slots (width height bitmap image) this
    (assert (zerop (% width 8)))
    (setf bitmap (make-bool-vector (* width height) nil))
    (setf image
          (apply
           #'create-image
           bitmap 'xbm t
           :width width
           :height height
           :relief 2
           :pointer 'arrow
           (if *sida-inverted-xbm-image*
               (list :foreground *sida-background-color*
                     :background *sida-foreground-color*)
             (list :foreground *sida-foreground-color*
                   :background *sida-background-color*))))))

(defmethod !f ((this <sida>) $k $x $y)
  (with-slots (width height) this
    (if (> $k 0)
        (loop for $i from 1 to 4 do
              (when (or (= $i 1) (< (random 10) 3))
                (!f this
                    (1- $k)
                    (funcall (intern (format "W%dx" $i)) $x $y)
                    (funcall (intern (format "W%dy" $i)) $x $y))))
      (!plot this
             (+ (* $x 490) (* width 0.5))
             (- height (* $y 490))))))

(defmethod !plot ((this <sida>) $x $y)
  (with-slots (width height bitmap) this
    (let (($x (truncate $x))
          ($y (truncate $y)))
      (cond
       ((< $x 0) nil)
       ((>= $x width) nil)
       ((< $y 0) nil)
       ((>= $y height) nil)
       (t (let (($index (+ (* width $y) $x)))
            (when (and (>= $index 0) (< $index (length bitmap)))
              (aset bitmap $index t))))))))

(defun sida ()
  (interactive)
  (let (($sida (make-instance <sida> :width 520 :height 500)))
    (with-slots (image) $sida
      (switch-to-buffer "<sida>")
      (remove-images (point-min) (point-max))
      (put-image image (point-min))
      (!f $sida 20 0 0))))