Merge branch 'master' of /home/dbane/public_repos/lsp into master

10 files changed, 135 insertions, 38 deletions

diff --git a/basic.lsp b/basic.lsp
index 7f13acd..11771e9 100644
--- a/basic.lsp
+++ b/basic.lsp
@@ -2,7 +2,7 @@
 
 (require "abs-syn")
 (require "lex")
-(require "parse")
+(require "parsing")
 (defpackage #:basic
   (:use #:openlisp)
   (:export
diff --git a/ccap-muck.lisp b/ccap-muck.lisp
new file mode 100644
index 0000000..d9de3b0
--- /dev/null
+++ b/ccap-muck.lisp
@@ -0,0 +1,72 @@
+(defvar *terminate-program* nil)
+
+(defconstant +bold+ "[1m")
+(defconstant +unbold+ "[0m")
+(defconstant +q+ #\")
+
+(defclass <avatar> () ((name :accessor name)
+                       (playing :reader playing :initform nil)
+                       (password :accessor password)))
+(defvar *avatars* '())
+
+(defvar *write-avatars* nil)
+
+(defclass <connection> () ((g :reader g)
+                           (socket :reader socket)
+                           (parser :reader parser)
+                           (avatar :reader avatar)
+                           (r :reader r)))
+(defvar *connections* '())
+
+(defconstant +port-number+ 6565)
+
+(defconstant +vd-type+ (vector 'n 's 'e 'w
+			       'u 'd))
+
+(defclass <room> () ((name :reader name)
+		     (desc :reader desc)
+		     (exits :reader exits)))
+(defvar *rooms* '())
+
+(defvar *write-rooms* nil)
+
+(defconstant +command-type+ (vector 'say 'help 'quit 'look
+				    'rooms 'make-room 'make-door 'teleport
+				    'n 's 'e 'w
+				    'u 'd 'password 'shutdown))
+
+(defconstant +name-prompt+ "Please enter your character name:")
+
+(defconstant +rdb+ "room.tam")
+(defconstant +adb+ "avatar.tam")
+
+;; TODO: should I use print-object & the reader for serialisation?
+(defun read-room-database ()
+  (with-open-file (file +rdb+ :direction :input)
+    ))
+
+(defun write-room-database ()
+  (with-open-file (file +rdb+ :direction output)
+    (mapcar (lambda (r)
+	      (format file "~A~%"
+
+(defun read-avatar-database ()
+  (setq *avatars* '())
+  (with-open-file (file +adb+ :direction :input)
+    (do ((name (read-line file nil nil))
+	 (password (read-line file nil nil)))
+	((or (null name) (null password)))
+      (let ((a (make-instance (find-class '<avatar>))))
+	(setf (name a) name)
+	(setf (password a) password)
+	(setq *avatars* (cons a *avatars*)))))
+  (setq *write-avatars* nil))
+
+(defun write-avatar-database ()
+  (with-open-file (file +adb+ :direction output)
+    (mapcar (lambda (a) (format file "~A~%~A~%" (name a) (password a))) *avatars*)))
+
+(read-avatar-database)
+(read-room-database)
+(while (not *terminate-program*)
+       (check-for-inputs))
diff --git a/cdbc.lisp b/cdbc.lisp
index 9d790ab..57e04e5 100644
--- a/cdbc.lisp
+++ b/cdbc.lisp
@@ -1,5 +1,7 @@
 ;; Ported from https://rosettacode.org/wiki/Assertions_in_design_by_contract#Eiffel
 ;; Arguably not *quite* design-by-contract, but very close in vanilla CL
+;;
+;; NB: This has non-essential complexity compared to the ISLisp version.
 (defun average-of-absolutes (values)
   (declare (list values))
   (assert (> (length values) 0))
diff --git a/clex.lisp b/clex.lisp
index cdd6025..7ca04f0 100644
--- a/clex.lisp
+++ b/clex.lisp
@@ -4,7 +4,10 @@
    #:<lint>
    #:<lsymbol>
    #:<lstring>
-   #:<lend>))
+   #:<lend>
+   #:<lident>
+   #:ident
+   #:lexer))
 (in-package #:clex)
 
 (defclass <lexeme> () () (:metaclass <abstract-class>))
@@ -55,4 +58,26 @@
                (and (char>= x #\0) (char<= x #\9))
                (char= x #\_))))
     (extract #'is-alpha-num cl)))
+
+(defgeneric lexer (cl))
+(defmethod lexer ((cl <string-lexer>))
+  (flet ((lexer-char (c)
+	   (cond ((member c '(#\space #\tab))
+		  (forward cl)
+		  (lexer cl))		; NB: tail recursion. ok?
+		 ((or (and (char>= c #\a) (char<= c #\z))
+		      (and (char>= c #\A) (char<= c #\Z)))
+		  (make-instance (find-class '<lident>) 'i (extract-ident cl)))
+		 ((char= c #\")
+		  (forward cl)
+		  (let ((res (make-instance (find-class '<lstring>) 's (extract (lambda (c) (char/= c #\")) cl))))
+		    (forward cl)
+		    res))
+		 ((member c '(#\+ #\- #\* #\/ #\% #\& #\| #\! #\= #\( #\)))
+		  (forward cl)
+		  (make-instance (find-class '<lsymbol>) 's (string c)))
+		 ((member c '(#\< #\>))
+		  (forward cl)
+		  
+  )
 (provide "clex")
diff --git a/cparse.lisp b/cparse.lisp
index 602dc76..31d7817 100644
--- a/cparse.lisp
+++ b/cparse.lisp
@@ -27,7 +27,7 @@
 	((string= s ">") 'great)))
 
 (defun parse (str)
-  (let* ((cl (init-lex str))
+  (let* ((cl (make-instance (find-class '<string-lexer>) 's str))
 	 (tok (lexer cl)))
     (cond ((instancep tok (find-class '<lint>))
 	   (make-instance (find-class '<line>) 'n n 'c (parse-cmd cl)))
diff --git a/cutil.lisp b/cutil.lisp
index e651b11..6b3f381 100644
--- a/cutil.lisp
+++ b/cutil.lisp
@@ -1,7 +1,8 @@
 (defpackage #:cutil
   (:use #:common-lisp)
   (:export
-   #:<abstract-class>))
+   #:<abstract-class>
+   #:instancep))
 (in-package #:cutil)
 
 (defclass <abstract-class> (standard-class) ())
@@ -18,4 +19,7 @@
 					   (superclass <abstract-class>))
   t)
 
+(defun instancep (obj cls)
+  (eq (class-of obj) cls))
+
 (provide "cutil")
diff --git a/doc/Makefile b/doc/Makefile
index 4139f63..8716885 100644
--- a/doc/Makefile
+++ b/doc/Makefile
@@ -6,7 +6,8 @@
 GEMINI := breaking_rules.gmi bane.20.cdr15.gmi
 
 .PHONY: all
-all: $(GEMINI) lkbib.txt
+all: $(GEMINI)
+# lkbib.txt can be made manually as needed
 
 # Write gfm.
 # Beyond that, YAGNI.
@@ -18,7 +19,7 @@ lkbib.txt: macros.ms lkbib.ms refs.i
 	groff -Tutf8 -R -ms -k -Kutf8 macros.ms lkbib.ms > $@
 
 %.gmi: %.md
-	md2gemini -m $^ > $@
+	md2gemini -m -l copy $^ > $@
 
 refs.i: refs
 	indxbib $^
@@ -29,4 +30,4 @@ clean:
 
 .PHONY: push
 push: $(GEMINI)
-	scp $^ dbane@republic.circumlunar.space:/usr/home/dbane/gemini/lsp_doc
+	scp -6 $^ dbane@republic.circumlunar.space:/usr/home/dbane/gemini/lsp_doc
diff --git a/doc/breaking_rules.md b/doc/breaking_rules.md
index 29f20d1..0c34594 100644
--- a/doc/breaking_rules.md
+++ b/doc/breaking_rules.md
@@ -55,8 +55,8 @@ without earning money.
 ## Design Decisions
 
 The programming language chosen is a particular style of Common Lisp.
-A clean subset of CL is desired,
-so cleave as [close to ISLisp](bane.20.cdr15.md) as practical[5].
+For readability my
+[ISLisp-like subset of CL](bane.20.cdr15.md) should be followed where practical[5].
 Reasons for this decision include:
 
 * Contrary to a lot of other languages, Lisp is fairly paradigm-agnostic.
@@ -92,7 +92,7 @@ Even though this is a prototype, attention should be paid to basic craftsmanship
 * Use `declare`
   to check the types of parameters in public interfaces (see below).
 * Indent all the source code using Emacs.
-* Some minimal documentation, at least an overview [README](https://tom.preston-werner.com/2010/08/23/readme-driven-development.html) file
+* Some minimal documentation, at least an overview like in [README driven development](https://tom.preston-werner.com/2010/08/23/readme-driven-development.html)
   and man (actually, [mdoc](https://manpages.bsd.lv/toc.html)) pages[7].
 * Certain parts of a system justify greater detail for a *complete* specification.
   These are (newly-designed) network protocols and complex persistent data models.
@@ -150,7 +150,7 @@ it may make sense to write the documentation (and contracts, and tests) "bottom-
 Depend only on GFM,
 in the same spirit as the software.
 The use of tools like
-PP and Pandoc should be minised.
+nw2md and Pandoc should be minised.
 PlantUML *should* be used where it can replace ad-hoc text.
 
 Documents should be stored under git in a "doc" subdirectory of the project.
@@ -189,6 +189,7 @@ However, some of this documentation is better in the source code:
 ```
 
 `lisp-critic` can be used to perform static analysis of the codebase.
+But it's not worth writing custom rules.
 
 ### UI
 
@@ -203,8 +204,8 @@ For productisation you may want to add more features.
 
 Although the official ANSI standard is moribund,
 quasi-standard libaries are recommended on the
-[awesome list](https://github.com/CodyReichert/awesome-cl),
-or [portability layers](http://portability.cl/).
+[Awesome-CL list](https://github.com/CodyReichert/awesome-cl),
+or [CL portability layers](http://portability.cl/).
 Usage should be limited as follows,
 in order of preference.
 The language/library split isn't as clear in CL as in some other languages,
@@ -231,7 +232,7 @@ System tests grow in parallel with the requirements spec.
 It's ok for system tests to use the same interfaces as the ltk code.
 All tests should be automated,
 except possibly for the UI/view layer.
-Q: These scripts could be generated from a literate test plan? A: yes, probably one of the few places to use "PP".
+Q: These scripts could be generated from a literate test plan? A: yes, probably one of the few places to use nw2md.
 
 As much of the testing work should be pushed "back" in the V model to contracts for the functions,
 following the pattern above.
diff --git a/echo.lsp b/echo.lsp
index 1fb1c89..b299eab 100755
--- a/echo.lsp
+++ b/echo.lsp
@@ -42,24 +42,16 @@
 (defun echo-server ()
    ;; Server side (server addr : 127.0.0.1)
    (with-server-socket (server 8192 "tcp")
-        (let ((fds (create-vector 16 ()))
-              (fdr (create-vector 16 ()))
-              (fdw (create-vector 16 ())))
-             (select-clear fds)
-             (select-add server fds)
-             (while (eq (select 1 fds fdr fdw () 5.0) 0)
-                    (print "Waiting ...."))
-             (let ((client (accept server)))
-                  ;; Talk with client using standard I/O.
-                  (with-standard-input client
-                     (with-standard-output client
-                          (while t
-                                 (let* ((line1 (read-line))
-                                        (tag-len (length +content-length+))
-                                        (content-length (convert (subseq line1 (- tag-len 1) (length line1)) <integer>)))
-                                       (read-line)
-                                       (marshal (json-parse (read-chars content-length)))))))
-                  (close client))
-             (select-remove server fds))))
+        (let ((client (accept server)))
+             ;; Talk with client using standard I/O.
+             (with-standard-input client
+                (with-standard-output client
+                     (while t
+                            (let* ((line1 (read-line))
+                                   (tag-len (length +content-length+))
+                                   (content-length (convert (subseq line1 (- tag-len 1) (length line1)) <integer>)))
+                                  (read-line)
+                                  (marshal (json-parse (read-chars content-length)))))))
+             (close client))))
 (provide "echo")
 (echo-server)
diff --git a/parse.lsp b/parsing.lsp
index 9bedee3..3e26a35 100644
--- a/parse.lsp
+++ b/parsing.lsp
@@ -1,14 +1,14 @@
-(defpackage #:parse
+(defpackage #:parsing
   (:use #:openlisp #:lex #:abs-syn)
   (:export
    #:parse))
-(in-package #:parse)
+(in-package #: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-lp> (<exp-elem) ())
+(defclass <elem-lp> (<exp-elem>) ())
 
 (defun unr-symb (s)
   (cond ((string= s "!") 'not)
@@ -30,7 +30,7 @@
   (let* ((cl (init-lex str))
 	 (tok (lexer cl)))
     (cond ((instancep tok (class <lint>))
-	   (make-instance (class <line>) 'n n 'c (parse-cmd cl)))
+	   (create (class <line>) 'n n 'c (parse-cmd cl)))
 	  ((instancep tok (class <lident>))
 	   (cond ((string= (ident tok) "LIST")
 		  (create (class <phrase-list>)))
@@ -40,4 +40,4 @@
 		  (create (class <phrase-p-end>)))
 		 (t (error "Parse error"))))
 	  (t (error "Parse error")))))
-(provide "parse")
+(provide "parsing")