Initial commit

7 files changed, 536 insertions, 0 deletions

diff --git a/PlugIns/Ansi-Color.lisp b/PlugIns/Ansi-Color.lisp
new file mode 100644
index 0000000..d6f64af
--- /dev/null
+++ b/PlugIns/Ansi-Color.lisp
@@ -0,0 +1,145 @@
+(defpackage ansi-color
+  (:use :cl :cl-user :moxie :bjc-utils))
+(in-package :ansi-color)
+
+(defvar *black-color* '(0 0 0))
+(defvar *red-color* '(200 0 0))
+(defvar *green-color* '(0 200 0))
+(defvar *yellow-color* '(200 200 0))
+(defvar *blue-color* '(0 0 200))
+(defvar *purple-color* '(200 0 200))
+(defvar *cyan-color* '(0 200 200))
+(defvar *white-color* '(200 200 200))
+
+(defun active-attributes (&optional (world *world*))
+  (world-var 'active-attrs world))
+
+(defsetf active-attributes (&optional (world '*world*)) (values)
+  `(setf (world-var 'active-attrs ,world) ,values))
+
+(defun add-attribute (attribute)
+  (remove-attribute (car attribute))
+  (setf (active-attributes)
+        (cons attribute (active-attributes))))
+
+(defun attribute-value (attribute)
+  (cdr (assoc attribute (active-attributes))))
+
+(defun remove-attribute (attribute)
+  (setf (active-attributes)
+        (remove attribute (active-attributes) :key #'car)))
+
+(defun set-attribute-for-code (code)
+  (case code
+    (0 (when (active-attributes)
+         (setf (active-attributes) nil)))
+    (1 (add-attribute '(:bold 1)))
+    (3 (add-attribute '(:italic 0.25)))
+    (4 (add-attribute '(:underline 1)))
+    (7 (add-attribute '(:inverse 1)))
+    (9 (add-attribute '(:strikethrough 1)))
+    (22 (remove-attribute :bold))
+    (23 (remove-attribute :italic))
+    (24 (remove-attribute :underline))
+    (27 (remove-attribute :inverse))
+    (29 (remove-attribute :strikethrough))
+    (30 (add-attribute (cons :color *black-color*)))
+    (31 (add-attribute (cons :color *red-color*)))
+    (32 (add-attribute (cons :color *green-color*)))
+    (33 (add-attribute (cons :color *yellow-color*)))
+    (34 (add-attribute (cons :color *blue-color*)))
+    (35 (add-attribute (cons :color *purple-color*)))
+    (36 (add-attribute (cons :color *cyan-color*)))
+    (37 (add-attribute (cons :color *white-color*)))
+    (39 (remove-attribute :color))
+    (40 (add-attribute (cons :background-color *black-color*)))
+    (41 (add-attribute (cons :background-color *red-color*)))
+    (42 (add-attribute (cons :background-color *green-color*)))
+    (43 (add-attribute (cons :background-color *yellow-color*)))
+    (44 (add-attribute (cons :background-color *blue-color*)))
+    (45 (add-attribute (cons :background-color *purple-color*)))
+    (46 (add-attribute (cons :background-color *cyan-color*)))
+    (47 (add-attribute (cons :background-color *white-color*)))
+    (49 (remove-attribute :background-color))))
+
+(defun end-of-ansi-position (string start)
+  "Returns the position in STRING after START where an ANSI escape sequence ends."
+  (position-if (lambda (c)
+                 (or (and (char< c #\z) (char> c #\a))
+                     (and (char< c #\Z) (char> c #\A))))
+               string :start start))
+
+(defun colorize-ansi-string (string)
+  (declare (ignore keywords))
+  (let* (*print-pretty*
+         (string (concatenate 'string
+                              (aif (world-var 'cached-escape)
+                                   (progn
+                                     (setf (world-var 'cached-escape) nil)
+                                     it)
+                                    "")
+                              (if (stringp string) string (car string))))
+         (scanlen (length string))
+         (attr-index 0)
+         (attributes nil)
+         (skipped-chars 0)
+         (result (with-output-to-string (stripped-string)
+                   (let ((final-scan (do* ((i 0 (1+ i)))
+                                          ((>= i scanlen) i)
+                                       (when (eql (elt string i) #\Escape)
+                                         (aif (end-of-ansi-position string i)
+                                              (progn
+                                                ;; When we have a code, we should dump the last
+                                                ;; set of attributes.
+                                                (princ (subseq string attr-index i) stripped-string)
+                                                (awhen (active-attributes)
+                                                  (push (cons (make-range (- attr-index skipped-chars)
+                                                                          (- i attr-index))
+                                                              (active-attributes)) attributes))
+                                           
+                                                ;; Grab the code sequence, break it up, and set the
+                                                ;; attributes for it.
+                                                (let ((code-str (subseq string (+ i 2) it)))
+                                                  (flet ((code-in-bounds (start end)
+                                                           (let ((start (or start 0))
+                                                                 (end (or end (length code-str))))
+                                                             (set-attribute-for-code (or (and (= start end) 0)
+                                                                                         (parse-integer (subseq code-str start end)
+                                                                                                        :junk-allowed t))))))
+                                                    ;; Coalesce attributes split up by semicolons.
+                                                    (do* ((last-pos 0 (1+ semi-pos))
+                                                          (semi-pos (position #\; code-str)
+                                                                    (position #\; code-str :start last-pos))
+                                                          (code (code-in-bounds last-pos semi-pos)
+                                                                (code-in-bounds last-pos semi-pos)))
+                                                         ((null semi-pos)))))
+                                                (setf skipped-chars (+ skipped-chars (- (1+ it) i)))
+                                                (setf i it)
+                                                (setf attr-index (1+ i)))
+                                              ;; We have an escape, but can't parse it.
+                                              ;; save it in a buffer for later use.
+                                              (progn
+                                                (setf (world-var 'cached-escape) (subseq string i scanlen))
+                                                (setf scanlen i)))))))
+                     ;; Append final attributes and string.
+                     (when (<= attr-index scanlen)
+                       (princ (subseq string attr-index scanlen) stripped-string)
+                       (push (cons (make-range (- attr-index skipped-chars) (- scanlen attr-index))
+                                   (active-attributes)) attributes))))))
+    (if attributes
+        (apply #'make-attributed-string result attributes)
+        result)))
+
+(defun test-output (&rest vars)
+  (with-output-to-string (s)
+    (dolist (v vars)
+      (format t "first char: ~S, var ~S~%" (elt v 0) v)
+      (princ v s))))
+
+(defun printer-test ()
+  (test-output "string-1" (format nil "string-2~%")))
+
+(defun make-ansi-sequence ()
+  (format nil "~C[~A;~Am~A ~C[~A;~A;~AmAnd another" #\Escape 0 31 "A sequence" #\Escape 1 22 37))
+
+(add-hook 'colorize-ansi-string :output-from-server-hook)
diff --git a/PlugIns/Idle-Monster.lisp b/PlugIns/Idle-Monster.lisp
new file mode 100644
index 0000000..827813a
--- /dev/null
+++ b/PlugIns/Idle-Monster.lisp
@@ -0,0 +1,10 @@
+(defpackage idle-monster
+  (:use :cl :cl-user :moxie :bjc-utils))
+(in-package :idle-monster)
+
+(defun send-idle-cmd (&rest args)
+  (declare (ignore args))
+  "Sends a command to the current world when idle."
+  (print-to-world *world* (format nil "Idle!~%")))
+
+;(add-hook 'send-idle-cmd :timer-hook)
\ No newline at end of file
diff --git a/PlugIns/Logger.lisp b/PlugIns/Logger.lisp
new file mode 100644
index 0000000..f456fc3
--- /dev/null
+++ b/PlugIns/Logger.lisp
@@ -0,0 +1,73 @@
+;;; -*- Lisp -*-
+;;; $Id: Logger.lisp 20 2005-12-27 15:21:23Z bjc $
+
+(defpackage default-logger
+  (:use :cl :cl-user :moxie :bjc-utils))
+(in-package :default-logger)
+
+(defvar *default-log-directory* (merge-pathnames "Documents/Moxie Transcripts/"
+                                                 (user-homedir-pathname)))
+
+(defun start-logging-hook (&optional arg)
+  (let ((log-filen (car (world-var :log-file-path))))
+    (setf (world-var :log-stream)
+          (open log-filen :direction :output
+                :if-exists :append :if-does-not-exist :create))
+    (awhen (world-var :log-stream)
+      (format it "[Logging started on: ~A]~%" (format-timestamp (get-universal-time)))
+      (finish-output it)
+      (print-to-world *world* (format nil "Now logging to: ~A~%" log-filen)))))
+
+(defun stop-logging-hook (&optional arg)
+  (awhen (world-var :log-stream)
+    (format it "[Logging ended on: ~A]~%" (format-timestamp (get-universal-time)))
+    (finish-output it)
+    (close it)
+    (setf (world-var :log-stream) nil)
+    (print-to-world *world* (format nil "Logging is now disabled.~%"))))
+
+(defun log-output (string)
+  "Log STRING to DEFAULT-FILE-NAME."
+  (awhen (world-var :log-stream)
+    (let* (*print-pretty*
+           (string (if (stringp string) string (car string))))
+      (format it "~A ~A" (format-timestamp (get-universal-time)) string)
+      (finish-output it))))
+
+(defun log-input (string)
+  "Log STRING to DEFAULT-FILE-NAME."
+  (awhen (world-var :log-stream)
+    (let* (*print-pretty*
+           (string (if (stringp string) string (car string))))
+      (format it "~A -> ~A~%" (format-timestamp (get-universal-time)) string)
+      (finish-output it))))
+
+(defun format-timestamp (universal-time)
+  (multiple-value-bind (sec min hour date mon year day daylight-p zone)
+      (decode-universal-time universal-time)
+    (format nil "[~D-~2,'0D-~2,'0D ~2,'0D:~2,'0D:~2,'0D]" year mon date hour min sec)))
+
+;;
+;; Convienence aliases
+;;
+(defun logger-alias (arg)
+  (if (> (length arg) 0)
+      (start-logging-to arg)
+      (if (world-var :log-stream)
+          (disable-logging *world*)
+          (enable-logging *world*)))
+  nil)
+
+(defun start-logging-to (filename)
+  (awhen (world-var :log-stream)
+    (disable-logging *world*))
+  (setf (world-var :log-file-path)
+        (list (merge-pathnames filename *default-log-directory*)))
+  (enable-logging *world*))
+
+(add-hook 'start-logging-hook :start-logging-hook)
+(add-hook 'stop-logging-hook :stop-logging-hook)
+(add-hook 'log-output :output-from-server-hook)
+(add-hook 'log-input :input-from-client-hook)
+
+(add-keyword 'logger-alias "log")
\ No newline at end of file
diff --git a/PlugIns/MXP.lisp b/PlugIns/MXP.lisp
new file mode 100644
index 0000000..8694608
--- /dev/null
+++ b/PlugIns/MXP.lisp
@@ -0,0 +1,54 @@
+;; -*- Lisp -*-
+;; $Id: MXP.lisp 20 2005-12-27 15:21:23Z bjc $
+
+(defpackage mxp
+  (:use :cl :cl-user :moxie :bjc-utils))
+(in-package :mxp)
+
+(defun parse-mxp-args (string)
+  (let ((last-space 0))
+    (loop as next-space = (position-if (lambda (c)
+                                         (or (eql c #\Space) (eql c #\Tab) (eql c #\Newline)))
+                                       string
+                                       :start last-space)
+         collect (if next-space 
+                     (prog1
+                       (subseq string last-space next-space)
+                       (setf last-space (1+ next-space)))
+                     (subseq string last-space (length string)))
+         while next-space)))
+
+;; We have to get the world name here, which isn't being set
+;; for some reason in the world-opened-hook.
+;;
+;; Update: the reason is that world-opened-hook doesn't have
+;; anything on it. We need to create a function to make the
+;; alist in args the environment for the world, and figure out
+;; where to put it.
+;;
+;; Built in plugin via runhook?
+;; Do we want runhook at all, since this is so low-level we may
+;; not want people messing with it.
+(defun play-sound (args)
+  (format t "msp dir: ~S~%" (merge-pathnames (car args)
+                                             (merge-pathnames "Library/Moxie/MSP/"
+                                             (user-homedir-pathname)))))
+
+(defun dispatch-mxp-command (string)
+  (let* ((strlen (length string))
+         (lp-pos (position #\( string))
+         (rp-pos (and lp-pos (position #\) string)))
+         (cmd (subseq string 0 (or lp-pos strlen)))
+         (args (and rp-pos (parse-mxp-args (subseq string (1+ lp-pos) rp-pos)))))
+    (cond ((or (string= cmd "MUSIC") (string= cmd "SOUND"))
+           (play-sound args))
+          (t (format t "Found MXP cmd: ~S, args: ~S~%" cmd args)))
+    (subseq string (1+ rp-pos))))
+
+(defun scan-mxp-data (string)
+  (let ((string (if (stringp string) string (car string))))
+    (when (and (> (length string) 2)
+               (string= (subseq string 0 2) "!!"))
+      (dispatch-mxp-command (subseq string 2)))))
+
+(add-hook 'scan-mxp-data :output-from-server-hook)
diff --git a/PlugIns/Numpad-Movement.lisp b/PlugIns/Numpad-Movement.lisp
new file mode 100644
index 0000000..5924b68
--- /dev/null
+++ b/PlugIns/Numpad-Movement.lisp
@@ -0,0 +1,45 @@
+;;; Keystroke macros to use the keypad for directional movement.
+;; $Id: Numpad-Movement.lisp 20 2005-12-27 15:21:23Z bjc $
+(defpackage :numpad-movement
+  (:use :cl :cl-user :moxie :bjc-utils))
+(in-package :numpad-movement)
+
+(defun keystroke-north (&rest keywords)
+  (send-to-mux *world* (format nil "north~%")))
+(defun keystroke-south (&rest keywords)
+  (send-to-mux *world* (format nil "south~%")))
+(defun keystroke-east (&rest keywords)
+  (send-to-mux *world* (format nil "east~%")))
+(defun keystroke-west (&rest keywords)
+  (send-to-mux *world* (format nil "west~%")))
+(defun keystroke-northeast (&rest keywords)
+  (send-to-mux *world* (format nil "northeast~%")))
+(defun keystroke-northwest (&rest keywords)
+  (send-to-mux *world* (format nil "northwest~%")))
+(defun keystroke-southeast (&rest keywords)
+  (send-to-mux *world* (format nil "southeast~%")))
+(defun keystroke-southwest (&rest keywords)
+  (send-to-mux *world* (format nil "southwest~%")))
+(defun keystroke-up (&rest keywords)
+  (send-to-mux *world* (format nil "up~%")))
+(defun keystroke-down (&rest keywords)
+  (send-to-mux *world* (format nil "down~%")))
+
+(defun clear-screen-fun (&optional args)
+  (declare (ignore arg))
+  (format t "clear-screen ~S~%" *world*)
+  (clear-screen *world*)
+  nil)
+
+(add-keystroke-macro 'keystroke-north :numpad-8)
+(add-keystroke-macro 'keystroke-south :numpad-2)
+(add-keystroke-macro 'keystroke-east :numpad-6)
+(add-keystroke-macro 'keystroke-west :numpad-4)
+(add-keystroke-macro 'keystroke-northeast :numpad-9)
+(add-keystroke-macro 'keystroke-northwest :numpad-7)
+(add-keystroke-macro 'keystroke-southeast :numpad-3)
+(add-keystroke-macro 'keystroke-southwest :numpad-1)
+(add-keystroke-macro 'keystroke-up :numpad-+)
+(add-keystroke-macro 'keystroke-down :numpad--)
+(add-keystroke-macro 'clear-screen-fun :clear)
+(add-keyword 'clear-screen-fun "clear")
\ No newline at end of file
diff --git a/PlugIns/Sample-Plugin.lisp b/PlugIns/Sample-Plugin.lisp
new file mode 100644
index 0000000..434cc8d
--- /dev/null
+++ b/PlugIns/Sample-Plugin.lisp
@@ -0,0 +1,60 @@
+#-cl-ppcre (asdf:operate 'asdf:load-op :cl-ppcre)
+(defpackage sample-plugin
+  (:use :cl :cl-user :moxie :bjc-utils :cl-ppcre))
+(in-package :sample-plugin)
+
+(defvar *page-highlight-attrs* (list (make-color 240 10 240)))
+
+(defun print-mandel (&optional (stream *standard-output*))
+  "Prints a mandelbrot set to STREAM."
+  (loop for y from -1 to 1.1 by 0.1 do
+       (format stream "~%")
+       (loop for x from -2 to 1 by 0.04 do
+            (let* ((c 126)
+                   (z (complex x y))
+                   (a z))
+              (loop while (< (abs
+                              (setq z (+ (* z z) a)))
+                             2)
+                 while (> (decf c) 32))
+              (princ (code-char c) stream)))))
+
+(defun mandel-in-string ()
+  (escape-mux-string (with-output-to-string (s)
+                       (print-mandel s)
+                       s)))
+
+(defun mandel-page (string)
+  "Sends a mandelbrot set to the first arg in STRING."
+  (map-variables "p $1$=$2$"
+                 (list (car (split "\\s+" string))
+                       (mandel-in-string))))
+
+(defun highlight-pages (string)
+  "Highlights a page if it comes in."
+  (let ((string (if (stringp string) string (car string))))
+    (multiple-value-bind (match names)
+        (scan-to-strings "^((.*)\\s+pages:|From afar, (\\w+))" string)
+      (when match
+        (format t "You were paged by: ~A.~%" (elt names 1))
+        (make-attributed-string string *page-highlight-attrs*)))))
+
+(defun complex-attribute (keystroke)
+  (let ((attr-string (make-attributed-string "Foobarbaz"
+                                             `(,(make-color 255 255 255) (:italic 0.25))
+                                             `(,(make-range 3 3)
+                                                ,(make-super 1)
+                                                ,(make-color 127 127 127))
+                                             `(,(make-range 6 3)
+                                                ,(make-super 2)
+                                                ,(make-color 63 63 63)))))
+    (format t "complex attribute: ~S~%" attr-string)
+    (print-to-world *world* attr-string)))
+
+;; Now that we have the functions defined, hook 'em into Moxie.
+(add-hook 'highlight-pages :output-from-server-hook)
+
+; Register MANDEL-PAGE for the command "/MANDEl"
+(add-keyword 'mandel-page "mandel")
+
+(add-keystroke-macro 'complex-attribute :f1)
diff --git a/PlugIns/Telnet.lisp b/PlugIns/Telnet.lisp
new file mode 100644
index 0000000..2410af4
--- /dev/null
+++ b/PlugIns/Telnet.lisp
@@ -0,0 +1,149 @@
+;; -*- Lisp -*-
+;; $Id: Telnet.lisp 20 2005-12-27 15:21:23Z bjc $
+
+(defpackage telnet-options
+  (:use :cl :cl-user :moxie :bjc-utils))
+(in-package :telnet-options)
+
+(defconstant +iac+ 255
+  "Interpret as Command")
+
+(defconstant +se+ 240
+  "End of subnegotiation parameters.")
+
+(defconstant +nop+ 241
+  "No operation.")
+
+(defconstant +data-mark+ 242
+  "The data stream portion of a Synch.
+This should always be accompanied
+by a TCP Urgent notification.")
+
+(defconstant +break+ 243
+  "NVT character BRK.")
+
+(defconstant +interrupt-process+ 244
+  "The function IP.")
+
+(defconstant +abort-output+ 245
+  "The function AO.")
+
+(defconstant +are-you-there+ 246
+  "The function AYT.")
+
+(defconstant +erase-character+ 247
+  "The function EC.")
+
+(defconstant +erase-line+ 248
+  "The function EL.")
+
+(defconstant +go-ahead+ 249
+  "The GA signal.")
+
+(defconstant +sb+ 250
+  "Indicates that what follows is
+subnegotiation of the indicated option.")
+
+(defconstant +will+ 251
+  "Indicates the desire to begin
+performing, or confirmation that
+you are now performing, the
+indicated option.")
+
+(defconstant +wont+ 252
+  "Indicates the refusal to perform,
+or continue performing, the
+indicated option.")
+
+(defconstant +do+ 253
+  "Indicates the request that the
+other party perform, or
+confirmation that you are expecting
+the other party to perform, the
+indicated option.")
+
+(defconstant +dont+ 254
+  "Indicates the demand tha the
+other party stop performing,
+or confirmation that you are no
+longer expecting the other party
+to perform, the indicated option.")
+
+(defconstant +option-binary+ 0
+  "Enable binary (8 bit) data transmission, instead of the stripped 7 bit ASCII default.")
+(defconstant +option-echo+ 1
+  "Enable remote echo, suppressing local echo.")
+(defconstant +option-supress-go-ahead+ 3
+  "Enable go-ahead suppression.")
+(defconstant +option-status+ 5
+  "Enable option spamming for easier negotiations.")
+(defconstant +option-timing-mark+ 6
+  "Return a timing mark when this is recieved.")
+(defconstant +option-terminal+ 24
+  "Return terminal type.")
+(defconstant +option-window-size+ 31
+  "Negotiate about window size.")
+(defconstant +option-authentication+ 37
+  "Negotiate authentication.")
+(defconstant +option-environment+ 39
+  "Negotiate environment variables.")
+(defconstant +option-extended-options-list+ 255
+  "Read the next byte for further options.")
+
+(defconstant +option-mccp1+ 85
+  "Mud Client Compression Protocol version 1.")
+(defconstant +option-mccp2+ 86
+  "Mud Client Compression Protocol version 2.")
+(defconstant +option-msp+ 90
+  "Mud Sound Protocol.")
+(defconstant +option-mxp+ 91
+  "Mud eXtension Protocol.")
+
+(defun ack-cmd (cmd)
+  "Computes the ACK code for CMD."
+  (cond ((eql cmd +do+) +will+)
+        ((eql cmd +will+) +do+)
+        ((eql cmd +dont+) +wont+)
+        ((eql cmd +wont+) +dont+)))
+
+(defun nack-cmd (cmd)
+  "Computes the NACK code for CMD."
+  (cond ((eql cmd +do+) +wont+)
+        ((eql cmd +will+) +dont+)
+        ((eql cmd +dont+) +will+)
+        ((eql cmd +wont+) +do+)))
+
+(defun send-option (cmd option)
+  (let ((options (world-var 'options)))
+    (unless options
+      (setf (world-var 'options) (make-hash-table))
+      (setf options (world-var 'options)))
+    (unless (eql cmd (gethash option options))
+      (setf (gethash option options) cmd)
+      (send-bytes (list +iac+ cmd option)))))
+
+(defun send-bytes (bytes)
+  (write-array-to-mux *world* bytes))
+
+(defun handle-command-array (array)
+  "Array is a byte-vector of the complete IAC code, including any IAC characters."
+  (format t "(handle-command-array ~S)~%" array)
+  (when (and (> (length array) 1) (eql (elt array 0) +iac+))
+    (let ((cmd (elt array 1)))
+      (cond ((or (eql cmd +do+) (eql cmd +will+))
+             (awhen (aand (> (length array) 2) (elt array 2))
+               (cond ((eql it +option-timing-mark+)
+                      (send-bytes (list +iac+ ack-cmd cmd) it))
+                     ((or (eql it +option-binary+)
+                          (eql it +option-supress-go-ahead+)
+                          (eql it +option-status+)
+                          (eql it +option-msp+)
+                          (eql it +option-mxp+))
+                      (send-option (ack-cmd cmd) it))
+                     (t (send-option (nack-cmd cmd) it)))))
+            ((or (eql cmd +dont+) (eql cmd +wont+))
+             (awhen (aand (> (length array) 2) (elt array 2))
+               (send-option (ack-cmd cmd) it)))
+            (t (format t "Can't handle command ~S.~%" cmd))))))
+
+(add-hook 'handle-command-array :telnet-option-hook)