1 files changed, 183 insertions, 0 deletions
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")