Some new ISLisp

4 files changed, 213 insertions, 2 deletions

diff --git a/basic.lsp b/basic.lsp
index 11771e9..135c2ba 100644
--- a/basic.lsp
+++ b/basic.lsp
@@ -1,4 +1,4 @@
-#!/Users/dbane/openlisp-11.0.0/uxlisp -shell
+#!/home/dbane/openlisp-11.0.0/uxlisp -shell
 
 (require "abs-syn")
 (require "lex")
diff --git a/cap-muck.lsp b/cap-muck.lsp
new file mode 100644
index 0000000..fd90626
--- /dev/null
+++ b/cap-muck.lsp
@@ -0,0 +1,183 @@
+(defpackage #:cap-muck
+  (:use #:openlisp)
+  (:export
+   #:main)
+  )
+(in-package #:cap-muck)
+(defglobal *terminate-program* nil)
+
+(defconstant +bold+ "#\esc[1m")
+(defconstant +unbold+ "#\esc[0m")
+(defconstant +q+ #\")
+
+(defclass <avatar> () ((name :accessor name)
+                       (playing :reader playing :initform nil)
+                       (password :accessor password)))
+(defglobal *avatars* '())
+
+(defglobal *write-avatars* nil)
+
+(defclass <connection> () ((g :reader g)
+                           (socket :reader socket)
+                           (parser :reader parser)
+                           (avatar :reader avatar)
+                           (curr-room :reader curr-room)))
+(defglobal *connections* '())
+
+(defconstant +port-number+ 6565)
+
+(defconstant +vd-type+ #(n s e w u d))
+
+(defclass <room> () ((name :reader name)
+                     (desc :reader desc)
+                     (exits :reader exits)))
+(defglobal *rooms* '())
+
+(defglobal *write-rooms* nil)
+
+(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")
+
+(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.
+;;
+;;       Or dbm?
+(defun read-room-database ()
+  (setq *rooms* '())
+  (with-open-input-file (file +rdb+)
+    (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-output-file (file +rdb+)
+    (mapcar (lambda (r) (print-object r file)) *rooms*))
+  (setq *write-rooms* nil))
+
+(defun read-avatar-database ()
+  (setq *avatars* '())
+  (with-open-input-file (file +adb+)
+    (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))
+
+(defmethod print-object ((obj <avatar>) stream)
+  (format stream "~A~%~A~%" (name a) (password a)))
+
+(defun write-avatar-database ()
+  (with-open-output-file (file +adb+)
+    (mapcar (lambda (a) (print-object a file)) *avatars*)))
+
+(defun main ()
+  (read-avatar-database)
+  (read-room-database)
+  (while (not *terminate-program*)
+         (check-for-inputs)))
+(provide "cap-muck")
diff --git a/dbm.lsp b/dbm.lsp
new file mode 100644
index 0000000..52a0a27
--- /dev/null
+++ b/dbm.lsp
@@ -0,0 +1,27 @@
+;; No package, this is for eisl
+
+(c-include "<ndbm.h>")
+
+(defclass <dbm> () (db :accessor db))
+
+(defgeneric clearerr (self))
+(defmethod clearerr ((self <dbm>))
+   (flet ((clearerr-h (db)
+             (c-lang "dbm_clearerr(DB);")))
+      (clearerr-h (db self))))
+
+(defgeneric close (self))
+
+(defgeneric delete (self key))
+
+(defgeneric open (self openflags))
+(defmethod open ((self <dbm>) file openflags)
+   (flet ((open-h (file openflags)
+             (c-lang "res = dbm_open(FILE, OPENFLAGS, MODE);")))
+      (setf (db self) (open-h file openflags))))
+
+(defgeneric create (self openflags modes))
+(defmethod create ((self <dbm>) file openflags modes)
+   (flet ((open-h (file openflags modes)
+             (c-lang "res = dbm_open(FILE, OPENFLAGS, MODE);")))
+      (setf (db self) (open-h file openflags modes))))
diff --git a/doc/breaking_rules.md b/doc/breaking_rules.md
index 200f3b8..db4f28c 100644
--- a/doc/breaking_rules.md
+++ b/doc/breaking_rules.md
@@ -92,7 +92,8 @@ If absolutely necessary you can choose some of the libraries mentioned in the "P
 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
+  supported by OpenLisp.
+  This can start from just "section headers" with lots of semicolons.
 * 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`