upd advent.lisp so it works

[lifp.git] / if.lisp

diff --git a/if.lisp b/if.lisp
index 08d5038aa070f1f779b87225b04cc1a2c0fdcf2a..447f69787db91d9ae9364c3290072654903bc4ec 100644 (file)
--- a/if.lisp
+++ b/if.lisp
@@ -36,14 +36,13 @@
            :addword :word2dic :addword2dic\r
            :split-to-words :sprint\r
            :parser :description :article :glance \r
-           :initnames :addnames\r
-           :read-property :read-property-string :read-property-number\r
-           :read-property-integer :read-property-object :read-property-execute\r
-           :read-property-other :read-property-list :exec :exec*\r
+           :initnames :addnames \r
+           :read-property :rp :read-property- \r
+           :exec :exec*\r
            :abstractobject :name :names :parent :children :flags\r
-           :initflags :add-flags :has :hasnt :-> :give\r
+           :initflags :add-flags :has :hasnt :-> :give :child\r
            :ifclass :object :defaction :*meta*\r
-           :move :rmv :ofclass :among\r
+           :move :rmv :ofclass :among :below\r
            :verb :extend-verb :extend-verb-first\r
            :extend-verb-only :extend-verb-only-first\r
            :deftoken :string== :matchp :!last!\r
@@ -89,7 +88,7 @@
   "make defvars for names"\r
   `(progn\r
      ,@(loop for x in names\r
-           collect `(defvar ,x))))\r
+           collect `(defvar ,x nil))))\r
 \r
 ;;SECTION 2: Global parameters and definitions\r
 \r
@@ -359,7 +358,7 @@ word in dictionary, add it."
 \r
 (defun give (obj &rest flags) \r
   "Informish synonim to add-flags." \r
-  (setf (flags obj) (combine-flags (append (flags obj) flags))))\r
+  (setf (flags obj) (combine-flags (append (flags obj) flags)))  nil)\r
 \r
 (defun has (obj &rest flags)\r
   "Informish macro has. Unlike Inform, can accept several flags."\r
@@ -370,6 +369,10 @@ word in dictionary, add it."
   (not (intersection flags (flags obj))))\r
   ;(not (subsetp flags (flags obj))))\r
 \r
+(defun child (obj)\r
+  "Returns the first child of the object"\r
+  (car (children obj)))\r
+\r
 (defmethod parser ((obj abstractobject) words) \r
   "Default parser. Really bad one."\r
   (when (zerop (length words)) (return-from parser 0))\r
@@ -478,6 +481,17 @@ word in dictionary, add it."
     (glance (apply #'read-property-string (slot-value self property) args))\r
     (t (slot-value self property))))\r
 \r
+(defun read-property- (method self property &rest args)\r
+  "read-property using specific method. method is one of keywords:\r
+   :string :number :object :integer :execute :list"\r
+  (case method\r
+    (:string (apply #'read-property-string (slot-value self property) args))\r
+    (:number (apply #'read-property-number (slot-value self property) args))\r
+    (:integer (apply #'read-property-integer (slot-value self property) args))\r
+    (:object (apply #'read-property-object (slot-value self property) args))\r
+    (:execute (apply #'read-property-execute (slot-value self property) args))\r
+    (:list (apply #'read-property-list (slot-value self property) args))\r
+    (t (slot-value self property))))\r
 \r
 ;;SECTION 7: IfClass macro and its hairy surroundings\r
 \r
@@ -730,7 +744,14 @@ word in dictionary, add it."
 (defun notin (obj &rest what)\r
   "Test whether the object is not in any of other arguments"\r
   (notany (lambda (x) (eql (parent obj) x)) what))\r
-   \r
+\r
+(defun below (obj1 obj2)\r
+  "Tests whether obj1 is strictly below obj2 in object structure"\r
+  (loop for x = obj1 then (parent x)\r
+        while x\r
+        when (eql x obj2) do (return t)\r
+        finally (return nil)))\r
+\r
 ;;SECTION 9: Verb functions\r
 \r
 (defstruct patternlist value)\r
@@ -937,14 +958,15 @@ word in dictionary, add it."
   ;;React after?\r
   t)\r
 \r
-(defun run-action (action args &key (time 0))\r
+(defun run-action (action args &key (time 0) no-output)\r
   "Run an action with a given args"\r
   (unless (listp args) (setf args (list args)))\r
   (setf *after* nil)\r
   (let ((*action* action)\r
         (*args* args)\r
         (*noun* (first args))\r
-        (*second* (second args)))\r
+        (*second* (second args))\r
+        (*no-output* no-output))\r
     (when *debug* \r
       (format t "[running action: ~a ~a]~%" *action* *args*))\r
     (when *meta* ;;Just do the darn thing!\r