diff options
| -rw-r--r-- | basic.lsp | 218 | ||||
| -rwxr-xr-x | btech.lsp | 45 | ||||
| -rw-r--r-- | cap-muck.lsp | 2 | ||||
| -rw-r--r-- | doc/Makefile | 4 | ||||
| -rw-r--r-- | doc/lkbib.ms | 2 | ||||
| -rw-r--r-- | shen/basic.shen | 18 | ||||
| -rw-r--r-- | shen/life.shen | 131 | ||||
| -rw-r--r-- | shen/rms-defs.shen | 20 | ||||
| -rw-r--r-- | shen/rms-sysdep.lisp | 1 | ||||
| -rw-r--r-- | shen/rms.shen | 8 |
10 files changed, 339 insertions, 110 deletions
diff --git a/basic.lsp b/basic.lsp index 03e4edb..2fec591 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)) - (create (class <lsymbols>) 's c) + (create (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))) |