--- /dev/null
+(if-lib::load-libs :cloak-of-darkness)\r
+\r
+(in-package :cloak-of-darkness)\r
+\r
+(ref cloak message)\r
+ \r
+(object foyer (room) "Foyer of the Opera House"\r
+ (description "You are standing in a spacious hall, splendidly\r
+ decorated in red and gold, with glittering chandeliers overhead.\r
+ The entrance from the street is to the north, and there are doorways\r
+ south and west.")\r
+ (s-to 'bar)\r
+ (w-to 'cloakroom)\r
+ (n-to "You've only just arrived, and besides, the weather outside\r
+ seems to be getting worse."))\r
+\r
+(object cloakroom (room) "Cloakroom"\r
+ (description "The walls of this small room were clearly once lined\r
+ with hooks, though now only one remains. The exit is a door to the east.")\r
+ (e-to 'foyer))\r
+\r
+(object hook (supporter) "small brass hook" cloakroom\r
+ (name "small" "brass" "hook" "peg")\r
+ (description (lambda () (format nil "It's just a small brass hook, ~a"\r
+ (if (in cloak *player*)\r
+ "screwed to the wall."\r
+ "with a cloak hanging on it."))))\r
+ (has :scenery))\r
+\r
+(object bar (room) "Foyer bar"\r
+ (description "The bar, much rougher than you'd have guessed after\r
+ the opulence of the foyer to the north, is completely empty. There seems\r
+ to be some sort of message scrawled in the sawdust on the floor.")\r
+ (n-to 'foyer)\r
+ (before\r
+ (go-to (when (and (hasnt self :light) \r
+ (not (eql *noun* dir-n)))\r
+ (incf (num message) 2)\r
+ "Blundering around in the dark isn't a good idea!"))\r
+ (t (when (hasnt self :light)\r
+ (incf (num message) 1)\r
+ "In the dark? You could easily disturb something!")))\r
+ (has :~light))\r
+\r
+(object cloak (clothing) "velvet cloak" *player*\r
+ (name "handsome" "dark" "black" "velvet" "satin" "cloak")\r
+ (description "A handsome cloak, of velvet trimmed with satin, and\r
+ slightly spattered with raindrops. Its blackness is so deep that it almost\r
+ seems to suck light from the room.")\r
+ (before\r
+ ((drop put-on)\r
+ (if (eql *location* cloakroom)\r
+ (progn (give bar :light)\r
+ (when (and (eql *action* 'put-on) (has self :general))\r
+ (give self :~general)\r
+ (incf *score*) nil))\r
+ "This isn't the best place to leave a smart cloak lying around.")))\r
+ (after (take (give bar :~light) nil))\r
+ (has :general :worn))\r
+\r
+(object message () "scrawled message" bar\r
+ (name "message" "sawdust" "floor")\r
+ (description (lambda ()\r
+ (if (< (num message) 2)\r
+ (progn (incf *score*) \r
+ (setf *gamestate* 2)\r
+ (sprint "The message, neatly marked in the\r
+ sawdust, reads..."))\r
+ (progn (setf *gamestate* 3)\r
+ (sprint "The message has been carelessly\r
+ trampled, making it difficult to read. You can just distinguish\r
+ the words...")))))\r
+ (num integer 0)\r
+ (has :scenery))\r
+ \r
+(supply init ()\r
+ (setf *location* foyer)\r
+ "~%~%Hurrying through the rainswept November night, you're glad to see\r
+ the bright lights of the Opera House. It's surprising that there aren't\r
+ more people about but, hey, what do you expect in a cheap demo game...?~%~%")\r
+\r
+(supply print-gamestate () "You have lost")\r
+\r
+(verb "hang" '(:held "on" :noun -> put-on))
\ No newline at end of file
--- /dev/null
+(if-lib::load-libs :heidi)\r
+\r
+(in-package :heidi)\r
+\r
+(object before-cottage (room) "In front of a cottage"\r
+ (description "You stand outside a cottage. The forest stretches east.")\r
+ (e-to 'forest)\r
+ (in-to "It's such a lovely day -- much too nice to go inside.")\r
+ (cant-go "The only path lies to the east."))\r
+\r
+(object cottage (scenery) "tiny cottage" before-cottage\r
+ (description "It's small and simple, but you're very happy here.")\r
+ (name "tiny" "cottage" "home" "house" "hut" "shed" "hovel")\r
+ (before\r
+ (enter "It's such a lovely day -- much too nice to go inside.")))\r
+\r
+(object forest (room) "Deep in the forest"\r
+ (description "Through the dense foliage, you glimpse a\r
+ building to the west. A track heads to the northeast.")\r
+ (w-to 'before-cottage)\r
+ (ne-to 'clearing))\r
+\r
+(object bird (item) "baby bird" forest\r
+ (description "Too young to fly, the nestling tweets helplessly.")\r
+ (name "baby" "bird" "nestling")\r
+ (before \r
+ (listen "It sounds scared and in need of assistance.")))\r
+\r
+(object clearing (room) "A forest clearing"\r
+ (description "A tall sycamore stands in the middle of this clearing.\r
+ The path winds southwest through the trees.")\r
+ (sw-to 'forest)\r
+ (u-to 'top-of-tree))\r
+\r
+(object nest (item container) "bird's nest" clearing\r
+ (description "The nest is carefully woven of twigs and moss.")\r
+ (name "bird's" "nest" "twigs" "moss")\r
+ (has :open))\r
+\r
+(ref top-of-tree)\r
+\r
+(object tree (scenery) "tall sycamore tree" clearing\r
+ (description "Standing proud in the middle of the clearing,\r
+ the stout tree looks easy to climb.")\r
+ (name "tall" "sycamore" "tree" "stout" "proud")\r
+ (before\r
+ (climb (go-to-room top-of-tree) t)))\r
+\r
+(object top-of-tree (room) "At the top of the tree"\r
+ (description "You cling precariously to the trunk.")\r
+ (d-to 'clearing)\r
+ (after\r
+ (drop (move *noun* clearing) nil)))\r
+\r
+(object branch (supporter) "wide firm bough" top-of-tree\r
+ (description "It's flat enough to support a small object.")\r
+ (name "wide" "firm" "flat" "bough" "branch")\r
+ (each-turn (lambda ()\r
+ (when (and (in bird nest) (in nest branch))\r
+ (setf *gamestate* 2))))\r
+ (has :static))\r
+\r
+(supply init ()\r
+ (setf *location* before-cottage))\r
+\r
+\r
+\r
+ \r
+\r
+ \r
+ \r
+
\ No newline at end of file
--- /dev/null
+;;LIFP module for input/output\r
+;;\r
+;;This file is a part of Lisp Interactive Fiction Project\r
+;;\r
+;;See license.txt for licensing information\r
+\r
+(in-package :cl-user)\r
+(defpackage :if-console\r
+ (:use :common-lisp :ltk :com.gigamonkeys.pathnames)\r
+ (:export :terminal-in :terminal-out\r
+ :run-console :console-running-p :textwidth :offset :style\r
+ :*text* :get-input :ltk-after :*repl-mode* :*hard-quit* :quit-lisp\r
+ :close-console :load-module :print-message))\r
+\r
+(in-package :if-console)\r
+\r
+(defparameter *repl-mode* nil)\r
+(defparameter *console-on* nil)\r
+(defparameter *text* nil)\r
+(defparameter *inp* nil)\r
+(defparameter *current-path* nil)\r
+(defparameter *hard-quit* nil)\r
+\r
+(defun quit-lisp ()\r
+ #+clisp (ext:quit)\r
+ #+sbcl (quit))\r
+\r
+(defclass terminal-out (gray:fundamental-character-output-stream)\r
+ ((textwidth :initarg textwidth :initform 72 :accessor textwidth)\r
+ (offset :initarg offset :initform 0 :accessor offset)\r
+ (style :initarg style :initform 0 :accessor style)))\r
+\r
+(defclass terminal-in (gray:fundamental-character-input-stream) \r
+ ((buffer :initform "" :accessor buffer)))\r
+\r
+(defmethod gray:stream-write-char ((s terminal-out) char)\r
+ (unless (console-running-p) (error "No console is running"))\r
+ (if *repl-mode* (princ char)\r
+ (append-text (first *console-on*) \r
+ (make-string 1 :initial-element char))))\r
+\r
+(defmethod gray:stream-line-column ((s terminal-out))\r
+ (offset s))\r
+\r
+(defmethod gray:stream-write-char-sequence ((s terminal-out) str\r
+ &optional start end)\r
+ (unless (console-running-p) (error "No console is running"))\r
+ (let ((toprint (subseq str (if start start 0) (if end end nil))))\r
+ (if *repl-mode* (princ toprint)\r
+ (progn\r
+ (append-text (first *console-on*) toprint)\r
+ (see (first *console-on*) "insert")))))\r
+\r
+(defmethod gray:stream-read-char ((s terminal-in))\r
+ (if *repl-mode* (read-char *standard-input*)\r
+ (let* ((l (length (buffer s)))\r
+ (c (when (> l 0) (elt (buffer s) 0)))\r
+ (rest (when (> l 0) (subseq (buffer s) 1))))\r
+ (if c (progn (setf (buffer s) rest) c) :eof))))\r
+\r
+(defmethod gray:stream-unread-char ((s terminal-in) c)\r
+ (let ((new (make-string (1+ (length (buffer s))))))\r
+ (setf (elt new 0) c)\r
+ (setf (subseq new 1) (buffer s))\r
+ (setf (buffer s) new)))\r
+ \r
+(defmethod gray:stream-read-line ((s terminal-in))\r
+ (if *repl-mode* (read-line *standard-input*)\r
+ (let ((what (buffer s)))\r
+ (setf (buffer s) "")\r
+ what)))\r
+\r
+(defun center-text (text)\r
+ (see text "insert"))\r
+ ;(format-wish "~A yview 10 units" (widget-path text)))\r
+\r
+(defun console-running-p () (or *repl-mode* *console-on*))\r
+\r
+(defun get-input (instream outstream)\r
+ (unless *repl-mode* \r
+ (center-text *text*)\r
+ (let ((inp (make-instance 'entry))\r
+ (flag nil))\r
+ (insert-object *text* inp)\r
+ (configure inp :background "light gray" :relief "flat" :width 100)\r
+ (focus inp) (setf *inp* inp)\r
+ (configure *text* :state "disabled")\r
+ (bind inp "<KeyPress-Return>" \r
+ (lambda (evt)\r
+ (declare (ignore evt))\r
+ (setf (buffer instream) (text inp))\r
+ (setf flag t)))\r
+ (loop do (process-events) until flag)\r
+ (configure *text* :state "normal")\r
+ (let ((command (text inp)))\r
+ (destroy inp)\r
+ (append-text *text* command)\r
+ (terpri outstream)\r
+ (setf (offset outstream) 0)\r
+ command))))\r
+\r
+(defun pick-file ()\r
+ (let* ((flag nil) \r
+ (dialog (make-instance 'toplevel))\r
+ (ent (make-instance 'entry :master dialog :width 80))\r
+ (but-ok (make-instance 'button :master dialog\r
+ :text "OK"\r
+ :command (lambda () (setf flag t))))\r
+ (but-cancel (make-instance 'button :master dialog\r
+ :text "Cancel"\r
+ :command (lambda ()\r
+ (destroy dialog)\r
+ (return-from pick-file\r
+ (values nil nil))))))\r
+ (pack ent :expand t :fill :x)\r
+ (pack but-ok :side :left :expand t :fill :x)\r
+ (pack but-cancel :side :left :expand t :fill :x)\r
+ (wm-title dialog "Choose a file to load")\r
+ (on-close dialog (lambda ()\r
+ (destroy dialog)\r
+ (return-from pick-file\r
+ (values nil nil))))\r
+ (force-focus dialog)\r
+ (focus ent)\r
+ (loop do (process-events) until flag)\r
+ (destroy dialog)\r
+ (let* ((file (pathname (text ent)))\r
+ (dir nil))\r
+ (unless (file-exists-p file)\r
+ (append-text *text* "No such file!\r
+")\r
+ (return-from pick-file (values nil nil)))\r
+ (setf dir (make-pathname\r
+ :directory (pathname-directory file)\r
+ :name nil\r
+ :type nil\r
+ :defaults file))\r
+ (values file dir))))\r
+\r
+\r
+(defun load-module (startup lib-loader)\r
+ "Loads IF module into the interpreter"\r
+ (multiple-value-bind (file dir) (pick-file)\r
+ (unless file (append-text *text* "Failed to load module.\r
+"))\r
+ (funcall lib-loader file dir)\r
+ (funcall startup)))\r
+\r
+(defun run-console (startup lib-loader &key (interactive nil))\r
+ (if *repl-mode* (progn (funcall startup) \r
+ (return-from run-console t))\r
+ (with-ltk ()\r
+ (let* ((txt (make-instance 'text))\r
+ (menu (make-menubar))\r
+ (m-file (make-menu menu "File"))\r
+ (m-file-load (make-menubutton m-file "Load Module" \r
+ (lambda () (load-module startup lib-loader))))\r
+ (m-file-quit (make-menubutton m-file "Quit" \r
+ (lambda () (destroy *tk*))))\r
+ )\r
+ (declare (ignore m-file-load m-file-quit))\r
+ (setf *text* txt)\r
+ (wm-title *tk* "LIFP - Lisp Interactive Fiction Project")\r
+ (pack txt :fill :both :expand :both)\r
+ ;;(pack status :side :left :expand t :fill :x) \r
+ (setf (text txt) "")\r
+ (configure txt :font "courier") \r
+ (setf *console-on* (list txt))\r
+ (force-focus *tk*)\r
+ (unless interactive (funcall startup)))))\r
+ (setf *console-on* nil))\r
+ \r
+(defun ltk-after (time fun)\r
+ (if *repl-mode* (funcall fun)\r
+ (ltk:after time fun)))\r
+\r
+(defun close-console ()\r
+ (unless *repl-mode*\r
+ (center-text *text*)\r
+ (let ((quit-button (make-instance \r
+ 'button\r
+ :text "Quit"\r
+ :command (lambda () (destroy *tk*)))))\r
+ (insert-object *text* quit-button)\r
+ (focus quit-button))))\r
+ \r
+ \r
+(defun print-message (string &rest args)\r
+ (if *repl-mode* (progn (apply #'format t string args) \r
+ (terpri *standard-output*))\r
+ (progn (configure *text* :state "normal")\r
+ (append-text *text* (apply #'format nil string args))\r
+ (append-text *text* "\r
+"))))
\ No newline at end of file
--- /dev/null
+;;Common Lisp Interactive Fiction Library \r
+;;\r
+;;if-basic-lib module: provides the core functionality - most of the critical\r
+;;macros and functions are defined there.\r
+;;\r
+;;This file is a part of Lisp Interactive Fiction Project\r
+;;\r
+;;See license.txt for licensing information\r
+;;\r
+;; Table of contents: \r
+;;\r
+;; SECTION 1: General purpose macros\r
+;; SECTION 2: Global parameters and definitions\r
+;; SECTION 2a: Cleanup mechanics\r
+;; SECTION 3: The Pretty Printer \r
+;; SECTION 4: The Dictionary\r
+;; SECTION 5: AbstractObject class and it's methods\r
+;; SECTION 6: read-property bonanza \r
+;; SECTION 7: IfClass macro and its hairy surroundings\r
+;; SECTION 8: Object macro and some related functions\r
+;; SECTION 9: Verb functions\r
+;; SECTION 10: pattern matching\r
+;; SECTION 11: Core functionality & commands parsing\r
+\r
+\r
+\r
+(in-package :cl-user)\r
+\r
+(defpackage :if-basic-lib\r
+ (:use :if-console :common-lisp)\r
+ (:export :with-gen-syms :once-only :defsyn :ref\r
+ :*space-chars* :*dictionary* :*dict-index* :*instream*\r
+ :*outstream* :*verbs* :*tokens* :*allobjects* :*tokenpar*\r
+ :*action* :*args* :*noun* :*second* :before :after :self\r
+ :*after* :*debug*\r
+ :addword :word2dic :addword2dic\r
+ :split-to-words :sprint\r
+ :parser :description :article :glance \r
+ :initnames :addnames\r
+ :read-property :read-property-string :read-property-number\r
+ :read-property-integer :read-property-object :read-property-execute\r
+ :read-property-other :read-property-list :exec :exec*\r
+ :abstractobject :name :names :parent :children :flags\r
+ :initflags :add-flags :has :hasnt :-> :give\r
+ :ifclass :object :defaction :*meta*\r
+ :move :rmv :ofclass :among\r
+ :verb :extend-verb :extend-verb-first\r
+ :extend-verb-only :extend-verb-only-first\r
+ :deftoken :string== :matchp :!last!\r
+ :in :objectloop :provides\r
+ :wordlist :tokenlist\r
+ :nosuchword :nosuchword-word\r
+ :parse-command :unknown-verb :run-action :run-action-after\r
+ :turn-passing :pretty-string :*textwidth* :*offset* \r
+ :ignore-newlines :newline :freshline :put-word :outprinc\r
+ :destroy :supply :defstub :before-hook :after-hook\r
+ :*rules* :*predicates* :declare-rule :declare-predicate\r
+ :react-before :react-after :instead\r
+ :*cleanup* :do-cleanup :register-stub :cleanup-stub \r
+ :register-generic))\r
+\r
+(in-package :if-basic-lib)\r
+\r
+\r
+;;SECTION 1: General purpose macros\r
+\r
+(defmacro with-gen-syms ((&rest names) &body body)\r
+ `(let ,(loop for n in names collect `(,n (make-symbol ,(string n))))\r
+ ,@body))\r
+\r
+(defmacro once-only ((&rest names) &body body)\r
+ (let ((gensyms (loop for n in names collect (gensym (string n)))))\r
+ `(let (,@(loop for g in gensyms collect `(,g (gensym))))\r
+ `(let (,,@(loop for g in gensyms for n in names collect ``(,,g ,,n)))\r
+ ,(let (,@(loop for n in names for g in gensyms collect `(,n ,g)))\r
+ ,@body)))))\r
+\r
+(defun ignore-warning (condition)\r
+ (declare (ignore condition))\r
+ (muffle-warning))\r
+\r
+(defun as-keyword (sym) (intern (string sym) :keyword))\r
+\r
+(defmacro defsyn (name func)\r
+ `(defmacro ,name (&rest args) \r
+ `(,',func ,@args)))\r
+\r
+(defmacro ref (&rest names)\r
+ "make defvars for names"\r
+ `(progn\r
+ ,@(loop for x in names\r
+ collect `(defvar ,x))))\r
+\r
+;;SECTION 2: Global parameters and definitions\r
+\r
+(defparameter *debug* t\r
+ "When true, displays all sorts of debug messages")\r
+\r
+(defparameter *space-chars* #(#\Space #\Newline #\Tab)\r
+ "Characters considered to be space by split-to-words function")\r
+\r
+\r
+(defparameter *dictionary* (make-hash-table :test #'equal)\r
+ "The game dictionary - contains mapping from words to integers")\r
+(defparameter *dict-index* 0\r
+ "The index indicating how many integers were used up")\r
+\r
+;;Streams\r
+\r
+(defparameter *outstream* (make-instance 'terminal-out)\r
+ "The stream where everything is output")\r
+(defparameter *instream* (make-instance 'terminal-in)\r
+ "The stream which reads commands from user")\r
+\r
+;;Uncomment these for the REPL output (don't - deprecated by repl-mode)\r
+;(defparameter *outstream* *standard-output*)\r
+;(defparameter *instream* *standard-input*)\r
+ \r
+\r
+;;Text printer parameters\r
+\r
+(define-symbol-macro *textwidth* (textwidth *outstream*))\r
+(define-symbol-macro *offset* (offset *outstream*))\r
+\r
+;(defparameter *textwidth* 72)\r
+;(defparameter *offset* 0)\r
+\r
+\r
+(defparameter *verbs* (make-hash-table :test #'eql)\r
+ "Contains verb syntax")\r
+(defparameter *tokens* (make-hash-table :test #'eql)\r
+ "Contains parser tokens")\r
+(defparameter *allobjects* nil\r
+ "Contains every object in the game")\r
+(defparameter *tokenpar* :unspecified\r
+ "Used to pass parameters to topics")\r
+(defparameter *action* nil\r
+ "Current action")\r
+(defparameter *args* nil\r
+ "Current arguments to action")\r
+(defparameter *noun* nil\r
+ "First argument to action")\r
+(defparameter *second* nil\r
+ "Second argument to action")\r
+(defparameter *after* nil\r
+ "Whether the run-action-after was called during the last action\r
+ and wasn't interrupted - this is necessary for indirect action\r
+ processing (like put-on/in and reverse)")\r
+(defvar *rules* nil\r
+ "List of ifclass parameters that are regarded as `rules', i.e.\r
+ methods with action autoswitch turned on)")\r
+(defvar *predicates* nil\r
+ "List of ifclass parameters that are regarded as `predicates',\r
+ i.e. properties that are either lists or functions.")\r
+\r
+(defvar self) ;;Must be special for being usable in object definitions\r
+\r
+(defparameter *meta* nil\r
+ "Indicates a meta-action, which cannot be intercepted by\r
+ in-game objects")\r
+\r
+(defparameter *cleanup* nil\r
+ "The list of elements of type (function . arguments), which\r
+ describe what is needed to do before reloading the library the\r
+ second time")\r
+\r
+;; SECTION 2a: Cleanup mechanics\r
+\r
+(defun do-cleanup ()\r
+ (loop for x in *cleanup*\r
+ do (apply (car x) (cdr x)))\r
+ (setf *cleanup* nil))\r
+ \r
+(defun stub-arguments (arglist)\r
+ "Returns a typical list of arguments for a stub"\r
+ (loop for x in arglist\r
+ if (consp x) collect t ;Hmmm... fishy\r
+ else if (or (keywordp x) \r
+ (member x '(&allow-other-keys &key &rest &aux &optional))) \r
+ collect x\r
+ else if (symbolp x) collect t))\r
+\r
+(defun cleanup-stub (fun args)\r
+ (loop for x in (compute-applicable-methods fun (stub-arguments args))\r
+ do (remove-method fun x)))\r
+ \r
+(defun register-stub (fun arglist)\r
+ (push (cons #'cleanup-stub (list fun arglist)) *cleanup*))\r
+\r
+(defun register-generic (fun)\r
+ (push (cons #'fmakunbound (list fun)) *cleanup*))\r
+\r
+\r
+;; SECTION 3: The Pretty Printer (well, not very pretty)\r
+\r
+(defun newline (&optional (stream *outstream*))\r
+ "Print a newline with printer"\r
+ (setf *offset* 0) (terpri stream))\r
+\r
+(defun freshline (&optional (stream *outstream*))\r
+ "Print a fresh line with printer"\r
+ (setf *offset* 0) (fresh-line stream))\r
+\r
+(defun outprinc (str &optional (stream *outstream*))\r
+ "Princ to printer"\r
+ (princ str stream) (incf *offset* (length str)))\r
+\r
+(defun ignore-newlines (str)\r
+ "Remove all newlines from a given string (allows us to use Lisp multilines)"\r
+ (let (spaceflag (countspaces 0))\r
+ (with-output-to-string (out)\r
+ (loop for c across str\r
+ when (char= c #\Space) do (incf countspaces)\r
+ else when (char= c #\Newline) do (setf spaceflag t countspaces 0)\r
+ (princ #\Space out)\r
+ else do (unless spaceflag (loop for i from 1 to countspaces\r
+ do (princ #\Space out)))\r
+ (princ c out) (setf spaceflag nil countspaces 0))\r
+ (loop for i from 1 to countspaces do (princ #\Space out)))))\r
+ \r
+(defun put-word (word stream)\r
+ "Put a word to printer"\r
+ (let ((wordlen (length word)))\r
+ (if (<= (+ *offset* wordlen 1) *textwidth*)\r
+ (progn (princ word stream) (princ #\Space stream)\r
+ (incf *offset* (1+ wordlen)))\r
+ (progn (newline stream) (princ word stream) \r
+ (princ #\Space stream)\r
+ (incf *offset* (1+ wordlen))))))\r
+\r
+(defun pretty-string (str stream)\r
+ "Print a string using pretty printer"\r
+ (let ((word (make-array 10 :adjustable t \r
+ :fill-pointer 0 :element-type 'character))\r
+ spaceflag)\r
+ (loop for c across str\r
+ unless (find c *space-chars*)\r
+ do (vector-push-extend c word) (setf spaceflag nil)\r
+ else do (unless spaceflag \r
+ (put-word word stream)\r
+ (setf spaceflag t)\r
+ (when (char= c #\Newline) \r
+ (setf spaceflag nil) (newline stream))\r
+ (adjust-array word 10 :fill-pointer 0)))\r
+ (unless (zerop (length word)) (put-word word stream))))\r
+ \r
+(defun sprint (str &rest args)\r
+ "format-like facility for printing strings with pretty printer"\r
+ (pretty-string (apply #'format nil (ignore-newlines str) args) *outstream*)\r
+ nil)\r
+\r
+;;SECTION 4: The Dictionary\r
+\r
+(defun addword (word)\r
+ "Add a word to dictionary"\r
+ (let ((word (string-downcase word)))\r
+ (multiple-value-bind (num ex) (gethash word *dictionary*)\r
+ (declare (ignore num))\r
+ (unless ex (setf (gethash word *dictionary*) (incf *dict-index*))))))\r
+\r
+(define-condition nosuchword (error)\r
+ ((word :initarg :word :reader nosuchword-word))\r
+ (:report (lambda (condition stream)\r
+ (format stream "No such word in dictionary: ~a" \r
+ (nosuchword-word condition))))\r
+ (:documentation "No such word error"))\r
+\r
+(defun word2dic (word)\r
+ "Return dictionary index of a given word. Error if there is no\r
+such word in dictionary"\r
+ (let ((word (string-downcase word)))\r
+ (multiple-value-bind (num ex) (gethash word *dictionary*)\r
+ (if ex num (error 'nosuchword :word word)))))\r
+\r
+(defun addword2dic (word)\r
+ "Return dictionary index of a given word. If there is no such\r
+word in dictionary, add it."\r
+ (let ((word (string-downcase word)))\r
+ (multiple-value-bind (num ex) (gethash word *dictionary*)\r
+ (if ex num (setf (gethash word *dictionary*) (incf *dict-index*))))))\r
+\r
+(defun split-to-words (string) \r
+ "Returns a list of words in a string"\r
+ (assert (stringp string))\r
+ (loop \r
+ with lst = nil\r
+ with curword = ""\r
+ for x across string\r
+ if (find x *space-chars*) \r
+ do (unless (zerop (length curword)) (push curword lst))\r
+ (setf curword "")\r
+ else do (setf curword (format nil "~a~a" curword x))\r
+ finally (unless (zerop (length curword)) (push curword lst))\r
+ (return (reverse lst))))\r
+\r
+;;SECTION 5: AbstractObject class and it's methods\r
+\r
+(defclass abstractobject ()\r
+ ((name :initarg :name :initform "object" :accessor name\r
+ :documentation "Name of the object")\r
+ (names :initform nil :reader names\r
+ :documentation "List of dict-words for the parser")\r
+ (parent :initarg :parent :initform nil :reader parent\r
+ :documentation "Parent of object")\r
+ (children :initform nil :reader children\r
+ :documentation "Children of object")\r
+ (flags :initarg :flags :initform nil :accessor flags\r
+ :documentation "Flags of object"))\r
+ (:documentation "The main IF object class, of which all other\r
+ objects are subclasses"))\r
+\r
+(defgeneric parser (obj words) \r
+ (:documentation \r
+ "Parser for object - returns a number between 0 and 1 indicating\r
+ how close the guess is."))\r
+(register-generic 'parser)\r
+\r
+(defgeneric initnames (obj names)\r
+ (:documentation "Init list of names for object"))\r
+(register-generic 'initnames)\r
+\r
+(defgeneric read-property (obj property &rest args)\r
+ (:documentation "Read property of object"))\r
+(register-generic 'read-property)\r
+\r
+(defgeneric initflags (obj)\r
+ (:documentation "Adds default flags for object")\r
+ (:method-combination append :most-specific-last))\r
+(register-generic 'initflags)\r
+\r
+(defsyn rp read-property)\r
+\r
+(defmethod initialize-instance :after ((this abstractobject) &key)\r
+ "Used for flag initialisation and adds object to *allobjects*"\r
+ (setf (slot-value this 'flags) (combine-flags (initflags this)))\r
+ (push this *allobjects*))\r
+\r
+(defmethod initflags append ((obj abstractobject))\r
+ (declare (ignore obj))\r
+ (list :object))\r
+\r
+(defun flag-compare (flag1 flag2)\r
+ "Tests whether flag2 unsets flag1"\r
+ (let ((fl1 (symbol-name flag1))\r
+ (fl2 (symbol-name flag2)))\r
+ (and (char= (aref fl2 0) #\~) (string= fl1 (subseq fl2 1)))))\r
+\r
+(defun combine-flags (flaglist)\r
+ "Combine a list of flags into a _set_ of flags"\r
+ (loop for fl in flaglist\r
+ if (char= (aref (symbol-name fl) 0) #\~) \r
+ do (setq set (nset-difference set (list fl) :test #'flag-compare))\r
+ else collect fl into set\r
+ finally (return set)))\r
+\r
+(defun add-flags (obj &rest flags)\r
+ "Add some flags to object"\r
+ (setf (flags obj) (combine-flags (append (flags obj) flags)))) \r
+\r
+(defun give (obj &rest flags) \r
+ "Informish synonim to add-flags." \r
+ (setf (flags obj) (combine-flags (append (flags obj) flags))))\r
+\r
+(defun has (obj &rest flags)\r
+ "Informish macro has. Unlike Inform, can accept several flags."\r
+ (subsetp flags (flags obj)))\r
+\r
+(defun hasnt (obj &rest flags)\r
+ "Informish macro hasnt. Unlike Inform, can accept several flags."\r
+ (not (intersection flags (flags obj))))\r
+ ;(not (subsetp flags (flags obj))))\r
+\r
+(defmethod parser ((obj abstractobject) words) \r
+ "Default parser. Really bad one."\r
+ (when (zerop (length words)) (return-from parser 0))\r
+ (let ((words1 (remove-duplicates words)))\r
+ (/ (loop \r
+ for word in words\r
+ counting (member word (names obj)))\r
+ (length words1))))\r
+\r
+(defmethod initnames ((obj abstractobject) names)\r
+ "Initialise names for object"\r
+ (setf (slot-value obj 'names) \r
+ (remove-duplicates (mapcar #'addword2dic names))))\r
+\r
+(defun add-names (obj names)\r
+ "Add new names to object"\r
+ (initnames obj (remove-duplicates \r
+ (append (names obj) (mapcar #'addword2dic names)))))\r
+\r
+;;SECTION 6: read-property bonanza \r
+;;\r
+;;This is an ugly, repetitive mass of code dealing with typing and\r
+;;coercion of types. I am very unhappy with this read-property thing\r
+;;which makes other code very un-elegant. However without these type\r
+;;coersions many Inform features would be impossible to reproduce.\r
+\r
+(defun eval-err (value type)\r
+ (error "~S cannot be evaluated as ~a." value type))\r
+\r
+(defun read-property-string (value &rest args)\r
+ (cond ((stringp value) value)\r
+ ((not value) "")\r
+ ((functionp value) \r
+ (let ((res (apply value args)))\r
+ (read-property-string res args))) \r
+ ((numberp value) (format nil "~a" value))\r
+ ((and (typep value 'abstractobject)\r
+ (slot-exists-p value 'name)\r
+ (stringp (name value))) (name value))\r
+ (t (eval-err value "string"))))\r
+\r
+(defun read-property-number (value &rest args)\r
+ (cond ((numberp value) value)\r
+ ((not value) 0)\r
+ ((functionp value) \r
+ (let ((res (apply value args)))\r
+ (read-property-number res args))) \r
+ (t (eval-err value "number"))))\r
+\r
+(defun read-property-integer (value &rest args)\r
+ (cond ((integerp value) value)\r
+ ((not value) 0)\r
+ ((functionp value) \r
+ (let ((res (apply value args)))\r
+ (read-property-integer res args))) \r
+ ((stringp value) (parse-integer value :junk-allowed t))\r
+ (t (eval-err value "integer"))))\r
+ \r
+(defun read-property-object (value &rest args)\r
+ (cond ((typep value 'abstractobject) value)\r
+ ((not value) nil) \r
+ ((functionp value)\r
+ (let ((res (apply value args)))\r
+ (read-property-object res args)))\r
+ ((symbolp value)\r
+ (let ((res (symbol-value value)))\r
+ (read-property-object res args)))\r
+ ((stringp value) (sprint "~a~%" value) (values value t))\r
+ (t (eval-err value "object"))))\r
+\r
+(defmacro exec (func (&rest args) &key str)\r
+ (with-gen-syms (tmp)\r
+ `(let ((,tmp (apply #',func (list ,@args))))\r
+ ,(unless str \r
+ `(when (stringp ,tmp) (sprint ,tmp) (newline *outstream*)))\r
+ (values ,tmp t))))\r
+\r
+(defun exec* (func args &key str)\r
+ (let ((args (if (listp args) args (list args))))\r
+ (let ((tmp (apply func args)))\r
+ (unless str (when (stringp tmp) (sprint tmp) (newline *outstream*)))\r
+ (values tmp t))))\r
+\r
+(defun read-property-execute (value &rest args)\r
+ (cond ((functionp value) (exec* value args))\r
+ ((not value) nil)\r
+ ((stringp value) (sprint "~a~%" value) (values value t))\r
+ (t value)))\r
+\r
+(defun read-property-list (value &rest args)\r
+ (cond ((listp value) value)\r
+ ((functionp value)\r
+ (let ((res (apply value args)))\r
+ (if (listp res) res (list res))))\r
+ (t (list value))))\r
+\r
+(defun read-property-other (value &rest args)\r
+ (declare (ignore args)) value)\r
+\r
+(defmethod read-property ((self abstractobject) property &rest args)\r
+ "default read-property"\r
+ (case property\r
+ (name (apply #'read-property-string (slot-value self property) args))\r
+ (description (apply #'read-property-string (slot-value self property) args))\r
+ (article (apply #'read-property-string (slot-value self property) args))\r
+ (glance (apply #'read-property-string (slot-value self property) args))\r
+ (t (slot-value self property))))\r
+\r
+\r
+;;SECTION 7: IfClass macro and its hairy surroundings\r
+\r
+(defun type-keywordp (obj)\r
+ "Defines a list of type keywords which are used for property declarations"\r
+ (and (symbolp obj)\r
+ (cdr (assoc (symbol-name obj) \r
+ (mapcar #'(lambda (s) (cons (symbol-name s) s)) \r
+ '(string number integer object function)))))) \r
+\r
+(defun parse-prop (prop)\r
+ "Parsing individual property"\r
+ (let* ((p1 (first prop))\r
+ (p2 (second prop))\r
+ (p3 (third prop))\r
+ (p4 (fourth prop))\r
+ (ggg (type-keywordp p2)))\r
+ (case (length prop)\r
+ (1 (list p1 nil nil))\r
+ (2 (if ggg (list p1 ggg) (list p1 nil p2)))\r
+ (3 (if ggg (list p1 ggg p3) (list p1 nil p2 p3)))\r
+ (4 (list p1 p2 p3 p4)))))\r
+\r
+(defun prop-process1 (name type &optional initform (documentation ""))\r
+ "Macro helper function"\r
+ (unless initform \r
+ (setf initform (case type \r
+ (string "")\r
+ (number 0)\r
+ (integer 0)\r
+ (object nil)\r
+ (function nil)\r
+ (list nil)\r
+ (t nil))))\r
+ `(,name :initarg ,(as-keyword name) :accessor ,name :initform ,initform\r
+ :documentation ,documentation))\r
+\r
+(defun prop-process2 (name type &rest stuff)\r
+ "Macro helper function"\r
+ (declare (ignore stuff))\r
+ (unless type (return-from prop-process2 nil))\r
+ `((,name) (apply \r
+ ,(case type\r
+ (string #'read-property-string)\r
+ (number #'read-property-number)\r
+ (integer #'read-property-integer)\r
+ (object #'read-property-object)\r
+ (function #'read-property-execute)\r
+ (list #'read-property-list)\r
+ (t #'read-property-other))\r
+ (slot-value obj property) args)))\r
+\r
+(defmacro declare-rule (&rest args)\r
+ "Declare new rules"\r
+ `(progn \r
+ ,@(loop for x in args\r
+ collect `(pushnew ',x *rules*)\r
+ collect `(defgeneric ,x (obj)\r
+ (:method-combination or)\r
+ (:method or (obj) (declare (ignore obj)) nil))\r
+ collect `(register-generic (quote ,x))))) \r
+ \r
+(defmacro declare-predicate (&rest args)\r
+ "Declare new predicates"\r
+ `(progn\r
+ ,@(loop for x in args\r
+ collect `(pushnew ',x *predicates*)\r
+ collect `(defgeneric ,x (obj &optional what)\r
+ (:method (obj &optional what) \r
+ (declare (ignore obj what)) nil))\r
+ collect `(register-generic (quote ,x)))))\r
+\r
+(declare-rule before after react-before react-after)\r
+\r
+(defun generate-rules (name rules)\r
+ "Generates rules for a class"\r
+ (let (result)\r
+ (dolist (r *rules* result)\r
+ (let ((rul (cdr (assoc r rules))))\r
+ (when rul (push `(defmethod ,r or ((self ,name))\r
+ (declare (ignorable self))\r
+ (case *action* ,@rul)) result))))))\r
+ \r
+(defun generate-predicates (name predicates)\r
+ "Generates predicates for a class"\r
+ (let (result)\r
+ (dolist (p *predicates* result)\r
+ (let ((pred (cdr (assoc p predicates))))\r
+ (when pred\r
+ (destructuring-bind (what . stuff) pred\r
+ (flet ((pfun (pred &key (terminate nil))\r
+ (destructuring-bind (what . stuff) pred\r
+ (if (listp what)\r
+ (let ((w (car what)))\r
+ (with-gen-syms (x)\r
+ `(defmethod ,p ((self ,name) &optional ,w)\r
+ (declare (ignorable self ,w))\r
+ (unless ,w \r
+ (return-from ,p\r
+ (loop for ,x in *allobjects*\r
+ when (,p self ,x)\r
+ collect ,x)))\r
+ (or (progn ,@stuff) \r
+ ,(unless terminate \r
+ `(call-next-method))))))\r
+ (with-gen-syms (x) \r
+ `(defmethod ,p ((self ,name) &optional ,x)\r
+ (declare (ignorable self))\r
+ (unless ,x (return-from ,p (list ,@pred)))\r
+ (or (member ,x (list ,@pred)) \r
+ ,(unless terminate \r
+ `(call-next-method)))))))))\r
+ (push (if (eql what :only) \r
+ (pfun stuff :terminate t)\r
+ (pfun pred)) result))))))))\r
+ \r
+ \r
+\r
+(defmacro ifclass (name (&rest classes) &rest options)\r
+ "Macro for generating IF classes"\r
+ (let (rules predicates)\r
+ (multiple-value-bind (proplist flaglist)\r
+ (loop for opt in options\r
+ for word = (car opt)\r
+ if (eql word 'has) collect opt into fllist\r
+ else if (member word *rules*) \r
+ do (pushnew (cons word (cdr opt)) rules \r
+ :test (lambda (a b) (eql (car a) (car b))))\r
+ else if (member word *predicates*)\r
+ do (pushnew (cons word (cdr opt)) predicates\r
+ :test (lambda (a b) (eql (car a) (car b))))\r
+ else collect opt into prlist\r
+ finally (return (values prlist fllist)))\r
+ `(progn\r
+ ;;(declare (ignorable self))\r
+ (defclass ,name ,(or classes '(abstractobject))\r
+ ,(loop for prop in proplist\r
+ when (apply #'prop-process1 (parse-prop prop)) collect it))\r
+ (defmethod read-property ((self ,name) property &rest args)\r
+ (declare (ignorable args))\r
+ (case property\r
+ ,@(loop for prop in proplist \r
+ when (apply #'prop-process2 (parse-prop prop)) collect it)\r
+ (t (call-next-method))))\r
+ (handler-bind ((warning #'ignore-warning))\r
+ (defmethod initflags append ((obj ,name))\r
+ (declare (ignore obj))\r
+ (list ,@(loop for fl in flaglist appending (cdr fl))))\r
+ ,@(generate-rules name rules)\r
+ ,@(generate-predicates name predicates)))))) \r
+\r
+(defun ofclass (obj class)\r
+ "Better name for typep"\r
+ (typep obj class))\r
+\r
+;;SECTION 8: Object macro and some related functions\r
+\r
+(defmacro object (intname (&rest classes) &rest options)\r
+ "Macro for creating objects"\r
+ (multiple-value-bind (extname parent namelist proplist flaglist)\r
+ (loop with extname = ""\r
+ with parent = nil\r
+ for word = nil\r
+ for opt in options\r
+ if (listp opt) do (setq word (car opt))\r
+ else if (stringp opt) do (setq extname opt)\r
+ else do (setq parent opt)\r
+ if word\r
+ if (eql word 'has) collect opt into fllist\r
+ else if (eql word 'name) collect opt into nmlist\r
+ else collect opt into prlist\r
+ finally (return (values extname parent nmlist prlist fllist)))\r
+ (let (listwords) \r
+ (unless (or namelist (endp (setq listwords (split-to-words extname))))\r
+ (setf namelist `((name ,@listwords)))))\r
+ (with-gen-syms (this) ;other)\r
+ `(progn \r
+ (defvar ,intname)\r
+ (ifclass ,intname ,classes ,@proplist ,@flaglist)\r
+ (defmethod initialize-instance :after ((,this ,intname) &key)\r
+ (setf (slot-value ,this 'name) ,extname)\r
+ (initnames ,this ',(loop for nm in namelist appending (cdr nm)))\r
+ (move ,this ,parent))\r
+ ,(when (boundp intname)\r
+ `(setf *allobjects* (remove ,intname *allobjects*)))\r
+ (defparameter ,intname (make-instance ',intname))))))\r
+\r
+(defun move (obj1 obj2)\r
+ "Move one object inside another"\r
+ (let (objt)\r
+ (when (setf objt (parent obj1))\r
+ (setf (slot-value objt 'children) \r
+ (remove obj1 (slot-value objt 'children)))\r
+ (setf (slot-value obj1 'parent) nil))\r
+ (when obj2\r
+ (pushnew obj1 (slot-value obj2 'children))\r
+ (setf (slot-value obj1 'parent) obj2))))\r
+\r
+(defun rmv (obj1)\r
+ "Move object to top-level"\r
+ (move obj1 nil))\r
+\r
+(defun in (obj1 &rest what)\r
+ "Tests whether the first object is inside some of the others"\r
+ (some (lambda (x) (eql (parent obj) x)) what))\r
+\r
+(defun destroy (obj)\r
+ "Destroy the object, like, totally!"\r
+ (setf *allobjects* (remove obj *allobjects*))\r
+ (rmv obj))\r
+\r
+(defmacro defaction (name (&rest args) &body body)\r
+ "Creates a new action"\r
+ (let ((doc (car body)) (body2 (cdr body)))\r
+ (unless (and (stringp doc) body2) (setf doc "") (setf body2 body))\r
+ `(progn \r
+ (defgeneric ,name ,args\r
+ (:documentation ,doc)\r
+ (:method ,args (declare (ignorable ,@args)) ,@body2))\r
+ (register-generic (quote ,name))))) \r
+\r
+(defmacro objectloop ((&whole alltest iter &rest test) &body body)\r
+ "Iterates over objects satisfying test. Use !last! as an indicator\r
+ that the loop is reaching its end"\r
+ (with-gen-syms (iterlist lastone)\r
+ (if test\r
+ (let ((iterator (first test)))\r
+ `(let ((,iterlist\r
+ (case ',iter\r
+ (eql (list ,(second test)))\r
+ (in (children ,(second test)))\r
+ (member ,(second test))\r
+ (t (remove-if \r
+ #'(lambda (,iterator) (not ,alltest)) *allobjects*)))))\r
+ (let ((,lastone (car (last ,iterlist))))\r
+ (dolist (,iterator ,iterlist) \r
+ (let ((!last! (eql ,iterator ,lastone)))\r
+ (declare (ignorable !last!))\r
+ ,@body)))))\r
+ `(dolist (,iter *allobjects*) ,@body))))\r
+\r
+(defun provides (obj slot)\r
+ "Tests whether an object has a given property"\r
+ (slot-exists-p obj slot))\r
+\r
+(defun among (obj &rest what)\r
+ "Tests whether obj is among other arguments"\r
+ (member obj what))\r
+\r
+(defun notin (obj &rest what)\r
+ "Test whether the object is not in any of other arguments"\r
+ (notany (lambda (x) (eql (parent obj) x)) what))\r
+ \r
+;;SECTION 9: Verb functions\r
+\r
+(defstruct patternlist value)\r
+\r
+(defun add-to-end (plist value)\r
+ "Add pattern to the end of patternlist"\r
+ (setf (patternlist-value plist)\r
+ (append (patternlist-value plist) \r
+ (if (listp value) value (list value)))))\r
+\r
+(defun add-to-start (plist value)\r
+ "Add pattern to the beginning of patternlist"\r
+ (setf (patternlist-value plist)\r
+ (append (if (listp value) value (list value)) \r
+ (patternlist-value plist))))\r
+\r
+(defun add-verb-pattern (verb plist)\r
+ "Associate verb and patternlist"\r
+ (setf (gethash verb *verbs*) plist))\r
+\r
+(defun extend-verb-pattern (verb pattern)\r
+ "Add pattern to the end of verb's patternlist"\r
+ (add-to-end (gethash verb *verbs*) pattern))\r
+\r
+(defun extend-verb-pattern-first (verb pattern)\r
+ "Add pattern to the beginning of verb's patternlist"\r
+ (add-to-start (gethash verb *verbs*) pattern))\r
+\r
+(defun verb (&rest args)\r
+ "Create new verb"\r
+ (multiple-value-bind (namelist pattern)\r
+ (loop for cons on args\r
+ unless (stringp (car cons)) \r
+ return (values (ldiff args cons) cons))\r
+ (let ((newpattern (make-patternlist :value pattern)))\r
+ (mapcar #'(lambda (name) \r
+ (add-verb-pattern (addword2dic name) newpattern))\r
+ namelist))))\r
+\r
+(defun extend-verb (name &rest pattern)\r
+ "Extend already existing verb"\r
+ (extend-verb-pattern (word2dic name) pattern))\r
+\r
+(defun extend-verb-first (name &rest pattern)\r
+ "Extend verb, by adding new pattern to the beginning"\r
+ (extend-verb-pattern-first (word2dic name) pattern))\r
+\r
+(defun extend-verb-only (&rest args)\r
+ "Provide additional patterns only for some synonims"\r
+ (multiple-value-bind (namelist pattern)\r
+ (loop for cons on args\r
+ unless (stringp (car cons)) \r
+ return (values (ldiff args cons) cons))\r
+ (let* ((name (car namelist))\r
+ (dicname (word2dic name))\r
+ (patt (make-patternlist \r
+ :value (patternlist-value (gethash dicname *verbs*)))))\r
+ (mapcar #'(lambda (name) \r
+ (add-verb-pattern (addword2dic name) patt))\r
+ namelist)\r
+ (extend-verb-pattern dicname pattern))))\r
+\r
+(defun extend-verb-only-first (&rest args)\r
+ "Provide additional patterns for specified synonims to the beginning"\r
+ (multiple-value-bind (namelist pattern)\r
+ (loop for cons on args\r
+ unless (stringp (car cons)) \r
+ return (values (ldiff args cons) cons))\r
+ (let* ((name (car namelist))\r
+ (dicname (word2dic name))\r
+ (patt (make-patternlist \r
+ :value (patternlist-value (gethash dicname *verbs*)))))\r
+ (mapcar #'(lambda (name) \r
+ (add-verb-pattern (addword2dic name) patt))\r
+ namelist)\r
+ (extend-verb-pattern-first dicname pattern))))\r
+\r
+;;SECTION 10: pattern matching\r
+;;\r
+;;The pattern has the following format:\r
+;;(...list of tokens... -> ACTION ORDER)\r
+;;ACTION - name of action (no action by default)\r
+;;ORDER - function that given a list shuffles it according to required order \r
+;; (id by default)\r
+\r
+ \r
+(defun parse-pattern (pattern)\r
+ "Splits pattern into it's core parts"\r
+ (loop for p on pattern\r
+ if (eql (car p) '->) \r
+ return (values (ldiff pattern p) \r
+ (second p) (third p)) \r
+ finally (return (values pattern nil nil)))) \r
+\r
+(defmacro deftoken (name &body body)\r
+ "The body should contain a function that, given wordlist and tokenlist\r
+ returns state of success, the result and remaining words. Each token \r
+ consumes one arg but can use every remaining one for additional\r
+ information (e.g. :multiinside can see the next tokens to determine\r
+ whether an object is inside another object"\r
+ `(setf (gethash ,name *tokens*)\r
+ #'(lambda (wordlist tokenlist)\r
+ (declare (ignorable wordlist tokenlist))\r
+ ,@body)))\r
+\r
+(defun string== (str1 str2)\r
+ "Case-insensitive string="\r
+ (string= (string-downcase str1) (string-downcase str2)))\r
+\r
+(defun shuffle (list order)\r
+ "Shuffle given list according to the order specified"\r
+ (if order (funcall order list) list))\r
+\r
+(defun matchp (words pattern &aux arglist) \r
+ "Matches string against pattern and returns action and args on success"\r
+ (multiple-value-bind (tokenlist action order) (parse-pattern pattern)\r
+ (loop named mainloop\r
+ for tokens on tokenlist\r
+ for token = (car tokens)\r
+ when (stringp token)\r
+ do (when (loop with spl = (split-to-words token)\r
+ while (and words spl \r
+ (string== (car words) (car spl)))\r
+ do (pop words) (pop spl)\r
+ finally (return spl))\r
+ (return-from mainloop nil))\r
+ else when (listp token) \r
+ do (let* ((tokenfun (gethash (first token) *tokens*))\r
+ (tpar (second token))\r
+ (tparall (cdr token))\r
+ (*tokenpar* (if (functionp tpar) \r
+ (apply tpar (cdr tparall)) tparall)))\r
+ (declare (ignorable *tokenpar*))\r
+ (unless tokenfun (return-from mainloop nil))\r
+ (multiple-value-bind (success result remwords)\r
+ (funcall tokenfun words tokens)\r
+ (unless success (return-from mainloop nil))\r
+ (when result (push result arglist))\r
+ (setf words remwords)))\r
+ else do (let ((tokenfun (gethash token *tokens*)))\r
+ (unless tokenfun (return-from mainloop nil))\r
+ (multiple-value-bind (success result remwords)\r
+ (funcall tokenfun words tokens)\r
+ (unless success (return-from mainloop nil))\r
+ (push result arglist)\r
+ (setf words remwords)))\r
+ finally (if (endp words) \r
+ (return-from mainloop \r
+ (values action \r
+ (shuffle (reverse arglist) order))) \r
+ (return-from mainloop nil)))))\r
+\r
+\r
+;;SECTION 11: Core functionality & commands parsing\r
+\r
+\r
+(defmacro supply (name args &body body)\r
+ "Supply a method to be used instead of default. Equivalent of\r
+ Inform's stub functions."\r
+ `(defmethod ,name :around ,args ,@body))\r
+\r
+(defmacro defstub (name args &body body)\r
+ "Make a stub generic function, supply target" \r
+ (let ((docstring "") (otherbody body))\r
+ (when (and (cdr body) (stringp (car body)) \r
+ (setf docstring (car body))\r
+ (setf otherbody (cdr body)))\r
+ `(progn\r
+ (defgeneric ,name ,args\r
+ (:documentation ,docstring)\r
+ (:method ,args ,@otherbody))\r
+ (register-stub (function ,name) (quote ,args))))))\r
+\r
+\r
+(defstub unknown-verb (word)\r
+ "Display error message for unknown verb"\r
+ (format nil "No such verb: \"~a\"" word))\r
+\r
+;(defgeneric turn-passing (&optional time)\r
+; (:documentation "Called at the end of turn")\r
+; (:method (&optional time) (declare (ignore time))))\r
+\r
+(defstub turn-passing (&optional time)\r
+ "Called at the end of turn"\r
+ (declare (ignore time)) nil)\r
+\r
+(defstub before-hook ()\r
+ "Used for special before rules set up by iflib.lisp"\r
+ nil)\r
+\r
+(defstub after-hook ()\r
+ "Used for special after rules set up by if.lisp"\r
+ nil)\r
+\r
+(defun run-action-after (obj)\r
+ "Run after actions, if appropriate"\r
+ (setf *after* t)\r
+ (when (exec after-hook nil) \r
+ (setf *after* nil) \r
+ (return-from run-action-after nil))\r
+ (when (and *args* (exec* #'after obj))\r
+ (setf *after* nil)\r
+ (return-from run-action-after nil))\r
+ ;;React after?\r
+ t)\r
+\r
+(defun run-action (action args &key (time 0))\r
+ "Run an action with a given args"\r
+ (unless (listp args) (setf args (list args)))\r
+ (setf *after* nil)\r
+ (let ((*action* action)\r
+ (*args* args)\r
+ (*noun* (first args))\r
+ (*second* (second args)))\r
+ (when *debug* \r
+ (format t "[running action: ~a ~a]~%" *action* *args*))\r
+ (when *meta* ;;Just do the darn thing!\r
+ (exec* action args)\r
+ (setf *meta* nil)\r
+ (return-from run-action t))\r
+ ;;Run before?\r
+ (when (exec before-hook nil) (return-from run-action nil))\r
+ (when (and args (exec* #'before (car args))) \r
+ (return-from run-action nil))\r
+ ;;Normal action\r
+ (exec* action args)\r
+ (unless (zerop time) (turn-passing time))\r
+ t))\r
+\r
+(defun instead (action args &key (time 0))\r
+ "same as run-action, but always returns t"\r
+ (run-action action args :time time) t)\r
+\r
+(defun parse-command (string)\r
+ "Parse command and execute appropriate action"\r
+ (destructuring-bind (verb . words) (split-to-words string) \r
+ (handler-bind ((nosuchword \r
+ #'(lambda (condition)\r
+ (exec unknown-verb \r
+ ((nosuchword-word condition))) \r
+ (return-from parse-command nil))))\r
+ (let* ((dverb (word2dic verb))\r
+ (plist (gethash dverb *verbs*))\r
+ (patterns (when plist (patternlist-value plist))))\r
+ (unless plist (signal 'nosuchword :word verb))\r
+ ;;(print words) (print patterns)\r
+ (loop for pat in patterns\r
+ when (multiple-value-bind (action args) (matchp words pat)\r
+ (when action (run-action action args :time 1) t))\r
+ return nil\r
+ finally (sprint "Sorry, I can't parse that.~%"))))))\r
+ \r
+\r
--- /dev/null
+;; -*- mode:lisp -*-\r
+;;ASDF system definition for loading if-lib and LIFP user interface\r
+;;\r
+;;This file is a part of Lisp Interactive Fiction Project\r
+;;\r
+;;See license.txt for licensing information\r
+\r
+\r
+(use-package :asdf)\r
+\r
+(defsystem iflib\r
+ :name "iflib"\r
+ :author "Timofei Shatrov <grue@mail.ru>"\r
+ :description "Interactive Fiction Lisp library"\r
+ :components\r
+ ((:file "console")\r
+ (:file "if" :depends-on ("console"))\r
+ (:file "iflib" :depends-on ("if" "console"))\r
+ (:file "verbs" :depends-on ("if" "iflib")))\r
+ :depends-on (:ltk :pathnames))\r
+
\ No newline at end of file
--- /dev/null
+;;Common Lisp Interactive Fiction Library \r
+;;\r
+;;if-lib module: contains various things that IF library should contain.\r
+;;\r
+;;See license.txt for licensing information\r
+;;\r
+;; Table of contents:\r
+;;\r
+;; SECTION 1: Global parameters and definitions\r
+;; SECTION 2: Library-defined classes and objects\r
+;; SECTION 3: Scope rules\r
+;; SECTION 4: Printing objects\r
+;; SECTION 5: Default parser\r
+;; SECTION 6: Tokens\r
+;; SECTION 7: Action helpers\r
+;; SECTION 8: Main loop\r
+;; SECTION 9: Other stuff\r
+\r
+\r
+(in-package :cl-user)\r
+\r
+(defpackage :if-lib\r
+ (:use :common-lisp :if-basic-lib :if-console)\r
+ (:export :container :room :item :clothing :capacity\r
+ :n-to :ne-to :e-to :se-to :s-to :sw-to :w-to :nw-to :in-to :out-to\r
+ :u-to :d-to :cant-go\r
+ :*intscope* :*outscope* :*location* :*trace-light* :*vowels*\r
+ :*score* :*gamestate* :*turns* :*dark*\r
+ :add-to-scope :add-to-outscope :found-in :seen-from\r
+ :compass :dir-n :dir-ne :dir-e :dir-se :dir-s\r
+ :dir-sw :dir-w :dir-nw :dir-u :dir-d :dir-in :dir-out\r
+ :darkness :lit :transparent :passable\r
+ :reachp :seep :global-reachp :global-seep :seep1 :reachp1\r
+ :darkness :actor :selfobj :*player* :find-location\r
+ :deduce-article :print-property :print-name :list-contents\r
+ :reset-scope :look :words2dic-first :disambig :normal-token-scope\r
+ :input-quit-loop :quit-game :prompt :prompt-read :input-loop-step\r
+ :go-to-room :property :init :test-seq\r
+ :heldp :the-name :each-turn\r
+ :supporter :animate :scenery\r
+ :afterlife :print-gamestate :end-game\r
+ :repl-mode :compile-lib \r
+ )\r
+ (:shadow :room))\r
+\r
+(in-package :if-lib)\r
+\r
+;;Access to shadowed room function\r
+\r
+(defun room (&optional (arg :default))\r
+ (cl:room arg))\r
+\r
+(define-compiler-macro room (&whole whole &optional arg)\r
+ (declare (ignore arg))\r
+ `(cl:room ,@(cdr whole)))\r
+\r
+;;---------------\r
+\r
+;;SECTION 1: Global parameters and definitions\r
+\r
+(defparameter *vowels* "aeiouy"\r
+ "A string containing all English vowels")\r
+\r
+(defparameter *intscope* nil\r
+ "`Internal' scope, i.e. reachable by hand")\r
+(defparameter *outscope* nil\r
+ "`Outside' scope, i.e. everything that is visible")\r
+(defparameter *location* nil\r
+ "Current location of the player")\r
+(defparameter *dark* nil\r
+ "Whether it is dark in the current location")\r
+(defparameter *score* 0\r
+ "Current score of the player")\r
+(defparameter *gamestate* 0\r
+ "Current gamestate: if not zero at the end of turn game ends")\r
+(defparameter *turns* 0\r
+ "Turns passed since beginning of the game")\r
+\r
+(defparameter *player* nil\r
+ "Current player object (will be initialised later")\r
+\r
+(declare-predicate add-to-scope add-to-outscope found-in seen-from)\r
+\r
+;;SECTION 2: Library-defined classes and objects\r
+\r
+(ifclass container () (capacity integer) (has :container))\r
+(ifclass supporter () (capacity integer) (has :supporter))\r
+\r
+(ifclass room () (description string)\r
+ (n-to object) (ne-to object) (e-to object) (se-to object)\r
+ (s-to object) (sw-to object) (w-to object) (nw-to object)\r
+ (u-to object) (d-to object) (in-to object) (out-to object)\r
+ (cant-go string)\r
+ (has :light :enterable))\r
+\r
+(ifclass item () (description string) (article string)\r
+ (has :item))\r
+\r
+(ifclass clothing (item) (has :clothing))\r
+\r
+(ifclass scenery () (has :scenery))\r
+\r
+(ifclass food (item) (has :edible))\r
+\r
+(ifclass switchable () (has :switchable))\r
+\r
+(object darkness (room) "Darkness"\r
+ (description "It's pitch black. You can't see a thing.")\r
+ (before\r
+ (look (look self)))\r
+ (has :~light))\r
+\r
+;;Compass directions\r
+(object compass ())\r
+(object dir-n () "north" (name "north" "n") compass (property 'n-to))\r
+(object dir-ne () "northeast" (name "northeast" "ne") compass \r
+ (property 'ne-to))\r
+(object dir-e () "east" (name "east" "e") compass (property 'e-to))\r
+(object dir-se () "southeast" (name "southeast" "se") compass \r
+ (property 'se-to))\r
+(object dir-s () "south" (name "south" "s") compass (property 's-to))\r
+(object dir-sw () "southwest" (name "southwest" "sw") compass \r
+ (property 'sw-to))\r
+(object dir-w () "west" (name "west" "w") compass (property 'w-to))\r
+(object dir-nw () "northwest" (name "northwest" "nw") compass \r
+ (property 'nw-to))\r
+(object dir-u () "up" (name "up" "u") compass (property 'u-to))\r
+(object dir-d () "down" (name "down" "d") compass (property 'd-to))\r
+(object dir-in () "in" compass (property 'in-to))\r
+(object dir-out () "out" compass (property 'out-to))\r
+\r
+(ifclass actor () (reachp function nil) (seep function nil))\r
+(ifclass animate () (has :animate))\r
+\r
+(object selfobj (actor animate) "me" \r
+ (article "")\r
+ (has :scenery))\r
+\r
+(defparameter *player* selfobj\r
+ "This time it's initialised properly")\r
+\r
+;;SECTION 3: Scope rules\r
+\r
+(defun find-location (obj)\r
+ "Find a top-level object that contains obj"\r
+ (loop for o = obj then (parent o) while (parent o) finally (return o))) \r
+\r
+(defun transparent (obj)\r
+ "Whether the object is transparent"\r
+ (or (has obj :container :open) \r
+ (has obj :supporter)\r
+ (has obj :transparent)\r
+ (eql obj *player*)))\r
+\r
+(defun lit-down (obj)\r
+ "Lighting recursion down the object tree"\r
+ (if (has obj :light) t\r
+ (some #'(lambda (x) (or (has x :light) \r
+ (and (transparent x) (lit-down x))))\r
+ (children obj))))\r
+\r
+(defun lit (obj)\r
+ "Whether an object is lit"\r
+ (or (lit-down obj) \r
+ (when (parent obj) \r
+ (or (has (parent obj) :light) \r
+ (lit (parent obj))))))\r
+\r
+\r
+(defun seep-down (actor obj)\r
+ "Looking recursion down the object tree"\r
+ (if (eql obj actor) t\r
+ (some #'(lambda (x) (or (eql x actor) \r
+ (and (transparent x) (seep-down actor x))))\r
+ (children obj))))\r
+ \r
+\r
+(defun seep2 (actor obj)\r
+ "First approximation of looking function"\r
+ (or (seep-down actor obj) \r
+ (when (parent obj) \r
+ (or (eql actor (parent obj)) (seep2 actor (parent obj))))))\r
+\r
+(defun seep1 (actor obj)\r
+ "Second approximation of looking function"\r
+ (and (lit actor) (lit obj) (or (in obj compass) (seep2 actor obj))))\r
+\r
+(defun global-seep (actor obj)\r
+ "Tests whether an object is seen by actor"\r
+ (if (and (typep actor 'actor) (seep actor))\r
+ (read-property actor 'seep obj)\r
+ (seep1 actor obj)))\r
+\r
+(defun passable (obj)\r
+ (or (has obj :container :open)\r
+ (has obj :supporter)\r
+ (eql obj *player*)))\r
+\r
+\r
+(defun reachp-down (actor obj)\r
+ "Reaching recursion down the object tree"\r
+ (if (eql obj actor) t\r
+ (some #'(lambda (x) (or (eql x actor) \r
+ (and (passable x) (reachp-down actor x))))\r
+ (children obj))))\r
+ \r
+\r
+(defun reachp2 (actor obj)\r
+ "First approximation of reaching function"\r
+ (or (reachp-down actor obj) \r
+ (when (parent obj) \r
+ (or (eql (parent obj) actor) \r
+ (reachp2 actor (parent obj))))))\r
+\r
+\r
+(defun reachp1 (actor obj)\r
+ "Second approximation of reaching function"\r
+ (and (lit obj) (lit actor) (reachp2 actor obj)))\r
+ \r
+(defun global-reachp (actor obj)\r
+ "Tests whether an object is reachable by actor"\r
+ (if (and (typep actor 'actor) (reachp actor))\r
+ (read-property actor 'reachp obj)\r
+ (reachp1 actor obj)))\r
+\r
+(defun reset-scope (&aux location)\r
+ "Update scope for the new location"\r
+ (setf location *location*)\r
+ (unless location (setf *intscope* nil *outscope* nil) \r
+ (return-from reset-scope))\r
+ (setf *dark* (not (and (lit *player*) (lit *location*))))\r
+ (setf *outscope* (loop for x in *allobjects* ;unless (eql x location)\r
+ when (global-seep *player* x) collect x))\r
+ (setf *intscope* (loop for x in *allobjects* ;unless (eql x location)\r
+ when (global-reachp *player* x) collect x))\r
+ (let ((int (loop for x in *intscope* \r
+ append (add-to-scope x)))\r
+ (out (loop for x in *outscope* \r
+ append (add-to-scope x)\r
+ append (add-to-outscope x))))\r
+ (setf *outscope* (nconc *outscope* out))\r
+ (setf *intscope* (nconc *intscope* int)))\r
+ (objectloop (x) (when (and (seen-from x *location*) (hasnt x :absent))\r
+ (push x *outscope*))))\r
+\r
+;;SECTION 4: Printing objects\r
+\r
+(defun deduce-article (name)\r
+ "Tries to guess an article for the object"\r
+ (let ((firstchar (aref name 0)))\r
+ (cond ((char= firstchar (char-upcase firstchar)) "the")\r
+ ((find firstchar *vowels* :test #'char=) "an")\r
+ (t "a")))) \r
+\r
+(defun print-property (obj property)\r
+ "Print a property of object"\r
+ (multiple-value-bind (value printp) (read-property obj property)\r
+ (if (and (stringp value) (not printp)) (sprint value) value)))\r
+\r
+(defgeneric print-name (obj &key article capital)\r
+ (:documentation "Returns a string containing the name of object"))\r
+(register-generic 'print-name) \r
+\r
+\r
+(defgeneric the-name (obj &key article capital)\r
+ (:documentation "Returns a string containing _the_ name of\r
+ object (with definite article, and fluff stripped off)"))\r
+(register-generic 'the-name)\r
+\r
+(defmethod print-name ((obj abstractobject) &key (article nil) (capital nil))\r
+ (let ((outstr\r
+ (with-output-to-string (out)\r
+ (let ((*standard-output* out)\r
+ (name (read-property obj 'name)))\r
+ (if article\r
+ (unless (zerop (length article)) (format t "~a " article))\r
+ (if (provides obj 'article) \r
+ (print-property obj 'article)\r
+ (progn (princ (deduce-article name)) (princ " "))))\r
+ (princ name)))))\r
+ (when capital (setf (aref outstr 0) (char-upcase (aref outstr 0))))\r
+ outstr))\r
+\r
+(defmethod print-name ((obj clothing) &key &allow-other-keys)\r
+ (if (has obj :worn) (concatenate 'string (call-next-method) " (worn)")\r
+ (call-next-method)))\r
+\r
+(defmethod print-name ((obj item) &key &allow-other-keys)\r
+ (if (has obj :light) (concatenate 'string (call-next-method) \r
+ " (providing light)")\r
+ (call-next-method)))\r
+\r
+(defmethod print-name ((obj animate) &key (article nil) (capital nil)) \r
+ (call-next-method obj :article (or article "") :capital capital))\r
+\r
+(defmethod the-name ((obj abstractobject) &key (article nil) (capital nil))\r
+ (let ((outstr\r
+ (with-output-to-string (out)\r
+ (let ((*standard-output* out)\r
+ (name (read-property obj 'name)))\r
+ (if article\r
+ (unless (zerop (length article)) (format t "~a " article))\r
+ (if (provides obj 'article) \r
+ (print-property obj 'article)\r
+ (progn (princ "the "))))\r
+ (princ name)))))\r
+ (when capital (setf (aref outstr 0) (char-upcase (aref outstr 0))))\r
+ outstr))\r
+ \r
+(defmethod the-name ((obj animate) &key (article nil) (capital nil)) \r
+ (call-next-method obj :article (or article "") :capital capital))\r
+\r
+(defun print-inside (obj stream)\r
+ "Return the string containing the status of contents of the object"\r
+ (when (has obj :container)\r
+ (if (or (has obj :open) (has obj :transparent))\r
+ (if (children obj)\r
+ (progn (princ " (containing " stream) \r
+ (princ (list-contents obj) stream) \r
+ (princ ")" stream))\r
+ (princ " (empty)" stream))\r
+ (princ " (closed)" stream)))\r
+ (when (has obj :supporter)\r
+ (when (children obj)\r
+ (progn (princ " (on top of which are " stream) \r
+ (princ (list-contents obj) stream) \r
+ (princ ")" stream)))))\r
+\r
+(defun list-contents (obj)\r
+ "Return the string containing the contents of the object"\r
+ (with-output-to-string (out)\r
+ (let (commaflag)\r
+ (when (children obj) \r
+ (objectloop (in x obj)\r
+ (if (and !last! commaflag) (princ " and " out)\r
+ (when commaflag (princ ", " out)))\r
+ (setf commaflag t)\r
+ (princ (print-name x) out)\r
+ (print-inside x out))))))\r
+ \r
+\r
+(defun default-glance (obj)\r
+ "Default initial description of object"\r
+ (format t "[Default glance for ~a]~%" obj)\r
+ (sprint "~a~%" \r
+ (with-output-to-string (out)\r
+ (princ "There is " out) (princ (print-name obj) out) \r
+ (print-inside obj out)\r
+ (princ "." out))))\r
+\r
+\r
+;;SECTION 5: Default parser\r
+\r
+(defun greedy-match-noun (obj words)\r
+ "Finds how many words obj matches"\r
+ (loop for w in words\r
+ collecting w into ww\r
+ when (< (parser obj ww) 1) return (length (butlast ww))\r
+ finally (return (length words))))\r
+ \r
+\r
+(defun find-best-match (words scope)\r
+ "Returns a list of objects that match words the best"\r
+ (loop with bestvalue = 0\r
+ with bestnouns = nil\r
+ for x in scope\r
+ for y = (greedy-match-noun x words)\r
+ when (> y bestvalue) do (setf bestvalue y) (setf bestnouns (list x))\r
+ else when (and (= y bestvalue) (> bestvalue 0)) do (push x bestnouns)\r
+ finally (return (values bestnouns bestvalue))))\r
+\r
+(defun words2dic-first (words)\r
+ "Returns a list of words while they are in the dictionary"\r
+ (loop for w in words\r
+ for n = (handler-case (word2dic w) (nosuchword () nil))\r
+ while n collect n))\r
+\r
+(defgeneric parser-score (obj)\r
+ (:documentation "Should return the score used when sorting\r
+ through ambiguous input")\r
+ (:method (obj) (declare (ignore obj)) 100))\r
+\r
+(defmethod parser-score ((room room))\r
+ (declare (ignore room)) 10)\r
+\r
+(define-condition disambig ()\r
+ ((what :initarg :what :initform nil :reader disambig-what)\r
+ (words :initarg :words :initform nil :reader disambig-words))\r
+ (:report (lambda (condition stream) \r
+ (format stream "Cannot decide between the objects: ~A" \r
+ (disambig-what condition))))) \r
+\r
+(defun handle-disambig (c)\r
+ "Disambiguation handle"\r
+ (let*((dlist (disambig-what c))\r
+ (bestvalue (loop for x in dlist\r
+ maximizing (parser-score x)))\r
+ (list (delete-if (lambda (item) (< (parser-score item) bestvalue))\r
+ dlist)))\r
+ (unless (cdr list)\r
+ (return-from handle-disambig (first list)))\r
+ (sprint "I can't understand what do you mean by:~{ ~a~}." \r
+ (disambig-words c))\r
+ (newline)\r
+ (sprint "Choose one:~%")\r
+ (let ((i 0))\r
+ (dolist (l list)\r
+ (sprint "~a: ~a~%" (incf i) (print-name l)))\r
+ (sprint ">>")\r
+ (force-output *outstream*)\r
+ (nth (loop for x = (parse-integer \r
+ (get-input *instream* *outstream*)\r
+ :junk-allowed t)\r
+ until (and (numberp x) (<= 1 x (length list)))\r
+ finally (return (1- x)))\r
+ list))))\r
+\r
+;;SECTION 6: Tokens\r
+\r
+\r
+(defun normal-token-scope (wordlist scope)\r
+ "The main token function"\r
+ (multiple-value-bind (bnouns bvalue) \r
+ (find-best-match (words2dic-first wordlist) scope)\r
+ (case (length bnouns)\r
+ (1 (values t (car bnouns) \r
+ (last wordlist (- (length wordlist) bvalue))))\r
+ (0 nil)\r
+ (t (let ((choosewhat (handler-case \r
+ (signal 'disambig :what bnouns\r
+ :words (butlast wordlist\r
+ (- (length wordlist) bvalue)))\r
+ (disambig (condition)\r
+ (handle-disambig condition)))))\r
+ (when choosewhat \r
+ (values t choosewhat\r
+ (last wordlist (- (length wordlist) bvalue)))))))))\r
+\r
+;;Token definitions\r
+\r
+(deftoken :noun ;matches the given scope (intscope by default)\r
+ (let ((scope (if (eql *tokenpar* :unspecified) *intscope* *tokenpar*))) \r
+ (normal-token-scope wordlist scope)))\r
+\r
+(deftoken :seen ;matches outscope\r
+ (normal-token-scope wordlist *outscope*))\r
+ \r
+(deftoken :or ;An ugly hack - matches either of supported words\r
+ (let ((word (car (member (car wordlist) *tokenpar* :test #'string==))))\r
+ (if word (values t word (cdr wordlist)) nil)))\r
+\r
+(deftoken :has ;has flag, in outscope\r
+ (normal-token-scope wordlist \r
+ (remove-if #'(lambda (x) (hasnt x *tokenpar*)) *outscope*)))\r
+\r
+(deftoken :direction ;compass direction\r
+ (normal-token-scope wordlist (children compass)))\r
+\r
+(defun heldp (obj)\r
+ (if (eql obj *player*) t\r
+ (and (parent obj) (transparent (parent obj)) (heldp (parent obj)))))\r
+\r
+(deftoken :held\r
+ (normal-token-scope wordlist\r
+ (remove-if (complement #'heldp) *outscope*))) \r
+\r
+(deftoken :meta\r
+ (setf *meta* t) (values t t wordlist))\r
+ \r
+ \r
+;;SECTION 7: Action helpers\r
+;;\r
+;;Most of the actions are defined in verbs module.\r
+\r
+ \r
+(defgeneric look (obj) \r
+ (:documentation "Used for looking in rooms and containers"))\r
+(register-generic 'look)\r
+\r
+(defmethod look ((room room))\r
+ (sprint "~a~%~%" (read-property room 'name))\r
+ (when (provides room 'description) (print-property room 'description))\r
+ (freshline)\r
+ (objectloop (in x room)\r
+ (when (hasnt x :scenery :hidden)\r
+ (freshline)\r
+ (if (provides x 'glance)\r
+ (unless (print-property x 'glance) (default-glance x))\r
+ (default-glance x))))\r
+ t)\r
+\r
+(defun go-to-room (room)\r
+ "Player moves into room"\r
+ (when (typep room 'abstractobject)\r
+ (setf *location* room)\r
+ (move *player* *location*)\r
+ (give *location* :visited)\r
+ (objectloop (x) (when (and (found-in x *location*) (hasnt x :absent))\r
+ (move x *location*)))\r
+ (reset-scope)\r
+ (run-action 'look *location* :time 0)))\r
+\r
+\r
+;;SECTION 8: Main loop \r
+\r
+(supply turn-passing (&optional time) \r
+ (reset-scope)\r
+ (incf *turns* time)\r
+ (loop for x in *outscope*\r
+ if (provides x 'each-turn)\r
+ do (read-property-execute (slot-value x 'each-turn)))\r
+ (call-next-method)) \r
+\r
+(defgeneric before-special-rule (location)\r
+ (:documentation "Runs on location before other before effects are runned")\r
+ (:method (location) (declare (ignore location)) nil))\r
+(register-generic 'before-special-rule)\r
+\r
+(defmethod before-special-rule ((location room))\r
+ (or (and *dark* (before darkness)) \r
+ (unless (eql *noun* *location*) (before location))))\r
+\r
+(defgeneric after-special-rule (location)\r
+ (:documentation "Runs on location before other after effects are runned")\r
+ (:method (location) (declare (ignore location)) nil))\r
+(register-generic 'after-special-rule)\r
+\r
+(defmethod after-special-rule ((location room))\r
+ (or (and *dark* (after darkness))\r
+ (unless (eql *noun* *location*) (after location))))\r
+\r
+(supply before-hook ()\r
+ "Allows for react-before and location interventions"\r
+ (or (loop for x in *outscope*\r
+ thereis (react-before x))\r
+ (before-special-rule *location*)))\r
+\r
+(supply after-hook ()\r
+ "Allows for react-after and location interventions"\r
+ (or (loop for x in *outscope*\r
+ thereis (react-after x))\r
+ (after-special-rule *location*)))\r
+\r
+(define-condition input-quit-loop () ()) \r
+\r
+(defun quit-game ()\r
+ "Guess what it does?" \r
+ (signal 'input-quit-loop))\r
+\r
+(defstub prompt ()\r
+ "Display the prompt for input"\r
+ (princ "> " *outstream*)) \r
+\r
+(defun prompt-read ()\r
+ "Read input from user"\r
+ (newline *outstream*) (prompt)\r
+ (force-output *outstream*)\r
+ (get-input *instream* *outstream*)\r
+ (let ((result (read-line *instream*)))\r
+ (newline *outstream*) result))\r
+\r
+;(defun input-loop ()\r
+; (handler-case \r
+; (loop (unless (zerop *gamestate*) (end-game))\r
+; (parse-command (prompt-read)))\r
+; (input-quit-loop () nil)))\r
+\r
+(defun input-loop-step ()\r
+ "One step of the input loop"\r
+ (handler-case\r
+ (progn\r
+ (unless (zerop *gamestate*) (end-game))\r
+ (let ((input (prompt-read)))\r
+ (when (equal input "!quit") (signal 'input-quit-loop))\r
+ (parse-command input))\r
+ (ltk-after 500 #'input-loop-step))\r
+ (input-quit-loop () (close-console) nil)))\r
+\r
+(defstub init ()\r
+ "Called at the beginning of the game"\r
+ "Warning: no init routine detected!")\r
+\r
+(defstub afterlife ()\r
+ "Called when the player dies" t)\r
+\r
+(defstub print-gamestate ()\r
+ "Called when gamestate is >2"\r
+ "The End")\r
+\r
+(defun print-gamestate-default ()\r
+ "Prints default end game messages"\r
+ (case *gamestate*\r
+ (1 "You have died")\r
+ (2 "You have won")\r
+ (t (print-gamestate))))\r
+\r
+(defun end-game ()\r
+ "Called when the game ends"\r
+ (when (afterlife)\r
+ (sprint "~%~%~%***~a***~%~%~%" (print-gamestate-default))\r
+ (sprint "Score:~a Turns:~a" *score* *turns*)\r
+ (quit-game)))\r
+\r
+\r
+(defun seq ()\r
+ "Load game sequence"\r
+ (exec init ()) (go-to-room *location*)\r
+ (input-loop-step))\r
+\r
+(defun lib (file dir)\r
+ "Reloads the IF library" \r
+ (format t "[DIRECTORY: ~a]~%" dir)\r
+ (print-message "Loading if.fas...")\r
+ (load (merge-pathnames dir "if.fas"))\r
+ (print-message "Loading iflib.fas...") \r
+ (load (merge-pathnames dir "iflib.fas"))\r
+ (print-message "Loading verbs.fas...") \r
+ (load (merge-pathnames dir "verbs.fas"))\r
+ (print-message "Loading game module...") \r
+ (load file)\r
+ (print-message "Module is successfully loaded."))\r
+\r
+(defun test-seq (&optional (rm nil))\r
+ "Test sequence emulating interactive fiction interpreter"\r
+ (load-cfg "iflib.cfg")\r
+ (setf *score* 0 \r
+ *turns* 0\r
+ *gamestate* 0)\r
+ (repl-mode rm)\r
+ (run-console #'seq #'lib))\r
+\r
+(defun load-cfg (file)\r
+ (when (probe-file file)\r
+ (format t "Loading config file...~%")\r
+ (with-open-file (s file)\r
+ (loop for x in (read s)\r
+ do (setf (symbol-value (car x)) (cdr x))))))\r
+\r
+(defun interactive-start ()\r
+ "Function intended to be used by user"\r
+ (load-cfg "iflib.cfg")\r
+ (run-console #'seq #'lib :interactive t)\r
+ (when *hard-quit* (quit-lisp)))\r
+\r
+;;SECTION 9: Other stuff\r
+\r
+;;Simpler defpackage for easy using\r
+\r
+(defmacro load-libs (name &rest other-packages)\r
+ `(defpackage ,name\r
+ (:use :common-lisp :if-basic-lib :if-lib :verb-lib ,@other-packages)\r
+ (:shadowing-import-from :if-lib :room)\r
+ (:shadowing-import-from :verb-lib :listen)))\r
+ \r
+(defun repl-mode (&optional (mode :unspecified))\r
+ "Flip the using of REPL for input and output (as opposed to\r
+graphical interface)"\r
+ (setf *repl-mode* (if (eql mode :unspecified) (not *repl-mode*) mode)))\r
+\r
+(defun compile-lib ()\r
+ "Recompile the library. Useful to refresh old fasls."\r
+ (compile-file "if.lisp")\r
+ (compile-file "iflib.lisp")\r
+ (compile-file "verbs.lisp"))\r
+\r
+(defun deliver-me ()\r
+ (ext:saveinitmem "lifp.exe" :quiet t :norc t \r
+ :init-function #'interactive-start \r
+ :start-package :if-lib \r
+ :executable t))
\ No newline at end of file
--- /dev/null
+Lisp Interactive Fiction Project is subject to the following license:\r
+\r
+--\r
+Copyright (c) 2004, 2005 Timofei Shatrov & contributors\r
+All rights reserved.\r
+\r
+Redistribution and use in source and binary forms, with or without\r
+modification, are permitted provided that the following conditions are\r
+met:\r
+\r
+1. Redistributions of source code must retain the above copyright\r
+ notice, this list of conditions and the following disclaimer.\r
+\r
+2. Redistributions in binary form must reproduce the above copyright\r
+ notice, this list of conditions and the following disclaimer in\r
+ the documentation and/or other materials provided with the\r
+ distribution.\r
+\r
+3. The names of the authors of this software may not be used to\r
+ endorse or promote products derived from this software without\r
+ specific prior written permission.\r
+\r
+THIS SOFTWARE IS PROVIDED "AS IS" AND ANY EXPRESS OR IMPLIED\r
+WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF\r
+MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.\r
+IN NO EVENT SHALL THE AUTHORS OF THIS SOFTWARE BE LIABLE FOR ANY\r
+DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL\r
+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE\r
+GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS\r
+INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER\r
+IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR\r
+OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN\r
+IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.\r
+--\r
--- /dev/null
+;;Common Lisp Interactive Fiction Library \r
+;;\r
+;;verb-lib module: defines verbs and their associated actions\r
+;;\r
+;;This file is a part of Lisp Interactive Fiction Project\r
+;;\r
+;;See license.txt for licensing information\r
+\r
+\r
+\r
+(in-package :cl-user)\r
+\r
+(defpackage :verb-lib\r
+ (:use :common-lisp :if-lib :if-basic-lib)\r
+ (:export :attack :take :teleport :examine \r
+ :go-to \r
+ :take :put-in :put-on :drop :receive\r
+ :wear :strip :enter :climb)\r
+ (:shadow :listen)\r
+ (:shadowing-import-from :if-lib :room))\r
+\r
+(in-package :verb-lib)\r
+\r
+(defmacro const-fun (name args value)\r
+ `(defun ,name ,args\r
+ (declare (ignore ,@args))\r
+ ,value))\r
+\r
+(const-fun noargs-1 (c) nil)\r
+\r
+(verb "quit" '(:meta -> quit-game noargs-1)) ;;That one you'll use often ;)\r
+\r
+;Debug verb\r
+(verb "teleport"\r
+ `((:noun ,(lambda () *allobjects*)) -> teleport))\r
+\r
+(verb "take"\r
+ '(:noun -> take)\r
+ '("off" :held -> strip)\r
+ '(:held "off" -> strip)) \r
+\r
+(verb "get"\r
+ '(:noun -> take))\r
+ \r
+(const-fun const-loc (c) *location*)\r
+\r
+(verb "look"\r
+ `(-> look const-loc)\r
+ '("at" :seen -> examine))\r
+\r
+(verb "examine" "x"\r
+ '(:noun -> examine))\r
+\r
+(verb "attack" "break" "crack" "destroy"\r
+ "fight" "hit" "kill" "murder" "punch"\r
+ "smash" "thump" "torture" "wreck"\r
+ '(:noun -> attack))\r
+\r
+;(defmacro const-fun* (name args value)\r
+; `(defun ,name ,args\r
+; (declare (ignore ,@args))\r
+; (list *location* ,value)))\r
+\r
+(const-fun cdir-n (c) dir-n)\r
+(const-fun cdir-ne (c) dir-ne)\r
+(const-fun cdir-e (c) dir-e)\r
+(const-fun cdir-se (c) dir-se)\r
+(const-fun cdir-s (c) dir-s)\r
+(const-fun cdir-sw (c) dir-sw)\r
+(const-fun cdir-w (c) dir-w)\r
+(const-fun cdir-nw (c) dir-nw)\r
+(const-fun cdir-u (c) dir-u)\r
+(const-fun cdir-d (c) dir-d)\r
+(const-fun cdir-in (c) dir-in)\r
+(const-fun cdir-out (c) dir-out)\r
+\r
+(verb "go" "run" "walk" \r
+ '(:direction -> go-to)\r
+ '(:noun -> enter)\r
+ '((:or "into" "in" "inside" "through") :noun -> enter rest))\r
+\r
+(verb "n" "north" '(-> go-to cdir-n))\r
+(verb "ne" "northeast" '(-> go-to cdir-ne))\r
+(verb "e" "east" '(-> go-to cdir-e))\r
+(verb "se" "southeast" '(-> go-to cdir-se))\r
+(verb "s" "south" '(-> go-to cdir-s))\r
+(verb "sw" "southwest" '(-> go-to cdir-sw))\r
+(verb "w" "west" '(-> go-to cdir-w))\r
+(verb "nw" "northwest" '(-> go-to cdir-nw))\r
+(verb "u" "up" '(-> go-to cdir-u))\r
+(verb "d" "down" '(-> go-to cdir-d))\r
+(verb "in" '(-> go-to cdir-in))\r
+(verb "out" '(-> go-to cdir-out))\r
+\r
+(verb "enter" \r
+ '(:direction -> go-to)\r
+ '(:noun -> enter))\r
+\r
+(verb "inventory" "i" '(-> inventory))\r
+\r
+(verb "take"\r
+ '(:noun -> take)\r
+ '("off" :held -> strip)\r
+ '(:held "off" -> strip))\r
+\r
+(verb "get"\r
+ '(:noun -> take)\r
+ '((:or "in" "into" "on" "onto") :noun -> enter rest))\r
+\r
+(verb "drop" "discard" "throw"\r
+ '(:held -> drop)\r
+ '(:held "in" :noun -> put-in)\r
+ '(:held "on" :noun -> put-on))\r
+ \r
+(verb "put"\r
+ '(:held "on" :noun -> put-on)\r
+ '(:held "in" :noun -> put-in)\r
+ '(:held "down" -> drop)\r
+ '("on" :held -> wear)\r
+ '(:held -> drop))\r
+\r
+(verb "wear" "don"\r
+ '(:held -> wear))\r
+\r
+(verb "remove"\r
+ '(:held -> strip)\r
+ '(:noun -> take))\r
+\r
+(verb "shed" "disrobe" "doff"\r
+ '(:held -> strip))\r
+\r
+(verb "sit" "lie"\r
+ '("on" "top" "of" :noun -> enter)\r
+ '((:or "on" "in" "inside") :noun -> enter rest))\r
+\r
+(verb "climb" "scale"\r
+ '(:noun -> climb)\r
+ '((:or "up" "over") :noun -> climb))\r
+\r
+(verb "listen" "hear"\r
+ '(-> listen const-loc)\r
+ '(:noun -> listen)\r
+ '("to" :noun -> listen))\r
+\r
+(defaction attack (obj) "Violence is not the answer.")\r
+\r
+(defaction teleport (obj) \r
+ (go-to-room obj))\r
+\r
+(defaction examine (obj)\r
+ (if (provides obj 'description)\r
+ (read-property obj 'description)\r
+ (format nil "You see nothing special about ~A.~%" (the-name obj)))) \r
+\r
+;;(defun look-around () (run-action 'look *location*))\r
+\r
+(defaction go-to (dir)\r
+ (let ((destination (read-property *location* (property dir))))\r
+ (if destination (go-to-room destination)\r
+ (if (provides *location* 'cant-go) \r
+ (read-property *location* 'cant-go)\r
+ "You can't go here."))))\r
+\r
+;; (defaction go-n () (run-action 'go-to dir-n))\r
+;; (defaction go-ne () (run-action 'go-to dir-ne))\r
+;; (defaction go-e () (run-action 'go-to dir-e))\r
+;; (defaction go-se () (run-action 'go-to dir-se))\r
+;; (defaction go-s () (run-action 'go-to dir-s))\r
+;; (defaction go-sw () (run-action 'go-to dir-sw))\r
+;; (defaction go-w () (run-action 'go-to dir-w))\r
+;; (defaction go-nw () (run-action 'go-to dir-nw))\r
+;; (defaction go-u () (run-action 'go-to dir-u))\r
+;; (defaction go-d () (run-action 'go-to dir-d))\r
+;; (defaction go-in () (run-action 'go-to dir-in))\r
+;; (defaction go-out () (run-action 'go-to dir-out))\r
+\r
+(defun inventory ()\r
+ (sprint "You are carrying: ~a." (list-contents *player*))\r
+ (newline))\r
+\r
+(defaction take (obj)\r
+ "You can't take that.")\r
+\r
+(defmethod take((obj item))\r
+ (if (has obj :item)\r
+ (if (in obj *player*) \r
+ (progn (sprint "You already have ~A" (the-name obj)) t) \r
+ (progn \r
+ (move obj *player*)\r
+ (when (run-action-after obj) "Taken.")))\r
+ (call-next-method)))\r
+\r
+(defaction drop (obj)\r
+ (unless (has obj :item) (return-from drop "You can't drop that."))\r
+ (when (has obj :worn)\r
+ (sprint "(first removing ~a)~%" (the-name obj))\r
+ (unless (run-action 'strip obj)\r
+ (return-from drop "You can't drop it."))) \r
+ (move obj (parent *player*))\r
+ (when (run-action-after obj) "Dropped."))\r
+\r
+(defaction put-on (item host)\r
+ "You can't put anything on that.")\r
+\r
+(defmethod put-on ((item item) (host supporter))\r
+ ;;(format t "(~a ~a)" (print-name item) (print-name host)) \r
+ (unless (has item :item) (return-from put-on "You can't get rid of that."))\r
+ (unless (has host :supporter) (return-from put-on (call-next-method)))\r
+ (and (run-action 'receive (reverse *args*) :time 0)\r
+ *after*\r
+ (run-action-after item) \r
+ "Done."))\r
+\r
+(defaction put-in (item host)\r
+ "You can't put anything in that.")\r
+\r
+(defmethod put-in ((item item) (host container))\r
+ (unless (has item :item) (return-from put-in "You can't get rid of that."))\r
+ (unless (has host :container) (return-from put-in (call-next-method)))\r
+ (when (has host :closed) \r
+ (return-from put-in \r
+ (format nil "~a is closed." (the-name host :capital t))))\r
+ (and (run-action 'receive (reverse *args*) :time 0)\r
+ *after*\r
+ (run-action-after item) \r
+ "Done."))\r
+ \r
+(defaction receive (host guest)\r
+ "No method defined for that kind of object movement.")\r
+\r
+(defmethod receive ((host supporter) (item item))\r
+ (if (or (zerop (capacity host)) \r
+ (< (list-length (children host)) (capacity host)))\r
+ (progn (move item host)\r
+ (run-action-after host))\r
+ "Not enough space."))\r
+\r
+(defmethod receive ((host container) (item item))\r
+ (if (or (zerop (capacity host)) \r
+ (< (list-length (children host)) (capacity host)))\r
+ (progn (move item host)\r
+ (run-action-after host))\r
+ "Not enough space."))\r
+\r
+(defaction wear (what)\r
+ "You can't wear that.")\r
+\r
+(defmethod wear ((obj clothing))\r
+ (if (has obj :clothing)\r
+ (if (hasnt obj :worn) \r
+ (progn \r
+ (give obj :worn) (when (run-action-after obj) "Done."))\r
+ "You are already wearing it.")\r
+ "You can't wear that."))\r
+\r
+(defaction strip (what)\r
+ "That's one strange thing you want to do.")\r
+\r
+(defmethod strip ((obj clothing))\r
+ (if (and (has obj :clothing) (has obj :worn))\r
+ (progn (give obj :~worn) (when (run-action-after obj) "Done."))\r
+ "You can't do that."))\r
+\r
+(defaction enter (what)\r
+ "You can't enter that.")\r
+\r
+(defaction climb (what)\r
+ "You can't climb that.")\r
+\r
+(defaction listen (what)\r
+ "You hear nothing unexpected.")
\ No newline at end of file
projects / lifp.git / commitdiff