LoginSignup
22

More than 5 years have passed since last update.

posted at

updated at

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

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

2014-0528-0222.png

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))))

Register as a new user and use Qiita more conveniently

  1. You get articles that match your needs
  2. You can efficiently read back useful information
What you can do with signing up
22