1 files changed, 131 insertions, 0 deletions
diff --git a/shen/life.shen b/shen/life.shen
new file mode 100644
index 0000000..6503042
--- /dev/null
+++ b/shen/life.shen
@@ -0,0 +1,131 @@
+(datatype subtype
+  (subtype B A); X : B;
+  _____________________
+  X : A;)
+ 
+(datatype integer
+  if (integer? X)
+  ___________
+  X: integer;
+ 
+  ________________________
+  (subtype integer number);)
+ 
+(datatype bit
+  if (< X 2)
+  _______
+  X: bit;
+ 
+  _____________________
+  (subtype bit integer);)
+ 
+(datatype row
+ 
+  _________
+  [] : row;
+ 
+  C : bit; Row : row;
+  ===================
+  [C | Row] : row;)
+ 
+(datatype universe
+ 
+  ______________
+  [] : universe;
+ 
+  R : row; Uni : universe;
+  ========================
+  [R | Uni] : universe;)
+ 
+(define conway-nth
+  \\ returns value of x from row if it exists, else 0
+  { number --> row --> bit }
+  _ [] -> 0
+  N _ -> 0 where (< N 0)
+  0 [A|B] -> A
+  N [A|B] -> (conway-nth (- N 1) B))
+
+(define row-retrieve
+  { number --> universe --> row }
+  _ [] -> []
+  0 [] -> []
+  0 [A|B] -> A
+  N [A|B] -> (row-retrieve (- N 1) B))
+ 
+(define cell-retrieve
+  { number --> number --> universe --> bit }
+  X Y Universe -> (conway-nth X (row-retrieve Y Universe)))
+ 
+(define neighbors
+  \\ takes an X and Y, retrieves the number of neighbors
+  { number --> number --> universe --> number }
+  X Y Universe -> (let Inc (+ 1)
+                       Dec (/. X (- X 1))
+                    (+ (cell-retrieve (Inc X) Y Universe)
+                       (cell-retrieve (Inc X) (Inc Y) Universe)
+                       (cell-retrieve (Inc X) (Dec Y) Universe)
+                       (cell-retrieve (Dec X) Y Universe)
+                       (cell-retrieve (Dec X) (Inc Y) Universe)
+                       (cell-retrieve (Dec X) (Dec Y) Universe)
+                       (cell-retrieve X (Inc Y) Universe)
+                       (cell-retrieve X (Dec Y) Universe))))
+
+(define handle-alive
+  { number --> number --> universe --> bit }
+  X Y Universe -> (if (or (= (neighbors X Y Universe) 2)
+                          (= (neighbors X Y Universe) 3))
+                      1 0))
+ 
+(define handle-dead
+  { number --> number --> universe --> bit }
+  X Y Universe -> (if (= (neighbors X Y Universe) 3)
+                      1 0))
+ 
+(define next-row
+  \\ first argument must be a previous row, second must be 0 when
+  \\ first called, third must be a Y value and the final must be the
+  \\ current universe
+  { row --> number --> number --> universe --> row }
+  [] _ _ _ -> []
+  [1|B] X Y Universe -> (cons (handle-alive X Y Universe)
+                              (next-row B (+ X 1) Y Universe))
+  [_|B] X Y Universe -> (cons (handle-dead X Y Universe)
+                              (next-row B (+ X 1) Y Universe)))
+ 
+(define next-universe
+  \\ both the first and second arguments must be the same universe,
+  \\ the third must be 0 upon first call
+  { universe --> number --> universe --> universe }
+  [] _ _ -> []
+  [Row|Rest] Y Universe -> (cons (next-row Row 0 Y Universe)
+                                 (next-universe Rest (+ Y 1) Universe)))
+ 
+(define display-row
+  { row --> number }
+  [] -> (nl)
+  [1|Rest] -> (do (output "* ")
+                  (display-row Rest))
+  [_|Rest] -> (do (output "  ")
+                  (display-row Rest)))
+ 
+(define display-universe
+  { universe --> number }
+  [] -> (nl 2)
+  [Row|Rest] -> (do (display-row Row)
+                    (display-universe Rest)))
+ 
+(define iterate-universe
+  { number --> universe --> number }
+  0 _ -> (nl)
+  N Universe -> (do (display-universe Universe)
+                    (iterate-universe (- N 1)
+                                      (next-universe Universe 0 Universe))))
+ 
+(iterate-universe
+ 10
+ [[0 0 0 0 0 0]
+  [0 0 0 0 0 0]
+  [0 0 1 1 1 0]
+  [0 1 1 1 0 0]
+  [0 0 0 0 0 0]
+  [0 0 0 0 0 0]])