1 ;;Common Lisp Interactive Fiction Library
\r
3 ;;if-basic-lib module: provides the core functionality - most of the critical
\r
4 ;;macros and functions are defined there.
\r
6 ;;This file is a part of Lisp Interactive Fiction Project
\r
8 ;;See license.txt for licensing information
\r
10 ;; Table of contents:
\r
12 ;; SECTION 1: General purpose macros
\r
13 ;; SECTION 2: Global parameters and definitions
\r
14 ;; SECTION 2a: Cleanup mechanics
\r
15 ;; SECTION 3: The Pretty Printer
\r
16 ;; SECTION 4: The Dictionary
\r
17 ;; SECTION 5: AbstractObject class and it's methods
\r
18 ;; SECTION 6: read-property bonanza
\r
19 ;; SECTION 7: IfClass macro and its hairy surroundings
\r
20 ;; SECTION 8: Object macro and some related functions
\r
21 ;; SECTION 9: Verb functions
\r
22 ;; SECTION 10: pattern matching
\r
23 ;; SECTION 11: Core functionality & commands parsing
\r
27 (in-package :cl-user)
\r
29 (defpackage :if-basic-lib
\r
30 (:use :if-console :common-lisp)
\r
31 (:export :with-gen-syms :once-only :defsyn :ref
\r
32 :*space-chars* :*dictionary* :*dict-index* :*instream*
\r
33 :*outstream* :*verbs* :*tokens* :*allobjects* :*tokenpar*
\r
34 :*action* :*args* :*noun* :*second* :before :after :self
\r
36 :addword :word2dic :addword2dic
\r
37 :split-to-words :sprint
\r
38 :parser :description :article :glance
\r
39 :initnames :addnames
\r
40 :read-property :read-property-string :read-property-number
\r
41 :read-property-integer :read-property-object :read-property-execute
\r
42 :read-property-other :read-property-list :exec :exec*
\r
43 :abstractobject :name :names :parent :children :flags
\r
44 :initflags :add-flags :has :hasnt :-> :give
\r
45 :ifclass :object :defaction :*meta*
\r
46 :move :rmv :ofclass :among
\r
47 :verb :extend-verb :extend-verb-first
\r
48 :extend-verb-only :extend-verb-only-first
\r
49 :deftoken :string== :matchp :!last!
\r
50 :in :notin :objectloop :provides
\r
51 :wordlist :tokenlist
\r
52 :nosuchword :nosuchword-word
\r
53 :parse-command :unknown-verb :run-action :run-action-after
\r
54 :turn-passing :pretty-string :*textwidth* :*offset*
\r
55 :ignore-newlines :newline :freshline :put-word :outprinc
\r
56 :destroy :supply :defstub :before-hook :after-hook
\r
57 :*rules* :*predicates* :declare-rule :declare-predicate
\r
58 :react-before :react-after :instead
\r
59 :*cleanup* :do-cleanup :register-stub :cleanup-stub
\r
62 (in-package :if-basic-lib)
\r
65 ;;SECTION 1: General purpose macros
\r
67 (defmacro with-gen-syms ((&rest names) &body body)
\r
68 `(let ,(loop for n in names collect `(,n (make-symbol ,(string n))))
\r
71 (defmacro once-only ((&rest names) &body body)
\r
72 (let ((gensyms (loop for n in names collect (gensym (string n)))))
\r
73 `(let (,@(loop for g in gensyms collect `(,g (gensym))))
\r
74 `(let (,,@(loop for g in gensyms for n in names collect ``(,,g ,,n)))
\r
75 ,(let (,@(loop for n in names for g in gensyms collect `(,n ,g)))
\r
78 (defun ignore-warning (condition)
\r
79 (declare (ignore condition))
\r
82 (defun as-keyword (sym) (intern (string sym) :keyword))
\r
84 (defmacro defsyn (name func)
\r
85 `(defmacro ,name (&rest args)
\r
88 (defmacro ref (&rest names)
\r
89 "make defvars for names"
\r
91 ,@(loop for x in names
\r
92 collect `(defvar ,x))))
\r
94 ;;SECTION 2: Global parameters and definitions
\r
96 (defparameter *debug* t
\r
97 "When true, displays all sorts of debug messages")
\r
99 (defparameter *space-chars* #(#\Space #\Newline #\Tab)
\r
100 "Characters considered to be space by split-to-words function")
\r
103 (defparameter *dictionary* (make-hash-table :test #'equal)
\r
104 "The game dictionary - contains mapping from words to integers")
\r
105 (defparameter *dict-index* 0
\r
106 "The index indicating how many integers were used up")
\r
110 (defparameter *outstream* (make-instance 'terminal-out)
\r
111 "The stream where everything is output")
\r
112 (defparameter *instream* (make-instance 'terminal-in)
\r
113 "The stream which reads commands from user")
\r
115 ;;Uncomment these for the REPL output (don't - deprecated by repl-mode)
\r
116 ;(defparameter *outstream* *standard-output*)
\r
117 ;(defparameter *instream* *standard-input*)
\r
120 ;;Text printer parameters
\r
122 (define-symbol-macro *textwidth* (textwidth *outstream*))
\r
123 (define-symbol-macro *offset* (offset *outstream*))
\r
125 ;(defparameter *textwidth* 72)
\r
126 ;(defparameter *offset* 0)
\r
129 (defparameter *verbs* (make-hash-table :test #'eql)
\r
130 "Contains verb syntax")
\r
131 (defparameter *tokens* (make-hash-table :test #'eql)
\r
132 "Contains parser tokens")
\r
133 (defparameter *allobjects* nil
\r
134 "Contains every object in the game")
\r
135 (defparameter *tokenpar* :unspecified
\r
136 "Used to pass parameters to topics")
\r
137 (defparameter *action* nil
\r
139 (defparameter *args* nil
\r
140 "Current arguments to action")
\r
141 (defparameter *noun* nil
\r
142 "First argument to action")
\r
143 (defparameter *second* nil
\r
144 "Second argument to action")
\r
145 (defparameter *after* nil
\r
146 "Whether the run-action-after was called during the last action
\r
147 and wasn't interrupted - this is necessary for indirect action
\r
148 processing (like put-on/in and reverse)")
\r
149 (defvar *rules* nil
\r
150 "List of ifclass parameters that are regarded as `rules', i.e.
\r
151 methods with action autoswitch turned on)")
\r
152 (defvar *predicates* nil
\r
153 "List of ifclass parameters that are regarded as `predicates',
\r
154 i.e. properties that are either lists or functions.")
\r
156 (defvar self) ;;Must be special for being usable in object definitions
\r
158 (defparameter *meta* nil
\r
159 "Indicates a meta-action, which cannot be intercepted by
\r
162 (defparameter *cleanup* nil
\r
163 "The list of elements of type (function . arguments), which
\r
164 describe what is needed to do before reloading the library the
\r
167 ;; SECTION 2a: Cleanup mechanics
\r
169 (defun do-cleanup ()
\r
170 (loop for x in *cleanup*
\r
171 do (apply (car x) (cdr x)))
\r
172 (setf *cleanup* nil))
\r
174 (defun stub-arguments (arglist)
\r
175 "Returns a typical list of arguments for a stub"
\r
176 (loop for x in arglist
\r
177 if (consp x) collect t ;Hmmm... fishy
\r
178 else if (or (keywordp x)
\r
179 (member x '(&allow-other-keys &key &rest &aux &optional)))
\r
181 else if (symbolp x) collect t))
\r
183 (defun cleanup-stub (fun args)
\r
184 (loop for x in (compute-applicable-methods fun (stub-arguments args))
\r
185 do (remove-method fun x)))
\r
187 (defun register-stub (fun arglist)
\r
188 (push (cons #'cleanup-stub (list fun arglist)) *cleanup*))
\r
190 (defun register-generic (fun)
\r
191 (push (cons #'fmakunbound (list fun)) *cleanup*))
\r
194 ;; SECTION 3: The Pretty Printer (well, not very pretty)
\r
196 (defun newline (&optional (stream *outstream*))
\r
197 "Print a newline with printer"
\r
198 (setf *offset* 0) (terpri stream))
\r
200 (defun freshline (&optional (stream *outstream*))
\r
201 "Print a fresh line with printer"
\r
202 (setf *offset* 0) (fresh-line stream))
\r
204 (defun outprinc (str &optional (stream *outstream*))
\r
206 (princ str stream) (incf *offset* (length str)))
\r
208 (defun ignore-newlines (str)
\r
209 "Remove all newlines from a given string (allows us to use Lisp multilines)"
\r
210 (let (spaceflag (countspaces 0))
\r
211 (with-output-to-string (out)
\r
212 (loop for c across str
\r
213 when (char= c #\Space) do (incf countspaces)
\r
214 else when (char= c #\Newline) do (setf spaceflag t countspaces 0)
\r
215 (princ #\Space out)
\r
216 else do (unless spaceflag (loop for i from 1 to countspaces
\r
217 do (princ #\Space out)))
\r
218 (princ c out) (setf spaceflag nil countspaces 0))
\r
219 (loop for i from 1 to countspaces do (princ #\Space out)))))
\r
221 (defun put-word (word stream)
\r
222 "Put a word to printer"
\r
223 (let ((wordlen (length word)))
\r
224 (if (<= (+ *offset* wordlen 1) *textwidth*)
\r
225 (progn (princ word stream) (princ #\Space stream)
\r
226 (incf *offset* (1+ wordlen)))
\r
227 (progn (newline stream) (princ word stream)
\r
228 (princ #\Space stream)
\r
229 (incf *offset* (1+ wordlen))))))
\r
231 (defun pretty-string (str stream)
\r
232 "Print a string using pretty printer"
\r
233 (let ((word (make-array 10 :adjustable t
\r
234 :fill-pointer 0 :element-type 'character))
\r
236 (loop for c across str
\r
237 unless (find c *space-chars*)
\r
238 do (vector-push-extend c word) (setf spaceflag nil)
\r
239 else do (unless spaceflag
\r
240 (put-word word stream)
\r
242 (when (char= c #\Newline)
\r
243 (setf spaceflag nil) (newline stream))
\r
244 (adjust-array word 10 :fill-pointer 0)))
\r
245 (unless (zerop (length word)) (put-word word stream))))
\r
247 (defun sprint (str &rest args)
\r
248 "format-like facility for printing strings with pretty printer"
\r
249 (pretty-string (apply #'format nil (ignore-newlines str) args) *outstream*)
\r
252 ;;SECTION 4: The Dictionary
\r
254 (defun addword (word)
\r
255 "Add a word to dictionary"
\r
256 (let ((word (string-downcase word)))
\r
257 (multiple-value-bind (num ex) (gethash word *dictionary*)
\r
258 (declare (ignore num))
\r
259 (unless ex (setf (gethash word *dictionary*) (incf *dict-index*))))))
\r
261 (define-condition nosuchword (error)
\r
262 ((word :initarg :word :reader nosuchword-word))
\r
263 (:report (lambda (condition stream)
\r
264 (format stream "No such word in dictionary: ~a"
\r
265 (nosuchword-word condition))))
\r
266 (:documentation "No such word error"))
\r
268 (defun word2dic (word)
\r
269 "Return dictionary index of a given word. Error if there is no
\r
270 such word in dictionary"
\r
271 (let ((word (string-downcase word)))
\r
272 (multiple-value-bind (num ex) (gethash word *dictionary*)
\r
273 (if ex num (error 'nosuchword :word word)))))
\r
275 (defun addword2dic (word)
\r
276 "Return dictionary index of a given word. If there is no such
\r
277 word in dictionary, add it."
\r
278 (let ((word (string-downcase word)))
\r
279 (multiple-value-bind (num ex) (gethash word *dictionary*)
\r
280 (if ex num (setf (gethash word *dictionary*) (incf *dict-index*))))))
\r
282 (defun split-to-words (string)
\r
283 "Returns a list of words in a string"
\r
284 (assert (stringp string))
\r
288 for x across string
\r
289 if (find x *space-chars*)
\r
290 do (unless (zerop (length curword)) (push curword lst))
\r
292 else do (setf curword (format nil "~a~a" curword x))
\r
293 finally (unless (zerop (length curword)) (push curword lst))
\r
294 (return (reverse lst))))
\r
296 ;;SECTION 5: AbstractObject class and it's methods
\r
298 (defclass abstractobject ()
\r
299 ((name :initarg :name :initform "object" :accessor name
\r
300 :documentation "Name of the object")
\r
301 (names :initform nil :reader names
\r
302 :documentation "List of dict-words for the parser")
\r
303 (parent :initarg :parent :initform nil :reader parent
\r
304 :documentation "Parent of object")
\r
305 (children :initform nil :reader children
\r
306 :documentation "Children of object")
\r
307 (flags :initarg :flags :initform nil :accessor flags
\r
308 :documentation "Flags of object"))
\r
309 (:documentation "The main IF object class, of which all other
\r
310 objects are subclasses"))
\r
312 (defgeneric parser (obj words)
\r
314 "Parser for object - returns a number between 0 and 1 indicating
\r
315 how close the guess is."))
\r
316 (register-generic 'parser)
\r
318 (defgeneric initnames (obj names)
\r
319 (:documentation "Init list of names for object"))
\r
320 (register-generic 'initnames)
\r
322 (defgeneric read-property (obj property &rest args)
\r
323 (:documentation "Read property of object"))
\r
324 (register-generic 'read-property)
\r
326 (defgeneric initflags (obj)
\r
327 (:documentation "Adds default flags for object")
\r
328 (:method-combination append :most-specific-last))
\r
329 (register-generic 'initflags)
\r
331 (defsyn rp read-property)
\r
333 (defmethod initialize-instance :after ((this abstractobject) &key)
\r
334 "Used for flag initialisation and adds object to *allobjects*"
\r
335 (setf (slot-value this 'flags) (combine-flags (initflags this)))
\r
336 (push this *allobjects*))
\r
338 (defmethod initflags append ((obj abstractobject))
\r
339 (declare (ignore obj))
\r
342 (defun flag-compare (flag1 flag2)
\r
343 "Tests whether flag2 unsets flag1"
\r
344 (let ((fl1 (symbol-name flag1))
\r
345 (fl2 (symbol-name flag2)))
\r
346 (and (char= (aref fl2 0) #\~) (string= fl1 fl2 :start2 1))))
\r
348 (defun combine-flags (flaglist)
\r
349 "Combine a list of flags into a _set_ of flags"
\r
350 (loop for fl in flaglist
\r
351 if (char= (aref (symbol-name fl) 0) #\~)
\r
352 do (setq set (nset-difference set (list fl) :test #'flag-compare))
\r
353 else collect fl into set
\r
354 finally (return set)))
\r
356 (defun add-flags (obj &rest flags)
\r
357 "Add some flags to object"
\r
358 (setf (flags obj) (combine-flags (append (flags obj) flags))))
\r
360 (defun give (obj &rest flags)
\r
361 "Informish synonim to add-flags."
\r
362 (setf (flags obj) (combine-flags (append (flags obj) flags))))
\r
364 (defun has (obj &rest flags)
\r
365 "Informish macro has. Unlike Inform, can accept several flags."
\r
366 (subsetp flags (flags obj)))
\r
368 (defun hasnt (obj &rest flags)
\r
369 "Informish macro hasnt. Unlike Inform, can accept several flags."
\r
370 (not (intersection flags (flags obj))))
\r
371 ;(not (subsetp flags (flags obj))))
\r
373 (defmethod parser ((obj abstractobject) words)
\r
374 "Default parser. Really bad one."
\r
375 (when (zerop (length words)) (return-from parser 0))
\r
376 (let ((words1 (remove-duplicates words)))
\r
379 counting (member word (names obj)))
\r
382 (defmethod initnames ((obj abstractobject) names)
\r
383 "Initialise names for object"
\r
384 (setf (slot-value obj 'names)
\r
385 (remove-duplicates (mapcar #'addword2dic names))))
\r
387 (defun add-names (obj names)
\r
388 "Add new names to object"
\r
389 (initnames obj (remove-duplicates
\r
390 (append (names obj) (mapcar #'addword2dic names)))))
\r
392 ;;SECTION 6: read-property bonanza
\r
394 ;;This is an ugly, repetitive mass of code dealing with typing and
\r
395 ;;coercion of types. I am very unhappy with this read-property thing
\r
396 ;;which makes other code very un-elegant. However without these type
\r
397 ;;coersions many Inform features would be impossible to reproduce.
\r
399 (defun eval-err (value type)
\r
400 (error "~S cannot be evaluated as ~a." value type))
\r
402 (defun read-property-string (value &rest args)
\r
403 (cond ((stringp value) value)
\r
405 ((functionp value)
\r
406 (let ((res (apply value args)))
\r
407 (read-property-string res args)))
\r
408 ((numberp value) (format nil "~a" value))
\r
409 ((and (typep value 'abstractobject)
\r
410 (slot-exists-p value 'name)
\r
411 (stringp (name value))) (name value))
\r
412 (t (eval-err value "string"))))
\r
414 (defun read-property-number (value &rest args)
\r
415 (cond ((numberp value) value)
\r
417 ((functionp value)
\r
418 (let ((res (apply value args)))
\r
419 (read-property-number res args)))
\r
420 (t (eval-err value "number"))))
\r
422 (defun read-property-integer (value &rest args)
\r
423 (cond ((integerp value) value)
\r
425 ((functionp value)
\r
426 (let ((res (apply value args)))
\r
427 (read-property-integer res args)))
\r
428 ((stringp value) (parse-integer value :junk-allowed t))
\r
429 (t (eval-err value "integer"))))
\r
431 (defun read-property-object (value &rest args)
\r
432 (cond ((typep value 'abstractobject) value)
\r
435 (let ((res (apply value args)))
\r
436 (read-property-object res args)))
\r
438 (let ((res (symbol-value value)))
\r
439 (read-property-object res args)))
\r
440 ((stringp value) (sprint "~a~%" value) (values value t))
\r
441 (t (eval-err value "object"))))
\r
443 (defmacro exec (func (&rest args) &key str)
\r
444 (with-gen-syms (tmp)
\r
445 `(let ((,tmp (apply #',func (list ,@args))))
\r
447 `(when (stringp ,tmp) (sprint ,tmp) (newline *outstream*)))
\r
450 (defun exec* (func args &key str)
\r
451 (let ((args (if (listp args) args (list args))))
\r
452 (let ((tmp (apply func args)))
\r
453 (unless str (when (stringp tmp) (sprint tmp) (newline *outstream*)))
\r
456 (defun read-property-execute (value &rest args)
\r
457 (cond ((functionp value) (exec* value args))
\r
459 ((stringp value) (sprint "~a~%" value) (values value t))
\r
462 (defun read-property-list (value &rest args)
\r
463 (cond ((listp value) value)
\r
465 (let ((res (apply value args)))
\r
466 (if (listp res) res (list res))))
\r
469 (defun read-property-other (value &rest args)
\r
470 (declare (ignore args)) value)
\r
472 (defmethod read-property ((self abstractobject) property &rest args)
\r
473 "default read-property"
\r
475 (name (apply #'read-property-string (slot-value self property) args))
\r
476 (description (apply #'read-property-string (slot-value self property) args))
\r
477 (article (apply #'read-property-string (slot-value self property) args))
\r
478 (glance (apply #'read-property-string (slot-value self property) args))
\r
479 (t (slot-value self property))))
\r
482 ;;SECTION 7: IfClass macro and its hairy surroundings
\r
484 (defun type-keywordp (obj)
\r
485 "Defines a list of type keywords which are used for property declarations"
\r
487 (cdr (assoc (symbol-name obj)
\r
488 (mapcar #'(lambda (s) (cons (symbol-name s) s))
\r
489 '(string number integer object function))))))
\r
491 (defun parse-prop (prop)
\r
492 "Parsing individual property"
\r
493 (let* ((p1 (first prop))
\r
497 (ggg (type-keywordp p2)))
\r
498 (case (length prop)
\r
499 (1 (list p1 nil nil))
\r
500 (2 (if ggg (list p1 ggg) (list p1 nil p2)))
\r
501 (3 (if ggg (list p1 ggg p3) (list p1 nil p2 p3)))
\r
502 (4 (list p1 p2 p3 p4)))))
\r
504 (defun prop-process1 (name type &optional initform (documentation ""))
\r
505 "Macro helper function"
\r
507 (setf initform (case type
\r
515 `(,name :initarg ,(as-keyword name) :accessor ,name :initform ,initform
\r
516 :documentation ,documentation))
\r
518 (defun prop-process2 (name type &rest stuff)
\r
519 "Macro helper function"
\r
520 (declare (ignore stuff))
\r
521 (unless type (return-from prop-process2 nil))
\r
524 (string #'read-property-string)
\r
525 (number #'read-property-number)
\r
526 (integer #'read-property-integer)
\r
527 (object #'read-property-object)
\r
528 (function #'read-property-execute)
\r
529 (list #'read-property-list)
\r
530 (t #'read-property-other))
\r
531 (slot-value self property) args)))
\r
533 (defmacro declare-rule (&rest args)
\r
534 "Declare new rules"
\r
536 ,@(loop for x in args
\r
537 collect `(pushnew ',x *rules*)
\r
538 collect `(defgeneric ,x (obj)
\r
539 (:method-combination or)
\r
540 (:method or (obj) (declare (ignore obj)) nil))
\r
541 collect `(register-generic (quote ,x)))))
\r
543 (defmacro declare-predicate (&rest args)
\r
544 "Declare new predicates"
\r
546 ,@(loop for x in args
\r
547 collect `(pushnew ',x *predicates*)
\r
548 collect `(defgeneric ,x (obj &optional what)
\r
549 (:method (obj &optional what)
\r
550 (declare (ignore obj what)) nil))
\r
551 collect `(register-generic (quote ,x)))))
\r
553 (declare-rule before after react-before react-after)
\r
555 (defun generate-rules (name rules)
\r
556 "Generates rules for a class"
\r
558 (dolist (r *rules* result)
\r
559 (let ((rul (cdr (assoc r rules))))
\r
560 (when rul (push `(defmethod ,r or ((self ,name))
\r
561 (declare (ignorable self))
\r
562 (case *action* ,@rul)) result))))))
\r
564 (defun generate-predicates (name predicates)
\r
565 "Generates predicates for a class"
\r
567 (dolist (p *predicates* result)
\r
568 (let ((pred (cdr (assoc p predicates))))
\r
570 (destructuring-bind (what . stuff) pred
\r
571 (flet ((pfun (pred &key (terminate nil))
\r
572 (destructuring-bind (what . stuff) pred
\r
574 (let ((w (car what)))
\r
576 `(defmethod ,p ((self ,name) &optional ,w)
\r
577 (declare (ignorable self ,w))
\r
580 (loop for ,x in *allobjects*
\r
583 (or (progn ,@stuff)
\r
584 ,(unless terminate
\r
585 `(call-next-method))))))
\r
586 (with-gen-syms (x)
\r
587 `(defmethod ,p ((self ,name) &optional ,x)
\r
588 (declare (ignorable self))
\r
589 (unless ,x (return-from ,p (list ,@pred)))
\r
590 (or (member ,x (list ,@pred))
\r
591 ,(unless terminate
\r
592 `(call-next-method)))))))))
\r
593 (push (if (eql what :only)
\r
594 (pfun stuff :terminate t)
\r
595 (pfun pred)) result))))))))
\r
599 (defmacro ifclass (name (&rest classes) &rest options)
\r
600 "Macro for generating IF classes"
\r
601 (let (rules predicates)
\r
602 (multiple-value-bind (proplist flaglist)
\r
603 (loop for opt in options
\r
604 for word = (car opt)
\r
605 if (eql word 'has) collect opt into fllist
\r
606 else if (member word *rules*)
\r
607 do (pushnew (cons word (cdr opt)) rules
\r
608 :test (lambda (a b) (eql (car a) (car b))))
\r
609 else if (member word *predicates*)
\r
610 do (pushnew (cons word (cdr opt)) predicates
\r
611 :test (lambda (a b) (eql (car a) (car b))))
\r
612 else collect opt into prlist
\r
613 finally (return (values prlist fllist)))
\r
615 ;;(declare (ignorable self))
\r
616 (defclass ,name ,(or classes '(abstractobject))
\r
617 ,(loop for prop in proplist
\r
618 when (apply #'prop-process1 (parse-prop prop)) collect it))
\r
619 (defmethod read-property ((self ,name) property &rest args)
\r
620 (declare (ignorable args))
\r
622 ,@(loop for prop in proplist
\r
623 when (apply #'prop-process2 (parse-prop prop)) collect it)
\r
624 (t (call-next-method))))
\r
625 (handler-bind ((warning #'ignore-warning))
\r
626 (defmethod initflags append ((obj ,name))
\r
627 (declare (ignore obj))
\r
628 (list ,@(loop for fl in flaglist appending (cdr fl))))
\r
629 ,@(generate-rules name rules)
\r
630 ,@(generate-predicates name predicates))))))
\r
632 (defun ofclass (obj class)
\r
633 "Better name for typep"
\r
636 ;;SECTION 8: Object macro and some related functions
\r
638 (defmacro object (intname (&rest classes) &rest options)
\r
639 "Macro for creating objects"
\r
640 (multiple-value-bind (extname parent namelist proplist flaglist)
\r
641 (loop with extname = ""
\r
645 if (listp opt) do (setq word (car opt))
\r
646 else if (stringp opt) do (setq extname opt)
\r
647 else do (setq parent opt)
\r
649 if (eql word 'has) collect opt into fllist
\r
650 else if (eql word 'name) collect opt into nmlist
\r
651 else collect opt into prlist
\r
652 finally (return (values extname parent nmlist prlist fllist)))
\r
654 (unless (or namelist (endp (setq listwords (split-to-words extname))))
\r
655 (setf namelist `((name ,@listwords)))))
\r
656 (with-gen-syms (this) ;other)
\r
659 (ifclass ,intname ,classes ,@proplist ,@flaglist)
\r
660 (defmethod initialize-instance :after ((,this ,intname) &key)
\r
661 (setf (slot-value ,this 'name) ,extname)
\r
662 (initnames ,this ',(loop for nm in namelist appending (cdr nm)))
\r
663 (move ,this ,parent))
\r
664 ,(when (boundp intname)
\r
665 `(setf *allobjects* (remove ,intname *allobjects*)))
\r
666 (defparameter ,intname (make-instance ',intname))))))
\r
668 (defun move (obj1 obj2)
\r
669 "Move one object inside another"
\r
671 (when (setf objt (parent obj1))
\r
672 (setf (slot-value objt 'children)
\r
673 (remove obj1 (slot-value objt 'children)))
\r
674 (setf (slot-value obj1 'parent) nil))
\r
676 (pushnew obj1 (slot-value obj2 'children))
\r
677 (setf (slot-value obj1 'parent) obj2))))
\r
680 "Move object to top-level"
\r
683 (defun in (obj1 &rest what)
\r
684 "Tests whether the first object is inside some of the others"
\r
685 (some (lambda (x) (eql (parent obj1) x)) what))
\r
687 (defun destroy (obj)
\r
688 "Destroy the object, like, totally!"
\r
689 (setf *allobjects* (remove obj *allobjects*))
\r
692 (defmacro defaction (name (&rest args) &body body)
\r
693 "Creates a new action"
\r
694 (let ((doc (car body)) (body2 (cdr body)))
\r
695 (unless (and (stringp doc) body2) (setf doc "") (setf body2 body))
\r
697 (defgeneric ,name ,args
\r
698 (:documentation ,doc)
\r
699 (:method ,args (declare (ignorable ,@args)) ,@body2))
\r
700 (register-generic (quote ,name)))))
\r
702 (defmacro objectloop ((&whole alltest iter &rest test) &body body)
\r
703 "Iterates over objects satisfying test. Use !last! as an indicator
\r
704 that the loop is reaching its end"
\r
705 (with-gen-syms (iterlist lastone)
\r
707 (let ((iterator (first test)))
\r
710 (eql (list ,(second test)))
\r
711 (in (children ,(second test)))
\r
712 (member ,(second test))
\r
714 #'(lambda (,iterator) (not ,alltest)) *allobjects*)))))
\r
715 (let ((,lastone (car (last ,iterlist))))
\r
716 (dolist (,iterator ,iterlist)
\r
717 (let ((!last! (eql ,iterator ,lastone)))
\r
718 (declare (ignorable !last!))
\r
720 `(dolist (,iter *allobjects*) ,@body))))
\r
722 (defun provides (obj slot)
\r
723 "Tests whether an object has a given property"
\r
724 (slot-exists-p obj slot))
\r
726 (defun among (obj &rest what)
\r
727 "Tests whether obj is among other arguments"
\r
730 (defun notin (obj &rest what)
\r
731 "Test whether the object is not in any of other arguments"
\r
732 (notany (lambda (x) (eql (parent obj) x)) what))
\r
734 ;;SECTION 9: Verb functions
\r
736 (defstruct patternlist value)
\r
738 (defun add-to-end (plist value)
\r
739 "Add pattern to the end of patternlist"
\r
740 (setf (patternlist-value plist)
\r
741 (append (patternlist-value plist)
\r
742 (if (listp value) value (list value)))))
\r
744 (defun add-to-start (plist value)
\r
745 "Add pattern to the beginning of patternlist"
\r
746 (setf (patternlist-value plist)
\r
747 (append (if (listp value) value (list value))
\r
748 (patternlist-value plist))))
\r
750 (defun add-verb-pattern (verb plist)
\r
751 "Associate verb and patternlist"
\r
752 (setf (gethash verb *verbs*) plist))
\r
754 (defun extend-verb-pattern (verb pattern)
\r
755 "Add pattern to the end of verb's patternlist"
\r
756 (add-to-end (gethash verb *verbs*) pattern))
\r
758 (defun extend-verb-pattern-first (verb pattern)
\r
759 "Add pattern to the beginning of verb's patternlist"
\r
760 (add-to-start (gethash verb *verbs*) pattern))
\r
762 (defun verb (&rest args)
\r
764 (multiple-value-bind (namelist pattern)
\r
765 (loop for cons on args
\r
766 unless (stringp (car cons))
\r
767 return (values (ldiff args cons) cons))
\r
768 (let ((newpattern (make-patternlist :value pattern)))
\r
769 (mapcar #'(lambda (name)
\r
770 (add-verb-pattern (addword2dic name) newpattern))
\r
773 (defun extend-verb (name &rest pattern)
\r
774 "Extend already existing verb"
\r
775 (extend-verb-pattern (word2dic name) pattern))
\r
777 (defun extend-verb-first (name &rest pattern)
\r
778 "Extend verb, by adding new pattern to the beginning"
\r
779 (extend-verb-pattern-first (word2dic name) pattern))
\r
781 (defun extend-verb-only (&rest args)
\r
782 "Provide additional patterns only for some synonims"
\r
783 (multiple-value-bind (namelist pattern)
\r
784 (loop for cons on args
\r
785 unless (stringp (car cons))
\r
786 return (values (ldiff args cons) cons))
\r
787 (let* ((name (car namelist))
\r
788 (dicname (word2dic name))
\r
789 (patt (make-patternlist
\r
790 :value (patternlist-value (gethash dicname *verbs*)))))
\r
791 (mapcar #'(lambda (name)
\r
792 (add-verb-pattern (addword2dic name) patt))
\r
794 (extend-verb-pattern dicname pattern))))
\r
796 (defun extend-verb-only-first (&rest args)
\r
797 "Provide additional patterns for specified synonims to the beginning"
\r
798 (multiple-value-bind (namelist pattern)
\r
799 (loop for cons on args
\r
800 unless (stringp (car cons))
\r
801 return (values (ldiff args cons) cons))
\r
802 (let* ((name (car namelist))
\r
803 (dicname (word2dic name))
\r
804 (patt (make-patternlist
\r
805 :value (patternlist-value (gethash dicname *verbs*)))))
\r
806 (mapcar #'(lambda (name)
\r
807 (add-verb-pattern (addword2dic name) patt))
\r
809 (extend-verb-pattern-first dicname pattern))))
\r
811 ;;SECTION 10: pattern matching
\r
813 ;;The pattern has the following format:
\r
814 ;;(...list of tokens... -> ACTION ORDER)
\r
815 ;;ACTION - name of action (no action by default)
\r
816 ;;ORDER - function that given a list shuffles it according to required order
\r
820 (defun parse-pattern (pattern)
\r
821 "Splits pattern into it's core parts"
\r
822 (loop for p on pattern
\r
823 if (eql (car p) '->)
\r
824 return (values (ldiff pattern p)
\r
825 (second p) (third p))
\r
826 finally (return (values pattern nil nil))))
\r
828 (defmacro deftoken (name &body body)
\r
829 "The body should contain a function that, given wordlist and tokenlist
\r
830 returns state of success, the result and remaining words. Each token
\r
831 consumes one arg but can use every remaining one for additional
\r
832 information (e.g. :multiinside can see the next tokens to determine
\r
833 whether an object is inside another object"
\r
834 `(setf (gethash ,name *tokens*)
\r
835 #'(lambda (wordlist tokenlist)
\r
836 (declare (ignorable wordlist tokenlist))
\r
839 (defun string== (str1 str2)
\r
840 "Case-insensitive string="
\r
841 (string= (string-downcase str1) (string-downcase str2)))
\r
843 (defun shuffle (list order)
\r
844 "Shuffle given list according to the order specified"
\r
845 (if order (funcall order list) list))
\r
847 (defun matchp (words pattern &aux arglist)
\r
848 "Matches string against pattern and returns action and args on success"
\r
849 (multiple-value-bind (tokenlist action order) (parse-pattern pattern)
\r
850 (loop named mainloop
\r
851 for tokens on tokenlist
\r
852 for token = (car tokens)
\r
853 when (stringp token)
\r
854 do (when (loop with spl = (split-to-words token)
\r
855 while (and words spl
\r
856 (string== (car words) (car spl)))
\r
857 do (pop words) (pop spl)
\r
858 finally (return spl))
\r
859 (return-from mainloop nil))
\r
860 else when (listp token)
\r
861 do (let* ((tokenfun (gethash (first token) *tokens*))
\r
862 (tpar (second token))
\r
863 (tparall (cdr token))
\r
864 (*tokenpar* (if (functionp tpar)
\r
865 (apply tpar (cdr tparall)) tparall)))
\r
866 (declare (ignorable *tokenpar*))
\r
867 (unless tokenfun (return-from mainloop nil))
\r
868 (multiple-value-bind (success result remwords)
\r
869 (funcall tokenfun words tokens)
\r
870 (unless success (return-from mainloop nil))
\r
871 (when result (push result arglist))
\r
872 (setf words remwords)))
\r
873 else do (let ((tokenfun (gethash token *tokens*)))
\r
874 (unless tokenfun (return-from mainloop nil))
\r
875 (multiple-value-bind (success result remwords)
\r
876 (funcall tokenfun words tokens)
\r
877 (unless success (return-from mainloop nil))
\r
878 (push result arglist)
\r
879 (setf words remwords)))
\r
880 finally (if (endp words)
\r
881 (return-from mainloop
\r
883 (shuffle (reverse arglist) order)))
\r
884 (return-from mainloop nil)))))
\r
887 ;;SECTION 11: Core functionality & commands parsing
\r
890 (defmacro supply (name args &body body)
\r
891 "Supply a method to be used instead of default. Equivalent of
\r
892 Inform's stub functions."
\r
893 `(defmethod ,name :around ,args ,@body))
\r
895 (defmacro defstub (name args &body body)
\r
896 "Make a stub generic function, supply target"
\r
897 (let ((docstring "") (otherbody body))
\r
898 (when (and (cdr body) (stringp (car body))
\r
899 (setf docstring (car body))
\r
900 (setf otherbody (cdr body)))
\r
902 (defgeneric ,name ,args
\r
903 (:documentation ,docstring)
\r
904 (:method ,args ,@otherbody))
\r
905 (register-stub (function ,name) (quote ,args))))))
\r
908 (defstub unknown-verb (word)
\r
909 "Display error message for unknown verb"
\r
910 (format nil "No such verb: \"~a\"" word))
\r
912 ;(defgeneric turn-passing (&optional time)
\r
913 ; (:documentation "Called at the end of turn")
\r
914 ; (:method (&optional time) (declare (ignore time))))
\r
916 (defstub turn-passing (&optional time)
\r
917 "Called at the end of turn"
\r
918 (declare (ignore time)) nil)
\r
920 (defstub before-hook ()
\r
921 "Used for special before rules set up by iflib.lisp"
\r
924 (defstub after-hook ()
\r
925 "Used for special after rules set up by if.lisp"
\r
928 (defun run-action-after (obj)
\r
929 "Run after actions, if appropriate"
\r
931 (when (exec after-hook nil)
\r
932 (setf *after* nil)
\r
933 (return-from run-action-after nil))
\r
934 (when (and *args* (exec* #'after obj))
\r
936 (return-from run-action-after nil))
\r
940 (defun run-action (action args &key (time 0))
\r
941 "Run an action with a given args"
\r
942 (unless (listp args) (setf args (list args)))
\r
944 (let ((*action* action)
\r
946 (*noun* (first args))
\r
947 (*second* (second args)))
\r
949 (format t "[running action: ~a ~a]~%" *action* *args*))
\r
950 (when *meta* ;;Just do the darn thing!
\r
951 (exec* action args)
\r
953 (return-from run-action t))
\r
955 (when (exec before-hook nil) (return-from run-action nil))
\r
956 (when (and args (exec* #'before (car args)))
\r
957 (return-from run-action nil))
\r
959 (exec* action args)
\r
960 (unless (zerop time) (turn-passing time))
\r
963 (defun instead (action args &key (time 0))
\r
964 "same as run-action, but always returns t"
\r
965 (run-action action args :time time) t)
\r
967 (defun parse-command (string)
\r
968 "Parse command and execute appropriate action"
\r
969 (destructuring-bind (verb . words) (split-to-words string)
\r
970 (handler-bind ((nosuchword
\r
971 #'(lambda (condition)
\r
972 (exec unknown-verb
\r
973 ((nosuchword-word condition)))
\r
974 (return-from parse-command nil))))
\r
975 (let* ((dverb (word2dic verb))
\r
976 (plist (gethash dverb *verbs*))
\r
977 (patterns (when plist (patternlist-value plist))))
\r
978 (unless plist (signal 'nosuchword :word verb))
\r
979 ;;(print words) (print patterns)
\r
980 (loop for pat in patterns
\r
981 when (multiple-value-bind (action args) (matchp words pat)
\r
982 (when action (run-action action args :time 1) t))
\r
984 finally (sprint "Sorry, I can't parse that.~%"))))))
\r