path: root/cap-muck.lsp

;;; See https://github.com/chazu/16k_muds/tree/master/drveg%40pacbell.net

(defglobal *terminate-program* nil)

;; Hmm, I now think procedural interfaces are better than protocols
(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 +opposite+ #(s n w e d u))

(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?
;;       Or dbm? (Espcially for production.)
(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 establish-connection ()
    (let ((c (create (class <connection-type>))))
        (say c "Welcome to CapMUCK!")
        (say c "Commands are all upper case, like HELP.")
        (say c "")
        (say c +name-prompt+)))

(defun main ()
  (read-avatar-database)
  (read-room-database)
  (while (not *terminate-program*)
         (check-for-inputs)))
(main)