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

9 files changed, 239 insertions, 72 deletions

diff --git a/cbtech.lisp b/cbtech.lisp
index 15eda5a..15eda5a 100755..100644
--- a/cbtech.lisp
+++ b/cbtech.lisp
diff --git a/cbutton.lisp b/cbutton.lisp
new file mode 100644
index 0000000..d94052b
--- /dev/null
+++ b/cbutton.lisp
@@ -0,0 +1,18 @@
+(ql:quickload "ltk")
+(defpackage :cbutton
+  (:use :common-lisp :ltk)
+  (:export #:main))
+
+(in-package :cbutton)
+
+(defun main ()
+  (setf *debug-tk* nil)
+  (with-ltk ()
+    (wm-title *tk* "Test1")
+    (let ((b (make-instance 'button
+			    :master nil
+			    :text "Push here"
+			    :command (lambda ()
+				       (format *standard-output* "Pushbutton activated; normal termination.~%")
+				       (setf *exit-mainloop* t)))))
+      (pack b))))
diff --git a/ccap-muck.lisp b/ccap-muck.lisp
index d9de3b0..9037d98 100644
--- a/ccap-muck.lisp
+++ b/ccap-muck.lisp
@@ -1,7 +1,15 @@
+(require "split-sequence")              ; TODO: really used?
+(defpackage #:ccap-muck
+  (:use #:common-lisp #:split-sequence)
+  (:export
+   #:main)
+  )
+(in-package #:ccap-muck)
+
 (defvar *terminate-program* nil)
 
-(defconstant +bold+ "[1m")
-(defconstant +unbold+ "[0m")
+(defvar +bold+ "#\esc[1m")    ; TODO: (alexandria:define-constant ...)
+(defvar +unbold+ "#\esc[0m")
 (defconstant +q+ #\")
 
 (defclass <avatar> () ((name :accessor name)
@@ -15,58 +23,161 @@
                            (socket :reader socket)
                            (parser :reader parser)
                            (avatar :reader avatar)
-                           (r :reader r)))
+                           (curr-room :reader curr-room)))
 (defvar *connections* '())
 
 (defconstant +port-number+ 6565)
 
-(defconstant +vd-type+ (vector 'n 's 'e 'w
-			       'u 'd))
+(defvar +vd-type+ #(n s e w u d))  ; TODO: alexandria again
 
 (defclass <room> () ((name :reader name)
-		     (desc :reader desc)
-		     (exits :reader exits)))
+                     (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 +command-type+ #(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 first-substr (s)
+  "Return the first substring of s (delimited by a space)."
+  (block result-first-substr
+    (do ((i 0 (+ i 1)))
+        ((>= i (length s)) s)
+      (if (char= (elt s i) #\space)
+          (return-from result-first-substr (subseq s 0 i))))))
+
+(defun rest-substr (s)
+  "Return the second part of s."
+  (block result-rest-substr
+    (let ((b nil))
+      (do ((i 0 (+ i 1)))
+          ((>= i (length s)) "")
+        (if (char= (elt s i) #\space)
+            (setq b t)
+            (if b
+                (return-from result-rest-substr (subseq s i (length s)))))))))
+
+(defun command (s)
+  (block result-command
+    (do ((i 0 (+ i 1)))
+        ((>= i (length +command-type+)) 'say)
+      (let ((c (elt +command-type+ i)))
+        (if (string= s (symbol-name c))
+            (return-from result-command c))))))
+
+(defun format-name (c)
+  (concatenate 'string +bold+ (name (avatar c)) +unbold+))
+
+(defun say (c s)
+  (if (g c)
+      (format (socket c) "~A~%" s)))
+
+(defun broadcast (s)
+  (do ((cs *connections* (cdr cs)))
+      ((null cs))
+    (let ((c (car cs)))
+      (say c s))))
+
+(defun say (r s)
+  (do ((cs *connections* (cdr cs)))
+      ((null cs))
+    (let ((c (car cs)))
+      (if (eq (curr-room c) r)
+          (say c s)))))
+
+(defun look (c)
+  (say c (concatenate 'string "Room: " (name (curr-room c))))
+  (do ((ds (desc (curr-room c)) (cdr ds)))
+      ((null ds))
+    (let ((d (car ds)))
+      (say c (line d))))
+  (say c "")
+  (say c "Exits:")
+  (do ((i 0 (+ i 1)))
+      ((>= i (length +vd-type+)))
+    (let ((e (elt (exits (curr-room c)) i)))
+      (if (not (null e))
+          (say c (concatenate 'string " " (symbol-name (elt +vd-type+ i)) " " (name e))))))
+  (say c "Avatars:")
+  ())
+
+;; TODO: Use the reader, for prototype at least?
+;;       Can switch to postmodern for production.
 (defun read-room-database ()
+  (setq *rooms* '())
   (with-open-file (file +rdb+ :direction :input)
-    ))
+    (flet ((read-desc ()
+             (let ((ls '()))
+               (do ((l (read-line file) (read-line file)))
+                   ((string= l ".") ls)
+                 (setq ls (cons l ls)))))
+           (skip-lines (n)
+             (do ((i 0 (+ i 1)))
+                 ((> i n))
+               (read-line file))))
+      (do ((name (read-line file nil nil))
+           (desc (read-desc)))
+          ((or (null name) (null desc)))
+        (skip-lines (length +vd-type+))
+        (let ((r (make-instance (find-class '<room>))))
+          (setf (name r) name)
+          (setf (desc r) desc)
+          (setq *rooms* (cons r *rooms*))))
+      (file-position file 0)
+      ())))
+
+(defmethod print-object ((obj <room>) stream)
+  (flet ((write-desc (ds)
+           (mapcar (lambda (l)
+                     (format stream "~A~%" l))
+                   ds))
+         (write-exits (es)
+           (do ((i 0 (+ i 1)))
+               ((> i (length +vd-type+)))
+             (if (null (elt es) i)
+                 (format stream "nil~%")
+                 (format stream "~A~%" (name (elt es i)))))))
+    (format stream "~A~%" (name r))
+    (write-desc (desc r))
+    (format stream ".~%")
+    (write-exits (exits r))))
 
 (defun write-room-database ()
   (with-open-file (file +rdb+ :direction output)
-    (mapcar (lambda (r)
-	      (format file "~A~%"
+    (mapcar (lambda (r) (print-object r file)) *rooms*))
+  (setq *write-rooms* nil))
 
 (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)))
+         (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*)))))
+        (setf (name a) name)
+        (setf (password a) password)
+        (setq *avatars* (cons a *avatars*)))))
   (setq *write-avatars* nil))
 
+(defmethod print-object ((obj <avatar>) stream)
+  (format stream "~A~%~A~%" (name a) (password a)))
+
 (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))
+    (mapcar (lambda (a) (print-object a file)) *avatars*)))
+
+(defun main ()
+  (read-avatar-database)
+  (read-room-database)
+  (while (not *terminate-program*)
+         (check-for-inputs)))
+(provide "ccap-muck")
diff --git a/cconv.lisp b/cconv.lisp
index 1d4f949..b0e4479 100644
--- a/cconv.lisp
+++ b/cconv.lisp
@@ -1,11 +1,41 @@
+(ql:quickload "ltk")
 (defpackage :cconv
   (:use :common-lisp :ltk)
   (:export #:main))
 
 (in-package :cconv)
 
-(defun main ()
+;; (defun main ()
+;;   (setf *debug-tk* nil)
+;;   (with-ltk ()
+;;     (wm-title *tk* "Feet to Meters")
+;;     (let ((mainframe (make-instance 'frame)))
+;;       (configure mainframe :padding "3 3 12 12")
+;;       ())))
+
+(defun calculate (feet-widget meter-widget)
+  (setf (text meter-widget) (format nil "~,2F" (* (read-from-string (text feet-widget)) 0.3048d0))))
+
+(defun gui ()
   (setf *debug-tk* nil)
   (with-ltk ()
-    (wm-title "." "Feet to Meters")
-    ()))
+    (wm-title *tk* "Feet to Meters")
+    (let ((c (make-instance 'frame)))
+      (grid c 0 0 :sticky "ne")
+      (grid-columnconfigure *tk* 0 :weight 1)
+      (grid-rowconfigure *tk* 0 :weight 1)
+      (let* ((c.feet (grid (make-instance 'entry :width 7)
+                           1 2 :sticky "we" :padx 5 :pady 5))
+             (c.meters (grid (make-instance 'entry :state "readonly")
+                             2 2 :sticky "we" :padx 5 :pady 5)))
+        (grid (make-instance 'button
+                             :text "Calculate"
+                             :command (lambda () (calculate c.feet c.meters)))
+              3 3 :sticky "w" :padx 5 :pady 5)
+        (grid (make-instance 'label :text "feet")
+              1 3 :sticky "w" :padx 5 :pady 5)
+        (grid (make-instance 'label :text "is equivalent to")
+              2 1 :sticky "w" :padx 5 :pady 5)
+        (grid (make-instance 'label :text "meters")
+              2 3 :sticky "w" :padx 5 :pady 5)))))
+(provide "cconv")
diff --git a/cecho.lisp b/cecho.lisp
index 9624712..d5c61b6 100644
--- a/cecho.lisp
+++ b/cecho.lisp
@@ -1,5 +1,5 @@
 (ql:quickload "jsonrpc")
-(require "jsonrpc")                     ; Required?
+(require "jsonrpc")
 (defun main ()
   (let ((server (jsonrpc:make-server)))
     (jsonrpc:expose server "subtract" (lambda (args)
diff --git a/cloot.lisp b/cloot.lisp
index 6192dbf..6192dbf 100755..100644
--- a/cloot.lisp
+++ b/cloot.lisp
diff --git a/doc/Makefile b/doc/Makefile
index 8716885..baad9d1 100644
--- a/doc/Makefile
+++ b/doc/Makefile
@@ -19,7 +19,9 @@ lkbib.txt: macros.ms lkbib.ms refs.i
 	groff -Tutf8 -R -ms -k -Kutf8 macros.ms lkbib.ms > $@
 
 %.gmi: %.md
-	md2gemini -m -l copy $^ > $@
+	md2gemini -m -l copy --code-tag lisp $^ > $@
+	# lowdown -s -Tgemini $^ > $@
+	# Lowdown isn't mature enough yet, no table support
 
 refs.i: refs
 	indxbib $^
diff --git a/doc/breaking_rules.md b/doc/breaking_rules.md
index 0eb3474..200f3b8 100644
--- a/doc/breaking_rules.md
+++ b/doc/breaking_rules.md
@@ -73,8 +73,13 @@ Detailed implementations, libraries, etc. are as follows:
 * The SBCL compiler.
 * Avoid multi-threading at this stage,
   event-driven should do the job.
-* For simple multi-user,
-  use IRCv3, including the bots (nickserv, chanserv), and tilde.chat.
+* Not sure if this is relevant for a prototype, but you could do simple multi-user
+  with IRCv3, including the bots (nickserv, chanserv), and tilde.chat.
+
+For a very mathematical domain,
+APL might be a better choice.
+However, if more than the mathematical features are required
+it could be difficult to satisfy expectations.
 
 ### Dependencies
 
@@ -88,7 +93,8 @@ Even though this is a prototype, attention should be paid to basic craftsmanship
 
 * Divide the system into packages, using the subset of CL that is
   supported by OpenLisp
-* Write one-sentence docstrings for at least each public fun, class, and package
+* Write docstrings for at least each public fun, class and package.
+  There are good guidelines in the Elisp manual, but for now one sentence will suffice.
 * Use `declare`
   to check the types of parameters in public interfaces (see below).
 * Indent all the source code using Emacs.
@@ -113,12 +119,19 @@ For example, the following:
 
 # Refinement to Production-Quality
 
-First, software at the level of the previous section is quite usable.
+Software at the level of the previous section is quite usable.
 It should be confirmed that further improvement is, in fact, required.
 If so, I argue that there is a repeatable procedure to improve the quality of a
 (reasonably well-written) prototype to a releaseable product.
 
-First, ensure that the surrounding infrastructure is in place:
+It may be useful to distinguish two levels of "production-quality".
+The first limits to widely portable dependencies,
+but this should be quite capable.
+The second could use anything
+(including the Web protocol stack),
+obviously at a maintenance cost.
+
+Ensure that the surrounding infrastructure is in place:
 
 * Configuration management. The prototype should already have been checked into git.
 * Build. Write an ASDF description, and install as a local quicklisp package.
@@ -131,9 +144,8 @@ First, ensure that the surrounding infrastructure is in place:
 Then, the following code & documentation improvements should be made:
 
 * Document the system more exhaustively
-* Can use more of quicklisp, e.g. the trivial-\* libraries
-* Can multi-thread to take advantage of all cores
-* Port to platform.sh? Modern WWW stacks are extremely complex, it would be great to do without.
+* Can use any of the "starred" libraries in quicklisp.
+* Maybe "lparallel" to take advantage of all cores
 
 Since we have a working prototype,
 it may make sense to write the documentation (and contracts, and tests) "bottom-up":
@@ -155,15 +167,15 @@ PlantUML *should* be used where it can replace ad-hoc text.
 
 Documents should be stored under git in a "doc" subdirectory of the project.
 
-I think it is a good idea to keep the separation between library and UI code
-when using ltk.
+It is recommended to keep the separation between library and UI code,
+e.g. for using ltk.
 
 The following can be added as sections to the README:
 
 * Uses hierarchy (but at a module level of granularity)
 * Task hierarchy
 
-And a proper software requirements spec should be written filling in any blanks that the man pages leave.  
+And a proper software requirements spec should be written filling in any blanks that the man pages leave.
 The specification of input and output variables is best left at the level of tables and Basic English again.
 
 ### Library
@@ -191,38 +203,32 @@ 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
-
-ltk is great for local GUIs.
-However, a product may (or may not) require HTMX and the platform.sh stack.
-Note that I prefer HTMX & ReST (following Fielding) to single-page applications
-(outside the very specific case of drawing on a canvas using ParenScript).
-
 ## Dependencies
 
 For productisation you may want to add more features.
 
 Although the official ANSI standard is moribund,
-quasi-standard libaries are recommended on the
+"community standard" (i.e. starred) libraries are recommended on the
 [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,
-but use your judgement.
-
-* For "language" functionality, "[Portability layers](http://portability.cl/)" from that list
-* For "library" functionality, any "stars" from the [Awesome-CL](https://github.com/CodyReichert/awesome-cl) list
-* Any of the `trivial-` libraries from that list.
+Dependencies should be limited to these two
+initially.
+Ltk can implement a GUI to replace the
+prototype command-line or terminal-based UI,
+if it makes sense.
+
+A second round of productisation,
+which again may never actually be required,
+could include:
+
+* Any of the `trivial-` libraries from the Awesome-CL list. The `trivial-` libraries may be *forked* and maintained locally.
 * Any other `trivial-` libraries available in Quicklisp.
 * Other libraries available in Quicklisp.
 
-The `trivial-` libraries may be *forked* and maintained locally.
-
-For example:
-* ltk for the view layer.
-* For IRC,
-  use trivial-irc.
+Now it may also be worth taking on the complexity of a Web UI,
+using HTMX and the platform.sh stack.
+HTMX & ReST (following Fielding) seem simpler than single-page applications
+(outside the very specific case of drawing on a canvas using ParenScript).
 
 ## Testing
 
diff --git a/loot.lsp b/loot.lsp
index 6192dbf..727f8f3 100755..100644
--- a/loot.lsp
+++ b/loot.lsp
@@ -5,16 +5,16 @@
 ;; Because this is a simple enum and not a full sum/product type,
 ;; I use symbols instead of CLOS.
 (defconstant +loot-type+ (vector 'bloodstone 'copper 'emeraldite 'gold
-                           'heronite 'platinum 'shadownite 'silver
+                           'heronite 'platinum 'shaownite 'silver
                            'soranite 'umbrarite 'cobalt 'iron
                            'nothing))
 (defclass <looter> () ((probabilities :accessor probabilities)))
 (defgeneric choose (self))
 (defmethod choose ((self <looter>))
   (let ((random-value (random (- +max-probability+ 1))))
-    (do ((loop 0 (+ loop 1)))
-        ((>= (elt (probabilities self) (mod loop 13)) random-value) (elt +loot-type+ (mod loop 13))))))
-(defmethod initialize-instance :after ((self <looter>) &rest initargs)
+    (for ((loop 0 (+ loop 1)))
+	((>= (elt (probabilities self) (mod loop 13)) random-value) (elt +loot-type+ (mod loop 13))))))
+(defmethod initialize-object :after ((self <looter>) initargs)
   (setf (probabilities self) (vector 10 77 105 125 142 159 172 200 201 202 216 282 +max-probability+)))
 (defun as-string (l)
   ;; Could use assoc here, but this is closer to the original.
@@ -34,8 +34,8 @@
     ((iron) "Iron")
     (t "")))
 (defun main ()
-  (let ((loot (make-instance (find-class '<looter>))))
-    (do ((n 0 (+ n 1)))
-      ((> n 99))
-      (format *standard-output* "~A~%" (as-string (choose loot))))))
+  (let ((loot (create (class <looter>))))
+    (for ((n 0 (+ n 1)))
+	((> n 99))
+	(format (standard-output) "~A~%" (as-string (choose loot))))))
 (main)