Merge branch 'master' of tilde.institute:public_repos/lsp

10 files changed, 339 insertions, 110 deletions

diff --git a/basic.lsp b/basic.lsp
index 5209832..a355ed0 100644
--- a/basic.lsp
+++ b/basic.lsp
@@ -13,12 +13,12 @@
 (defclass <exp-bin> (<expression>) ((exp1 :accessor exp1) (op :accessor op) (exp2 :accessor exp2)))
 
 (defclass <command> () () (:abstractp t))
-(defclass <cmd-rem> (<command>) ((rem :accessor rem)))
-(defclass <cmd-goto> (<command>) ((goto :accessor goto)))
+(defclass <cmd-rem> (<command>) ((rem :initarg r :accessor rem)))
+(defclass <cmd-goto> (<command>) ((goto :initarg g :accessor goto)))
 (defclass <cmd-print> (<command>) ((expr :accessor expr)))
-(defclass <cmd-input> (<command>) ((var :accessor var)))
-(defclass <cmd-if> (<command>) ((expr :accessor expr) (num :accessor num)))
-(defclass <cmd-let> (<command>) ((var :accessor var) (expr :accessor expr)))
+(defclass <cmd-input> (<command>) ((var :initarg v :accessor var)))
+(defclass <cmd-if> (<command>) ((expr :initarg e :accessor expr) (num :initarg n :accessor num)))
+(defclass <cmd-let> (<command>) ((var :initarg v :accessor var) (expr :initarg e :accessor expr)))
 
 (defclass <line> () ((num :accessor num) (cmd :accessor cmd)))
 
