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