forked from forestfoxx/Serial-Experiments-Lain
-
Notifications
You must be signed in to change notification settings - Fork 0
/
CRowView.CL
127 lines (114 loc) · 4.01 KB
/
CRowView.CL
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
117
118
119
120
121
122
123
124
125
126
127
;;; ****************************************************************
;;; Conway's Game of Life ******************************************
;;; ****************************************************************
;;; Don't know where/when got this. --mk
(defstruct (world (:print-function
(lambda (s d o)
(declare (ignore d))
(format s "#<WORLD: ~D>" (world-numdots world)))))
size
current
numdots
next
(xmin 1000000) ; Initialize the region to ridiculous numbers.
(xmax -1)
(ymin 1000000)
(ymax -1))
(defun setnext (world i j)
(let* ((current (world-current world))
(next (world-next world))
(neighbors (count-neighbors current i j)))
;; set the next bit pattern
(if (zerop (bit current i j))
(cond ((not (= neighbors 3))
;; current = 0, surrounding cells != 3
(setf (bit next i j) 0))
(t (setf (bit next i j) 1)
;; current = 0, surrounding cells = 3
(incf (world-numdots world))))
(cond ((or (= neighbors 2)
(= neighbors 3))
;; current = 1, surrounding cells = 2,3
(setf (bit next i j) 1))
(t (setf (bit next i j) 0)
(decf (world-numdots world)))))
;; reset the bounds, if necessary
(unless (zerop (bit next i j))
(when (< i (world-xmin world)) (setf (world-xmin world) i))
(when (> i (world-xmax world)) (setf (world-xmax world) i))
(when (< j (world-ymin world)) (setf (world-ymin world) j))
(when (> j (world-ymax world)) (setf (world-ymax world) j)))))
(defun count-neighbors (array i j)
(+ (bit array (1- i) (1- j))
(bit array i (1- j))
(bit array (1+ i) (1- j))
(bit array (1- i) j)
(bit array (1+ i) j)
(bit array (1- i) (1+ j))
(bit array i (1+ j))
(bit array (1+ i) (1+ j))))
(defun next-cycle (world)
(let* ((lim (world-size world))
(current (world-current world))
(next (world-next world))
(xlb (max 1 (1- (world-xmin world))))
(xub (min (- lim 2) (1+ (world-xmax world))))
(ylb (max 1 (1- (world-ymin world))))
(yub (min (- lim 2) (1+ (world-ymax world)))))
(dotimes (i (1+ (- xub xlb)))
(dotimes (j (1+ (- yub ylb)))
(setnext world (+ i xlb) (+ j ylb))))
(dotimes (y lim)
(dotimes (x lim)
(setf (bit current x y) (bit next x y))))))
(defun print-world (world generations)
(let ((lim (world-size world))
(current (world-current world)))
(dotimes (y lim)
(dotimes (x lim)
(if (zerop (bit current y x))
(princ " ")
(princ "*")))
(terpri))
(format t "~&~d Generations, ~d Organisms."
generations (world-numdots world))))
(defun propagate (world cycles)
(print-world world cycles)
(do ()
((zerop (world-numdots world))
(format t "~2&POPULATION 0 ... ~d generations" cycles))
(next-cycle world)
(incf cycles)
(print-world world cycles)))
(defun life (source)
(let* ((size (length (car source)))
(life (make-world
:size size
:current (make-array (list size size) :element-type 'bit
:initial-contents source)
:next (make-array (list size size) :element-type 'bit
:initial-element 0)
:numdots 0)))
(dotimes (i size)
(dotimes (j size)
(unless (zerop (bit (world-current life) i j))
(incf (world-numdots life))
(when (< i (world-xmin life)) (setf (world-xmin life) i))
(when (> i (world-xmax life)) (setf (world-xmax life) i))
(when (< j (world-ymin life)) (setf (world-ymin life) j))
(when (> j (world-ymax life)) (setf (world-ymax life) j)))))
(propagate life 0)))
#|
;;; Example:
(setq test
'((0 0 0 0 0 0 0 0)
(0 0 0 1 1 0 1 0)
(0 0 1 0 1 0 1 0)
(0 0 1 1 1 0 0 0)
(0 1 0 0 1 1 1 0)
(0 1 1 1 0 0 0 0)
(0 0 0 1 1 0 1 0)
(0 0 0 0 0 0 0 0)))
(life test)
|#
;;; *EOF*