;; -*- Mode:Lisp; Syntax:ANSI-Common-LISP; Coding:us-ascii-unix; fill-column:158 -*- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;; @file exp-Life.lisp ;; @author Mitch Richling ;; @brief Read in a life RLE file, and iterate (dumping a TGA at each step) until the pattern cycles.@EOL ;; @std Common Lisp ;; @copyright ;; @parblock ;; Copyright (c) 2012,2015, Mitchell Jay Richling All rights reserved. ;; ;; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: ;; ;; 1. Redistributions of source code must retain the above copyright notice, this list of conditions, and the following disclaimer. ;; ;; 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions, and the following disclaimer in the documentation ;; and/or other materials provided with the distribution. ;; ;; 3. Neither the name of the copyright holder nor the names of its contributors may be used to endorse or promote products derived from this software ;; without specific prior written permission. ;; ;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE ;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE ;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS ;; OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT ;; LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH ;; DAMAGE. ;; @endparblock ;; @filedetails ;; ;; Render a movie like this: ;; convert exp-Life-OUT-*.tga -sample 800% exp-Life-ART.gif ;; convert -define gif:size=200x200 exp-Life-ART.gif -thumbnail '200x200>' -background white -gravity Center -extent 190x190 exp-Life-ART-t.gif ;; rm exp-Life-OUT-???.tga ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (declaim (optimize (speed 3) (safety 0) ( debug 0) (compilation-speed 0))) (time (let* ((shop 't) (padn 10) (shap (with-open-file (in-file "exp-Life-IN.rle" :direction :input) (let* ((header (loop for line = (read-line in-file nil) while line when (not (equal #\# (aref line 0))) do (return line))) (rledata (with-output-to-string (str-strm) (loop for char = (read-char in-file nil) while char when (mjr_char_in-class char "0123456789bo$!") do (format str-strm "~a" char))))) (if shop (format 't "HEADER: ~a~%" header)) (if shop (format 't " RLE: ~a~%" rledata)) (multiple-value-bind (xwid pos1) (parse-integer header :start (position-if #'mjr_char_digitsp header) :junk-allowed 't) (multiple-value-bind (ywid) (parse-integer header :start (position-if #'mjr_char_digitsp header :start pos1) :junk-allowed 't) (if shop (format 't " X: ~a~%" xwid)) (if shop (format 't " Y: ~a~%" ywid)) (let ((x 0) (y 0) (len 1) (p 0) (img (make-array (list xwid ywid) :initial-element 0))) (flet ((don (live num) (loop for i from 1 upto num do (setf (aref img x y) (if live 1 0)) do (incf x)) (setf len 1) (incf p))) (loop for c = (aref rledata p) do (if shop (format 't "~5a ~5a ~5a ~5a ~5a ~15a ~%" x y p c len (subseq rledata p (min (+ 15 p) (1- (length rledata)))))) do (cond ((equal c #\b) (don nil len)) ((equal c #\o) (don 't len)) ((equal c #\$) (progn (setf x 0) (incf y len) (incf p) (setf len 1))) ((mjr_char_digitsp c) (multiple-value-bind (nlen npos) (parse-integer rledata :start p :junk-allowed 't) (setf p npos len nlen)))) until (equal c #\!) finally (return img))))))))) (xmax (+ padn padn (first (array-dimensions shap)))) (ymax (+ padn padn (second (array-dimensions shap)))) (seed (make-array (list xmax ymax))) (img1 (make-array (list xmax ymax))) (img2 (make-array (list xmax ymax)))) (declare (fixnum xmax ymax)) (dotimes (y (- ymax padn padn)) (dotimes (x (- xmax padn padn)) (setf (aref seed (+ padn x) (+ padn y)) (aref shap x y) (aref img1 (+ padn x) (+ padn y)) (aref shap x y)))) (mjr_tga_from-array "exp-Life-OUT-000.tga" seed :color-space :cs-bit :color-packing :cp-none) (loop for i from 1 upto 200 for old-img = (if (evenp i) img2 img1) for new-img = (if (evenp i) img1 img2) do (if shop (format 't "CYCLE: ~10a~%" i)) do (loop for y fixnum from 0 upto (1- ymax) do (loop for x fixnum from 0 upto (1- xmax) for nc = (loop for xd in '(-1 0 1 -1 1 -1 0 1) for yd in '(-1 -1 -1 0 0 1 1 1) count (not (zerop (aref old-img (mod (+ x xd) xmax) (mod (+ y yd) ymax))))) do (if (zerop (aref old-img x y)) (if (= nc 3) (setf (aref new-img x y) 1) (setf (aref new-img x y) 0)) (if (or (< nc 2) (> nc 3)) (setf (aref new-img x y) 0) (setf (aref new-img x y) 1))))) do (mjr_tga_from-array (format nil "exp-Life-OUT-~3,'0d.tga" i) new-img :color-space :cs-bit :color-packing :cp-none) until (if (equalp new-img old-img) (progn (format 't "STABLE STATE FOUND: ~d~%" i) 't)) until (if (equalp new-img seed) (progn (format 't "PERIOD FOUND: ~d~%" i) 't)))))