@@ -29,33 +29,33 @@
 (defclass <phrase-p-end> (<phrase>) ())
 
 (defun priority-uop (unr-op)
-  (case unr-op
-    ((not) 1)
-    ((uminus) 7)))
+   (case unr-op
+         ((not) 1)
+         ((uminus) 7)))
 
 (defun priority-binop (bin-op)
-  (cond ((member bin-op '(mult div)) 6)
-    ((member bin-op '(plus minus)) 5)
-    ((eql bin-op 'mod) 4)
-    ((member bin-op '(equal less lesseq great greateq diff)) 3)
-    ((member bin-op '(and or)) 2)))
+   (cond ((member bin-op '(mult div)) 6)
+         ((member bin-op '(plus minus)) 5)
+         ((eql bin-op 'mod) 4)
+         ((member bin-op '(equal less lesseq great greateq diff)) 3)
+         ((member bin-op '(and or)) 2)))
 
 ;;; Program pretty printing
 (defun pp-binop (bin-op)
-  (case bin-op
-    ((plus) "+")
-    ((mult) "*")
-    ((mod) "%")
-    ((minus) "-")
-    ((div) "/")
-    ((equal) " = ")
-    ((less) " < ")
-    ((lesseq) " <= ")
-    ((great) " > ")
-    ((greateq) " >= ")
-    ((diff) " <> ")
-    ((and) " & ")
-    ((or) " | ")))
+   (case bin-op
+         ((plus) "+")
+         ((mult) "*")
+         ((mod) "%")
+         ((minus) "-")
+         ((div) "/")
+         ((equal) " = ")
+         ((less) " < ")
+         ((lesseq) " <= ")
+         ((great) " > ")
+         ((greateq) " >= ")
+         ((diff) " <> ")
+         ((and) " & ")
+         ((or) " | ")))
 
 (defun pp-unrop (unr-op)
    (case unr-op
@@ -156,8 +156,8 @@
       (let* ((st (string cl))
              (pos (current cl))
              (res (ext pos)))
-         (setf (current cl) res)
-         (subseq (string cl) pos (- res pos)))))
+            (setf (current cl) res)
+            (subseq (string cl) pos (- res pos)))))
 
 ;; Some functions from C's ctype.h:
 (defun isdigit (c)
@@ -197,11 +197,11 @@
                          res))
                    ((member c '(#\+ #\- #\* #\/ #\% #\& #\| #\! #\= #\( #\)))
                     (forward cl)
-                    (create (class <lsymbol>) 's c))
+                    (create (class <lsymbol>) 's (create-string 1 c)))
                    ((or (char= c #\<) (char= c #\>))
                     (forward cl)
                     (if (>= (current cl) (size cl))
-                        (crate (class <lsymbols>) 's c)
+                        (crate (class <lsymbol>) 's (create-string 1 c))
                         (let ((cs (elt (string cl) (current cl))))
                              (cond ((and (char= c #\<) (char= cs #\=))
                                     (forward cl)
@@ -213,7 +213,7 @@
                                     (forward cl)
                                     (create (class <lsymbol>) 's "<>"))
                                    (t
-                                    (create (class <lsymbol>) c))))))
+                                    (create (class <lsymbol>) 's (create-string 1 c)))))))
                    (t (error "Lexer error")))))
       (if (>= (current cl) (size cl))
           (create (class <lend>))
@@ -222,48 +222,110 @@
 ;;; Parsing
 (defclass <exp-elem> () () (:abstractp t))
 (defclass <elem-exp> (<exp-elem>) ((expr :accessor expr)))
-(defclass <elem-bin> (<exp-elem>) ((bin-op :accessor bin-op)))
-(defclass <elem-unr> (<exp-elem>) ((unr-op :accessor unr-op)))
+(defclass <elem-bin> (<exp-elem>) ((bin-op :initarg o :accessor bin-op)))
+(defclass <elem-unr> (<exp-elem>) ((unr-op :initarg o :accessor unr-op)))
 (defclass <elem-lp> (<exp-elem>) ())
 
 (defun unr-symb (s)
-  (cond ((string= s "!") 'not)
-	((string= s "-") 'uminus)
-	(t (throw 'parse-failure))))
+   (case-using #'string= s
+               (("!") 'not)
+	           (("-") 'uminus)
+	           (t (error "Parse error"))))
 
 (defun bin-symb (s)
-  (cond ((string= s "+") 'plus)
-	((string= s "-") 'minus)
-	((string= s "*") 'mult)
-	((string= s "/") 'div)
-	((string= s "%") 'mod)
-	((string= s "=") 'equal)
-	((string= s "<") 'less)
-	((string= s "<=") 'lesseq)
-	((string= s ">") 'great)
-    ((string= s ">=") 'greateq)
-    ((string= s "<>") 'diff)
-    ((string= s "&") 'and)
-    ((string= s "|") 'or)
-    (t (throw 'parse-failure))))
+   (case-using #'string= s
+               (("+") 'plus)
+	           (("-") 'minus)
+	           (("*") 'mult)
+	           (("/") 'div)
+	           (("%") 'mod)
+	           (("=") 'equal)
+	           (("<") 'less)
+	           (("<=") 'lesseq)
+	           ((">") 'great)
+               ((">=") 'greateq)
+               (("<>") 'diff)
+               (("&") 'and)
+               (("|") 'or)
+               (t nil)))
 
 (defun tsymb (s)
-   (catch 'parse-failure (lambda 
+   (let ((maybe-bin (bin-symb s)))
+        (if (null maybe-bin)
+            (create (class <elem-unr>) 'o (unr-symb s))
+            (create (class <elem-bin>) 'o maybe-bin))))
+
+(defun reduce (pr)
+   )
+
+(defun stack-or-reduce (lex stack)
+   )
+
+(defun reduce-all (st)
+   (cond ((null st) (error "Parse error"))
+         ((and (= (length st) 1) (instancep (car st) (class <elem-exp>))) (expr (car st)))
+         (t (reduce-all (reduce 0 st)))))
+
+(defun parse-exp (stop cl)
+   (let ((p 0))
+        (flet ((parse-one (stack)
+                  (setq p (current cl))
+                  (let ((l (lexer cl)))
+                       (if (not (stop l))
+                           (parse-one (stack-or-reduce l stack))
+                           (progn (setf (current cl) p)
+                                  (reduce-all stack))))))
+           (parse-one '()))))
+
+(defun parse-cmd (cl)
+   (let ((tok (lexer cl)))
+        (if (instancep tok (class <lident>))
+            (case-using #'string= (ident tok)
+                        (("REM")
+                         (create (class <cmd-rem>) 'r (extract (lambda (x) t) cl)))
+                        (("GOTO")
+                         (create (class <cmd-goto>) 'g (let ((tok (lexer cl)))
+                                                            (if (instancep tok (class <lint>))
+                                                                (int tok)
+                                                                (error "Parse error")))))
+                        (("INPUT")
+                         (create (class <cmd-input>) 'v (let ((tok (lexer cl)))
+                                                             (if (instancep tok (class <lident>))
+                                                                 (ident tok)
+                                                                 (error "Parse error")))))
+                        (("PRINT")
+                         (create (class <cmd-print>) 'e (parse-exp (lambda (x) (instancep x (class <lend>))) cl)))
+                        (("LET")
+                         (let ((l2 (lexer cl))
+                               (l3 (lexer cl)))
+                              (if (and (instancep l2 (class <lident>)) (instancep l3 (class <lsymbol>)) (string= (lsymbol l3) "="))
+                                  (create (class <cmd-let>) 'v (ident l2) 'e (parse-exp (lambda (x) (instancep x <lend>)) cl))
+                                  (error "Parse error"))))
+                        (("IF")
+                         (let ((test (parse-exp (lambda (x) (and (instancep x <lident>) (string= (ident x) "THEN"))) cl)))
+                              (progn (lexer cl)
+                                     (let ((tok (lexer cl)))
+                                          (if (instancep tok (class <lint>))
+                                              (create (class <cmd-if>) 'e test 'n (int tok))
+                                              (error "Parse error"))))))
+                        (t (error "Parse error")))
+            (error "Parse error"))))
 
 (defun parse (str)
-  (let* ((cl (init-lex str))
-	 (tok (lexer cl)))
-    (cond ((instancep tok (class <lint>))
-	   (create (class <line>) 'n n 'c (parse-cmd cl)))
-	  ((instancep tok (class <lident>))
-	   (cond ((string= (ident tok) "LIST")
-		  (create (class <phrase-list>)))
-		 ((string= (ident tok) "RUN")
-		  (create (class <phrase-run>)))
-		 ((string= (ident tok) "END")
-		  (create (class <phrase-p-end>)))
-		 (t (error "Parse error"))))
-	  (t (error "Parse error")))))
+   (let* ((cl (init-lex str))
+	      (tok (lexer cl)))
+         (cond ((instancep tok (class <lint>))
+	            (create (class <line>) 'n n 'c (parse-cmd cl)))
+	           ((instancep tok (class <lident>))
+	            (case-using #'string= (ident tok)
+                            (("LIST")
+		                     (create (class <phrase-list>)))
+		                    (("RUN")
+		                     (create (class <phrase-run>)))
+		                    (("END")
+		                     (create (class <phrase-p-end>)))
+		                    (t (error "Parse error"))))
+	           (t (error "Parse error")))))
 
 ;;; Evaluation
 (defclass <value> () () (:abstractp t))
@@ -282,21 +344,21 @@
 
 ;;;; Assembly
 (defun lookup-index (tprog num-line)
-  (block result-lookup-index
-    (for ((i 0 (+ i 1)))
-      ((>= i (length tprog)))
-      (let ((num-i (num (elt tprog i))))
-        (if (= num-i num-line)
-          (return-from result-lookup-index i)
-          (if (> num-i num-line)
-            (return-from result-lookup-index -1)))))
-    -1))
+   (block result-lookup-index
+          (for ((i 0 (+ i 1)))
+               ((>= i (length tprog)))
+               (let ((num-i (num (elt tprog i))))
+                    (if (= num-i num-line)
+                        (return-from result-lookup-index i)
+                        (if (> num-i num-line)
+                            (return-from result-lookup-index -1)))))
+          -1))
 
 (defun assemble (prog)
-  (let ((tprog (apply #'vector prog)))
-    (for ((i 0 (+ i 1)))
-      ((>= i (length tprog)))
-      ())))
+   (let ((tprog (apply #'vector prog)))
+        (for ((i 0 (+ i 1)))
+             ((>= i (length tprog)))
+             ())))
 
 ;;;; Expression evaluation
 (defgeneric eval-exp (n envt expr))
diff --git a/btech.lsp b/btech.lsp
index 5a4d11b..07b0d48 100755
--- a/btech.lsp
+++ b/btech.lsp
@@ -1,27 +1,18 @@
-#!/home/dbane/openlisp-10.9.0/uxlisp -shell
-;;; ISLisp is fine so long as you do "read-line" from the same place you call the entry point fun.
-;;; So -shell with an immediate call doesn't work, something is closed after reading the Lisp source.
-;;; -shell -keep, supplying the call from the keyboard works fine.
-;;;
-;;; Calling entry point from a Lisp CLI (after "load") also works.
-;;; And this may be what I end up with, if I'm doing a view in Emacs.
-(require "cmd")
-(require "builtins")
-(defpackage #:btech
-  (:use #:cmd #:builtins)
-  (:export
-    #:main))
-(in-package #:btech)
-;; Favour symbols & objects over C-like numbers
-(defconstant +cmds+ (list
-                      (create-tab #'bt-quit "QUIT" 1)
-                      (create-tab #'help "help" 2)
-                      (create-tab #'look "look" 2)))
-(defun main ()
-  (read-line)                           ; Throw away LF
-  (format (standard-output) "> ")
-  (let* ((tab (lookup (parse (read-line)) +cmds+))
-          (f (fun tab)))
-    (funcall f)))                       ; I *think* this is better than (flet ...
-(provide "btech")
-(main)
+(defclass <unit> () ((name :initarg n :reader name)
+                     (tp :initarg tp :reader tp)
+                     (pv :initarg p :reader pv)))
+(defconstant +mad-3r+ (create (class <unit>)
+                              'n 'marauder
+                              'tp 'bm
+                              'p 42
+                              'sz 3
+                              'tmm 1
+                              'mv 8
+                              'role 'sniper
+                              'skill 3
+                              'damage #(2 3 3)
+                              'ov 1
+                              'a 0
+                              's 0
+                              'crit
+                              'id))
diff --git a/cap-muck.lsp b/cap-muck.lsp
index 36bffba..54bfa9a 100644
--- a/cap-muck.lsp
+++ b/cap-muck.lsp
@@ -183,5 +183,3 @@
   (while (not *terminate-program*)
          (check-for-inputs)))
 (main)
-
-
diff --git a/doc/Makefile b/doc/Makefile
index baad9d1..27cc51e 100644
--- a/doc/Makefile
+++ b/doc/Makefile
@@ -15,8 +15,8 @@ all: $(GEMINI)
 # None of setting GROFF_NO_SGR, using the "-c" option,
 # or piping through ul worked.
 # GROFF_NO_SGR=1 groff -Tutf8 -R -ms -k -Kutf8 -c macros.ms lkbib.ms | ul > $@
-lkbib.txt: macros.ms lkbib.ms refs.i
-	groff -Tutf8 -R -ms -k -Kutf8 macros.ms lkbib.ms > $@
+lkbib.txt: lkbib.ms refs.i
+	groff -Tutf8 -R -ms -k -Kutf8 lkbib.ms > $@
 
 %.gmi: %.md
 	md2gemini -m -l copy --code-tag lisp $^ > $@
diff --git a/doc/lkbib.ms b/doc/lkbib.ms
index d9e095c..4d26493 100644
--- a/doc/lkbib.ms
+++ b/doc/lkbib.ms
@@ -5,7 +5,7 @@ accumulate
 References
 .AU
 Darren Bane
-.L= sec 1 refs
+.SH
 References
 .IP 1.
 .[
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)))