-
Notifications
You must be signed in to change notification settings - Fork 3
/
exp-Life.lisp
116 lines (111 loc) · 7.75 KB
/
exp-Life.lisp
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
;; -*- Mode:Lisp; Syntax:ANSI-Common-LISP; Coding:us-ascii-unix; fill-column:158 -*-
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;; @file exp-Life.lisp
;; @author Mitch Richling <https://www.mitchr.me>
;; @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 <https://www.mitchr.me> 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)))))