ランダムドットをつかった立体視画像作成

今日は休み時間に暇だったので、立体視の画像を作成するアルゴリズムを実装し
指定した文字列が見える、指定したサイズの画像を生成する関数を作成しました。

(ql:quickload :vecto)
(ql:quickload :flexi-streams)
(ql:quickload :opticl)

(defun create-random-dot-img (width height)
  (declare (optimize (speed 3) (safety 0)))
  (let ((img (opticl:make-8-bit-gray-image height width)))
    (opticl:fill-image img 0 0 0)
    (loop for y below height
          do
          (loop for x below width
                when (zerop (random 2))
                do
                (setf (opticl:pixel img y x) 
                      (values 255 255 255))))
    img))

(defun calc-font-size (font-loader width height msg)
  (loop for size = 3 then (1+ size)
        for msg-bound = (vecto:string-bounding-box msg size font-loader)
        while (let* ((msg-width (- (aref msg-bound 2) (aref msg-bound 0)))
                     (msg-height (- (aref msg-bound 3) (aref msg-bound 1))))
                (and (<= msg-width width) (<= msg-height height)))
        finally (return (values size msg-bound))))

(defun create-text-img (text width height &optional (padding 0))
  (vecto:with-canvas (:width width :height height)
        (let ((font (vecto:get-font "/usr/share/fonts/truetype/msttcorefonts/Courier_New.ttf")))
          (multiple-value-bind (size bound) (calc-font-size font (- width (* padding 2)) (- height (* padding 2)) text)
            (vecto:set-font font size)
            (vecto:set-rgb-fill 0 0 0)
            (vecto:rectangle 0 0 width height)
            (vecto:fill-path)
            (vecto:stroke)
            (vecto:set-rgb-fill 1.0 1.0 1.0)
            (vecto:set-rgb-stroke 0.5 0.5 0.5)
            (vecto:draw-centered-string (- (/ width 2) (aref bound 0))
                                        (- (/ height 2) (/ (- (aref bound 3) (aref bound 1)) 2))
                                  text)
            (vecto:stroke)
            (with-open-stream (s (flexi-streams:make-in-memory-output-stream 
                                   :element-type '(unsigned-byte 8)))
              (vecto:save-png-stream s)
              (opticl:read-png-stream (flexi-streams:make-in-memory-input-stream 
                                        (flexi-streams:get-output-stream-sequence s))))))))

(defun make-sird-img (text width height &optional (padding 0))
  (let* ((msg-img (create-text-img text width height padding))
         (dot-img-width (ash width -4))
         (dot-img (create-random-dot-img  dot-img-width height))
         (res-img (opticl:make-8-bit-gray-image height width)))
    (loop for x from 0 below width
          for dot-img-x = (mod x dot-img-width)
          for crr-step = (truncate x dot-img-width)
          while (< x width)
          do
          (loop for y from 0 below height
                if (zerop (opticl:pixel msg-img y x))
                do
                (setf (opticl:pixel res-img y x)
                      (opticl:pixel (if (zerop crr-step) dot-img res-img) y
                                    (if (zerop crr-step)
                                      dot-img-x
                                      (+ (* (1- crr-step) dot-img-width) dot-img-x))))
                else
                do
                (loop for shft from 0 upto 4
                      do
                      (setf (opticl:pixel res-img y (- x shft))
                            (opticl:pixel (if (zerop crr-step) dot-img res-img) y
                                          (if (zerop crr-step)
                                            dot-img-x
                                            (+ (* (1- crr-step) dot-img-width) dot-img-x)))))))
    res-img))