;;; -*- Mode: Lisp; Syntax: Common-Lisp; -*- Author: Roman Belavkin

;;;  Name: OPTIMIST Conflict Resolution for ACT-R 5
;;;  Author:  Roman Belavkin
;;;  Contact: R.Belavkin@mdx.ac.uk
;;;  Version: 2.01
;;;  Date: 17/06/2005
;;;  Date started: 13/4/2003
;;;  Description: An alternative conflict resolution algorithm
;;;  for ACT-R.  Instead of utilities U = PG-C, it uses estimates
;;;  of expected costs with the help of Poisson distributions.
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;  This code was written at Middlesex University          ;;;
;;;  and has been placed in the public domain.              ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; Global variables

(defvar *optimist* t
  "If T, then use OPTIMIST conflict resolution")

(defvar *minimal-cost* *default-action-time*)

(defvar *reward* nil
  "If a number, then substract it from the efforts on success")

(defvar *penalty* nil
  "If a number, then add it to the efforts on failure")

;;; Service functions

(defun unwrap (list)
  (and list (if (not (listp list)) list (unwrap (car list)))))

(defun add-hook (old-hook new-hook)
  "Adds a function to an existing hook"
  (if (null old-hook) new-hook
    (lambda (&optional x)
      (if (null x)
          (progn (funcall old-hook) (funcall new-hook))
        (progn (funcall old-hook x) (funcall new-hook x))))))

;;; Main functions

(defun production-all-efforts (p)
  "Returns all efforts spent on the production"
  (unwrap (production-efforts p)))

(defun production-all-successes (p)
  (unwrap (production-successes p)))

(defun production-pof-success (p)
  (let ((ss (unwrap (production-successes p)))
        (fs (unwrap (production-failures p))))
    (/ ss (+ ss fs))))

(defun production-estimated-cost (p)
  "Returns the estimated expected cost of the production"
  (compute-costs
   (production-successes p)
   (list 0.0)
   (list (production-all-efforts p))))

(defun poisson-random-cost (mean)
  "Retunrs a sample (random cost of the first success) from the
   Poisson distribution for the latest estimate of the Poisson rate."
  (let ((c (if (> mean 0) mean *minimal-cost*))
        (p (max 0.0001 (min (random 1.0) 0.9999))))
    (* (- c) (log (- 1 p)))))

(defun optimist-utility (p)
  "Returns the expected utility similar to ACT-R, but with Gamma
   distributed noise with converging variance."
  (let* ((c (production-estimated-cost p))
         (p (production-pof-success p))
         (r (poisson-random-cost c))
         (pg-c (- (* p *g*) r)))
    (and (numberp *exp-gain-noise*) (incf pg-c (noise *exp-gain-noise*)))
    pg-c))

(defun optimist-cr (&optional conflict-set)
  "OPTIMIST conflict resolution"
  (and *optimist* conflict-set
       (let* ((is conflict-set)
              (ps (mapcar #'(lambda (x) (instantiation-production x)) is))
              (pg-cs (mapcar #'optimist-utility ps)))
         (loop for i  in is
               and pg-c in pg-cs do (setf (instantiation-gain i) pg-c))
         (setf is (sort is #'(lambda (x y) (> (instantiation-gain x)
                                              (instantiation-gain y)))))
         is)))

(defun reinforce-start (&optional instantiation)
  "Adds reward-penalty to *time* before learning"
  (and *optimist* instantiation
       (or (and (numberp *reward*)
                (production-success (instantiation-production instantiation))
                (decf *time* *reward*))
           (and (numberp *penalty*)
                (production-failure (instantiation-production instantiation))
                (incf *time* *penalty*)))))

(defun reinforce-end (&optional instantiation)
  "Removes reward-penalty from *time* after learning"
  (and *optimist* instantiation
       (or (and (numberp *reward*)
                (production-success (instantiation-production instantiation))
                (incf *time* *reward*))
           (and (numberp *penalty*)
                (production-failure (instantiation-production instantiation))
                (decf *time* *penalty*)))))

(defun optimist-hooks ()
  "Adds optimist hook functions"
  (setf *conflict-set-hook-fn* (add-hook *conflict-set-hook-fn* 'optimist-cr))
  (setf *firing-hook-fn* (add-hook *firing-hook-fn* 'reinforce-start))
  (setf *cycle-hook-fn*  (add-hook *cycle-hook-fn* 'reinforce-end)))

(setf *init-hook-fn* (add-hook *init-hook-fn* 'optimist-hooks))