quest.lisp

(in-package #:org.shirakumo.fraf.kandria)

(defvar *current-task*)
(defvar *current-interaction*)

(defclass storyline (quest:storyline)
  ((default-interactions :initform (make-hash-table :test 'eql) :reader default-interactions)))

(defclass quest (quest:quest alloy:observable)
  ((clock :initarg :clock :initform 0f0 :accessor clock)
   (start-time :initarg :start-time :initform 0f0 :accessor start-time)
   (visible-p :initarg :visible :initform T :accessor visible-p)
   (experience-reward :initarg :experience-reward :initform 500 :accessor experience-reward)))

(define-event quest-started (event) quest)
(define-event quest-completed (event) quest)
(define-event quest-failed (event) quest)
(define-event task-completed (event) task)
(define-event game-over (event) ending)

(alloy:make-observable '(setf clock) '(value alloy:observable))
(alloy:make-observable '(setf quest:status) '(value alloy:observable))

(defmethod quest:class-for ((storyline (eql 'quest:quest))) 'quest)

(defmethod quest:activate :before ((quest quest))
  (when (and (not (eql :active (quest:status quest)))
             (visible-p quest))
    (harmony:play (// 'sound 'ui-quest-start))
    (status :important (@formats 'new-quest-started (quest:title quest)))
    (setf (start-time quest) (clock +world+))
    (issue +world+ 'quest-started :quest quest))
  (setf (clock quest) 0f0))

(defmethod quest:complete :before ((quest quest))
  (when (and (not (eql :complete (quest:status quest)))
             (visible-p quest))
    (award-experience (node 'player T) (experience-reward quest))
    (harmony:play (// 'sound 'ui-quest-complete))
    (status :important (@formats 'quest-successfully-completed (quest:title quest)))
    (issue +world+ 'quest-completed :quest quest)))

(defmethod quest:fail :before ((quest quest))
  (when (and (not (eql :failed (quest:status quest)))
             (visible-p quest))
    (harmony:play (// 'sound 'ui-quest-fail))
    (status :important (@formats 'quest-completion-failed (quest:title quest)))
    (issue +world+ 'quest-failed :quest quest)))

(defmethod quest:make-assembly ((_ quest))
  (make-instance 'assembly))

(defclass task (quest:task)
  ((visible-p :initarg :visible :initform T :accessor visible-p)
   (progress-fun :initarg :progress-fun :initform NIL :accessor progress-fun)
   (full-progress :initarg :full-progress :initform 0 :accessor full-progress)
   (last-progress :initform 0 :accessor last-progress)
   (marker :initarg :marker :initform NIL :accessor marker)))

(defmethod shared-initialize :after ((task task) slots &key progress-fun)
  (typecase progress-fun
    ((or function null))
    (T (setf (progress-fun task) (compile NIL `(lambda () ,(task-wrap-lexenv progress-fun)))))))

(defmethod quest:try :around ((task task))
  (let ((progress (current-progress task))
        (*current-task* task))
    (when progress
      (when (< (last-progress task) progress)
        (harmony:play (// 'sound 'ui-quest-update) :reset T)
        (status :note "~a (~a/~a)" (quest:title task) progress (full-progress task)))
      (setf (last-progress task) progress))
    (call-next-method)))

(defmethod current-progress ((task task))
  (let ((fun (progress-fun task))
        (*current-task* task))
    (when fun (funcall fun))))

(defmethod quest:class-for ((storyline (eql 'quest:task))) 'task)

(defmethod quest:make-assembly ((task task))
  (make-instance 'assembly))

(defmethod quest:activate :around ((task task))
  (let ((*current-task* task))
    (call-next-method))
  (when (and (marker task) (setting :gameplay :display-hud))
    (show (make-instance 'quest-indicator :target (unlist (marker task))))))

(defmethod quest:complete :after ((task task))
  (issue +world+ 'task-completed :task task))

(defclass interaction (quest:interaction)
  ((source :initform NIL :initarg :source :accessor source)
   (repeatable :initform NIL :initarg :repeatable :accessor repeatable-p)
   (auto-trigger :initform NIL :initarg :auto-trigger :accessor auto-trigger)))

(defmethod shared-initialize :around ((interaction interaction) slots &rest args &key source dialogue task name)
  (cond (dialogue
         (call-next-method))
        ((or source (and (slot-boundp interaction 'source) (source interaction)))
         (let ((dialogue (apply #'find-mess (enlist (or source (source interaction))))))
           (apply #'call-next-method interaction slots :dialogue dialogue args)))
        ((or task (and (slot-boundp interaction 'quest:task) (quest:task interaction)))
         (let* ((task (or task (quest:task interaction)))
                (name (or name (quest:name interaction)))
                (source (list (quest:name (quest:quest task)) (format NIL "~(~a/~a~)" (quest:name task) name)))
                (dialogue (handler-case (apply #'find-mess source)
                            (sb-ext:file-does-not-exist ()))))
           (cond (dialogue
                  (setf (source interaction) source)
                  (apply #'call-next-method interaction slots :dialogue dialogue args))
                 (T
                  (call-next-method)))))
        (T
         (call-next-method))))

(defmethod quest:class-for ((storyline (eql 'quest:interaction))) 'interaction)

(defmethod quest:make-assembly ((interaction interaction))
  (make-instance 'assembly))

(defmethod quest:activate ((trigger interaction))
  (with-simple-restart (abort "Don't activate the interaction.")
    (when (and +world+ (not (auto-trigger trigger)))
      (let ((interactable (node (quest:interactable trigger) +world+)))
        (if (typep interactable 'interactable)
            (pushnew trigger (interactions interactable))
            (v:severe :kandria.quest "What the fuck? Can't find interaction target ~s, got ~a"
                      (quest:interactable trigger) interactable))))))

(defmethod quest:deactivate :around ((trigger interaction))
  (call-next-method)
  (when +world+
    (let ((interactable (node (quest:interactable trigger) +world+)))
      (when (typep interactable 'interactable)
        (setf (interactions interactable) (remove trigger (interactions interactable)))))))

(defmethod quest:complete ((trigger interaction))
  (when +world+
    (let ((interactable (node (quest:interactable trigger) +world+)))
      (when (and (typep interactable 'interactable)
                 (not (repeatable-p trigger)))
        (setf (interactions interactable) (remove trigger (interactions interactable)))))))

(defmethod quest:try ((trigger interaction))
  (when (and (auto-trigger trigger)
             (pausing-possible-p NIL))
    (interact trigger T)))

(defmethod quest:title ((interaction interaction))
  (or (call-next-method)
      (language-string* (quest:name (quest:quest (quest:task interaction)))
                        (quest:name (quest:task interaction))
                        (quest:name interaction))))

(defclass stub-interaction (interaction)
  ((quest:dialogue :initform NIL :accessor quest:dialogue)
   (quest:task :initform (quest:find-named 'task-world-all (quest:find-named 'world (quest:storyline T))))
   (quest:name :initform 'stub)))

(defmethod quest:complete ((stub-interaction stub-interaction)))

(defclass assembly (dialogue:assembly)
  ())

(defmethod clone ((assembly assembly) &key)
  (let ((clone (make-instance (class-of assembly))))
    (loop for instruction across (dialogue:instructions assembly)
          do (vector-push-extend instruction (dialogue:instructions clone)))
    clone))

(defun find-task (quest task)
  (uiop:nest
   (quest:find-task task)
   (quest:find-quest quest)
   (storyline +world+)))

(flet ((thing (thing)
         (if (and (symbolp thing) (not (null thing)))
             (quest:find-named thing *current-task*)
             thing)))
  (defun activate (&rest things)
    (loop for thing in things do (quest:activate (thing thing))))

  (defun deactivate (&rest things)
    (loop for thing in things do (quest:deactivate (thing thing))))

  (defun complete (&rest things)
    (loop for thing in things do (quest:complete (thing thing))))

  (defun fail (&rest things)
    (loop for thing in things do (quest:fail (thing thing))))

  (defun complete-p (&rest things)
    (loop for thing in things always (eql :complete (quest:status (thing thing)))))
  
  (defun failed-p (&rest things)
    (loop for thing in things always (eql :failed (quest:status (thing thing)))))

  (defun var-of (thing name &optional default)
    (quest:var name (thing thing) default)))

(defun var (name &optional default)
  (quest:var name *current-task* default))

(defun (setf var) (value name)
  (setf (quest:var name *current-task*) value))

(defun global-wrap-lexenv (form)
  `(let* ((player (node 'player +world+))
          (clock (clock +world+)))
     (declare (ignorable player clock))
     (flet ((have (thing &optional (count 1) (inventory player))
              (<= count (item-count thing inventory)))
            (item-count (thing &optional (inventory player))
              (item-count thing inventory))
            (store (item &optional (count 1) (inventory player))
              (store item inventory count))
            (retrieve (item &optional (count 1) (inventory player))
              (retrieve item inventory count))
            (move-to (target unit)
              (move-to target unit)
              (when (typep unit 'ai-entity)
                (setf (ai-state unit) :move-to)))
            (unit (name &optional (container +world+))
              (node name container)))
       (declare (ignorable #'have #'item-count #'store #'retrieve #'move-to #'unit))
       ,form)))

(defun find-all-variables ()
  (let ((vars ()))
    (flet ((handle-scope (thing)
             (loop for binding in (quest:bindings thing)
                   do (pushnew (car binding) vars))))
      (dolist (storyline quest::*storylines* vars)
        (handle-scope storyline)
        (loop for quest being the hash-values of (quest:quests storyline)
              do (handle-scope quest)
                 (loop for task being the hash-values of (quest:tasks quest)
                       do (handle-scope task)))))))

(defun task-wrap-lexenv (form)
  `(let* ((task *current-task*)
          (quest (quest:quest task))
          (all-complete (loop for trigger being the hash-values of (quest:triggers task)
                              always (eql :complete (quest:status trigger)))))
     (declare (ignorable quest all-complete))
     (flet ((thing (thing)
              (if (and (symbolp thing) (not (null thing)))
                  (quest:find-named thing task)
                  thing)))
       (flet ((reset (&rest things)
                (loop for thing in things do (quest:reset (thing thing) :reset-vars NIL)))
              (active-p (&rest things)
                (loop for thing in things always (quest:active-p (thing thing)))))
         (declare (ignorable #'reset #'active-p))
         ;; KLUDGE: this sucks, lmao
         (symbol-macrolet ,(loop for var in (find-all-variables)
                                 collect `(,var (var ',var)))
           ,(global-wrap-lexenv form))))))

(defmethod quest:compile-form ((task task) form)
  (compile NIL `(lambda () ,(task-wrap-lexenv form))))

(defmethod dialogue:wrap-lexenv ((assembly assembly) form)
  `(let* ((interaction *current-interaction*)
          (*current-task* (quest:task interaction)))
     ,(task-wrap-lexenv form)))

(defun load-default-interactions (&optional (storyline (quest:storyline T)) (file (merge-pathnames "quests/default-interactions.spess" (language-dir))))
  (let ((*package* #.*package*)
        (interactions (make-hash-table :test 'eql))
        (root (dialogue:parse file))
        (section NIL))
    (flet ((start-new (name)
             (let ((root (make-instance 'components:root-component)))
               (setf (gethash name interactions) root)
               (setf section root))))
      (loop for component across (components:children root)
            do (if (typep component 'components:header)
                   (start-new (read-from-string (aref (components:children component) 0)))
                   (vector-push-extend component (components:children section))))
      (loop with defaults = (default-interactions storyline)
            for name being the hash-keys of interactions using (hash-value root)
            do (when (typep root 'components:root-component)
                 (setf (gethash name defaults) (ensure-instance (gethash name defaults) 'stub-interaction :dialogue root)))))))

(defmacro define-sequence-quest ((storyline name) &body body)
  (let ((counter 0))
    (labels ((parse-sequence-form (form name next)
               (match1 form
                 (:eval (&rest body)
                        (form-fiddle:with-body-options (body initargs) body
                          `((,name
                             ,@initargs
                             :title "-"
                             :visible NIL
                             :condition T
                             :on-activate (action)
                             :on-complete ,next
                             (:action action
                                      ,@body)))))
                 (:animate ((character animation) . body)
                           (form-fiddle:with-body-options (body initargs) body
                             `((,name
                                ,@initargs
                                :title ,(format NIL "Wait for ~@(~a~) to ~(~a~)." character animation)
                                :visible NIL
                                :condition (not (eql ',animation (name (animation (node ',character +world+)))))
                                :on-activate (action)
                                :on-complete ,next
                                (:action action
                                         (start-animation ',animation (node ',character +world+))
                                         ,@body)))))
                 (:nearby ((place character) . body)
                          (form-fiddle:with-body-options (body initargs) body
                            `((,name
                               ,@initargs
                               :title ,(format NIL "Wait for ~@(~a~) to arrive." character)
                               :condition (nearby-p ',place ',character)
                               :on-complete (action ,@next)
                               (:action action
                                        ,@body)))))
                 (:wait (for . initargs)
                        `((,name
                           ,@initargs
                           :title ,(format NIL "Wait for ~d second~:p" for)
                           :visible NIL
                           :condition (<= ,for (- clock timer))
                           :variables ((timer 0.0))
                           :on-activate (action)
                           :on-complete ,next
                           (:action action (setf timer clock)))))
                 (:have ((item &optional (count 1)) . initargs)
                        `((,name
                           ,@initargs
                           :title ,(format NIL "Collect ~d ~@(~a~:p~)" count item)
                           :condition (have ',item ,count)
                           :on-complete ,next
                           ,@(when (< 1 count)
                               `(:full-progress ,count
                                 :progress-fun '(item-count ',item))))))
                 (:go-to ((place &key lead follow with) . body)
                         (form-fiddle:with-body-options (body initargs eval) body
                           `((,name
                              ,@initargs
                              :title ,(cond (lead (format NIL "Follow ~@(~a~) to ~@(~a~)" lead place))
                                            (follow (format NIL "Lead ~@(~a~) to ~@(~a~)" follow place))
                                            (T (format NIL "Go to ~a" place)))
                              :condition (nearby-p ',place 'player)
                              :on-activate (action)
                              :on-complete ,next
                              :marker ',place
                              (:action action
                                       ,@(if with `((stop-following ',with)
                                                    (move-to ',place ',with)))
                                       ,@(if lead `((lead 'player ',place ',lead)))
                                       ,@(if follow `((follow 'player ',follow)))
                                       ,eval
                                       ,@(if body `((walk-n-talk (progn ,@body)))))))))
                 (:interact ((with &key now repeatable) . body)
                            (form-fiddle:with-body-options (body initargs) body
                              (let ((repeatable (or repeatable (popf initargs :repeatable)))
                                    (source (popf initargs :source)))
                                `((,name
                                   ,@initargs
                                   :title ,(format NIL "Listen to ~@(~a~)" with)
                                   :condition (complete-p 'interaction)
                                   :on-activate (interaction)
                                   :on-complete ,next
                                   :marker ',(if now NIL with)
                                   (:interaction interaction
                                    :interactable ,with
                                    :auto-trigger ,now
                                    :repeatable ,repeatable
                                    :source ,source
                                                 ,@body))))))
                 (:complete ((&rest things) . body)
                            (form-fiddle:with-body-options (body initargs (activate T)) body
                              `((,name
                                 ,@initargs
                                 :title ,(format NIL "Complete ~{~@(~a~)~^, ~}" things)
                                 :condition (complete-p ,@(loop for thing in things
                                                                collect (if (symbolp thing)
                                                                            `(or (unit ',thing) ',thing)
                                                                            (destructuring-bind (quest task) thing
                                                                              `(find-task ',quest ',task)))))
                                 :on-activate (action)
                                 :on-complete ,next
                                 (:action action
                                          ,@(when activate
                                              (loop for thing in things
                                                    collect `(activate (or (unit ',thing) ',thing))))
                                          ,@(if body `((walk-n-talk (progn ,@body)))))))))))
             (sequence-form-name (form)
               (apply #'trial::mksym *package* (incf counter) :- (first form) :- (enlist (unlist (second form)))))
             (parse-sequence-to-tasks (forms)
               (let ((forms (loop for form in forms
                                  collect (list (sequence-form-name form) form))))
                 (loop for (form next) on forms
                       append (parse-sequence-form (second form) (first form) (enlist (first next)))))))
      (form-fiddle:with-body-options (body initargs) body
        (let ((tasks (parse-sequence-to-tasks body)))
          `(quest:define-quest (,storyline ,name)
             ,@initargs
             :on-activate (,(caar tasks))
             ,@tasks))))))