;;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
           :food :switchable :door :predoor
	   :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 :destination
	   :*intscope*  :*outscope* :*location* :*trace-light* :*vowels*
	   :*score* :*gamestate* :*turns* :*dark*
           :add-to-scope :add-to-outscope :found-in :seen-from :with-keys
	   :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 :daemon :time-left :time-out
           :start-daemon :stop-daemon :start-timer :stop-timer           
	   :supporter :animate :scenery
	   :afterlife :print-gamestate :end-game
	   :repl-mode :compile-lib :free-symbol 
	   )
  (: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
                   with-keys)

;;Library file names
(defvar *library-file-if* "if.fas")
(defvar *library-file-iflib* "iflib.fas")
(defvar *library-file-verbs* "verbs.fas") 

;;SECTION 2: Library-defined classes and objects

(ifclass predoor ()) ;;Can potentially be locked... 

(ifclass container (predoor) (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) <- doesn't provide by default
	 (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))

(ifclass door (predoor scenery) (destination object) 
         (has :door :closed :openable))



;;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 (and (has obj :container) (hasnt obj :closed)) 
      (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 (and (has obj :container) (hasnt obj :closed))
      (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)) (progn (sprint value) t) printp)))

(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 (hasnt obj :closed) (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 *allobjects*
              if (and (has x :daemon) (provides x 'daemon))
              do (read-property- :execute x 'daemon)
              if (and (has x :timer) (provides x 'time-left) 
                      (provides x 'time-out))
              do (if (zerop (slot-value x 'time-left))
                     (read-property- :execute x 'time-out)
                     (decf (slot-value x 'time-left))))
        (loop for x in *outscope*
	      if (provides x 'each-turn)
	      do (read-property- :execute x 'each-turn))           
	(call-next-method))	     

(defun start-daemon (obj)
  (give obj :daemon))

(defun stop-daemon (obj)
  (give obj :~daemon))

(defun start-timer (obj time)
  (assert (provides obj 'time-left))
  (setf (slot-value obj 'time-left) time)
  (give obj :timer))

(defun stop-timer (obj)
  (give obj :~timer))

(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-basic-lib...")
  (load (merge-pathnames dir *library-file-if*))
  (print-message "Loading if-lib...") 
  (load (merge-pathnames dir *library-file-iflib*))
  (print-message "Loading verbs...") 
  (load (merge-pathnames dir *library-file-verbs*))
  (print-message "Loading game module...") 
  (load file)
  (print-message "Module is successfully loaded."))

(defun test-seq (&optional (rm *repl-mode*))
  "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")
  (unless *repl-mode*
    (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 :fill :open :close)))

(defmacro free-symbol (id)
  "Frees a symbol from current package using shadow"
  `(eval-when (:compile-toplevel :load-toplevel :execute)
     (shadow ,id)))

   
(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"))

#+clisp
(defun deliver-me ()
  (ext:saveinitmem "lifp.exe" :quiet t :norc t 
		   :init-function #'interactive-start 
		   :start-package :if-lib 
		   :executable t))