From 67ef9fbf276a3f1490910abfcb2f8387f0944a95 Mon Sep 17 00:00:00 2001
From: Darren Bane <darren.bane@gmail.com>
Date: Tue, 2 Nov 2021 13:22:02 +0000
Subject: Some Shen code

---
 shen/basic.shen      |  18 +++++++
 shen/life.shen       | 131 +++++++++++++++++++++++++++++++++++++++++++++++++++
 shen/rms-defs.shen   |  20 ++++++++
 shen/rms-sysdep.lisp |   1 +
 shen/rms.shen        |   8 ++++
 5 files changed, 178 insertions(+)
 create mode 100644 shen/basic.shen
 create mode 100644 shen/life.shen
 create mode 100644 shen/rms-defs.shen
 create mode 100644 shen/rms-sysdep.lisp
 create mode 100644 shen/rms.shen

diff --git a/shen/basic.shen b/shen/basic.shen
new file mode 100644
index 0000000..89a998e
--- /dev/null
+++ b/shen/basic.shen
@@ -0,0 +1,18 @@
+(define priority-op
+  { symbol --> number }
+  not -> 1
+  uminus -> 7)
+
+(define pp-binop
+  { symbol --> string }
+  plus -> "+"
+  mult -> "*")
+
+(define parenthesis
+  { string --> string }
+  X -> (@s "(" X ")"))
+
+(define isdigit
+  { string --> boolean }
+  C -> (let CN (string->n C)
+         (and (>= CN (string->n "0")) (<= CN (string->n "9")))))
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]])
diff --git a/shen/rms-defs.shen b/shen/rms-defs.shen
new file mode 100644
index 0000000..7839a17
--- /dev/null
+++ b/shen/rms-defs.shen
@@ -0,0 +1,20 @@
+(define mean
+  { (list number) --> number }
+  Xs -> (/ (sum Xs) (length Xs)))
+ 
+(define square
+  { number --> number }
+  X -> (* X X))
+ 
+(define rms
+  { (list number) --> number }
+  Xs -> (sqrt (mean (map (function square) Xs))))
+ 
+(define iota-h
+  { number --> number --> (list number) }
+  X X -> [X]
+  X Lim -> (cons X (iota-h (+ X 1) Lim)))
+ 
+(define iota
+  { number --> (list number) }
+  Lim -> (iota-h 1 Lim))
diff --git a/shen/rms-sysdep.lisp b/shen/rms-sysdep.lisp
new file mode 100644
index 0000000..48dcd93
--- /dev/null
+++ b/shen/rms-sysdep.lisp
@@ -0,0 +1 @@
+(DEFUN sqrt (X) (SQRT X))
diff --git a/shen/rms.shen b/shen/rms.shen
new file mode 100644
index 0000000..f7a17cb
--- /dev/null
+++ b/shen/rms.shen
@@ -0,0 +1,8 @@
+(set *hush* true)
+(LOAD "rms-sysdep.lisp")
+(declare sqrt [number --> number])
+(specialise sqrt 1)
+(tc +)
+(load "rms-defs.shen")
+(set *hush* false)
+(output "~A~%" (rms (iota 10)))
-- 
cgit 1.4.1-2-gfad0