;;;;  MLS   Multi-Level Simulation package
;;;;
;;;;    based on and with acknowledgement to MIMOSE
;;;;
;;;;    Nigel Gilbert September 5, 1996
;;;;

(provide "mls")


;; define the root object for mls entities

(defproto mls-proto '(id upper lowers logs histories))

(defmacro defobject (name &optional logged-attributes other-attributes )
  (let ((obj (gensym)))
    `(let (obj) 
       (defproto ,name 
         (append (quote ,logged-attributes) (quote ,other-attributes))
         '(count) mls-proto)
       (setq obj (eval ,name))
       (send obj :slot-value 'logs (quote ,logged-attributes))
       (send obj :slot-value 'count 0)
      obj)))

(defmeth mls-proto :new (&rest args)
  (let ((object (apply #'call-next-method  args)))
    (incf (slot-value 'count))
    object))

(defmeth mls-proto :isnew (upper &rest args)
  (setf (slot-value 'upper) upper)
  (setf (slot-value 'histories) (gensym))
  (setf (slot-value 'id) (slot-value 'count))
  (apply #'send self :initialise args)
  (send self :update-histories))

(defmacro create (obj &rest args)
  `(send ,obj :new nil ,@args))

(defmeth mls-proto :print (&optional (stream t))
  (if (slot-value 'id)
      (format stream "#<~A-~D>" (slot-value 'proto-name) (slot-value 'id))
      (format stream "#<~A>" (slot-value 'proto-name))))

(defmeth mls-proto :initialise ()
"This must be specialised by all objects which need to do anything 
at the time of creation"  
  nil)

(defmeth mls-proto :step ()
"Advance the simulation by one step"
  (let ((lowers (slot-value 'lowers)))
    (when lowers
          (dolist (low-obj lowers)
                  (send low-obj :step)))
    (send self :act)
    (send self :update-histories)))

(defmeth mls-proto :act ()
"This must be specialised by all objects which need to do anything on each step"
  nil)

(defmeth mls-proto :update-histories ()
  (dolist (a (slot-value 'logs))
          (push (slot-value a) (get (slot-value 'histories) a))))

(defmeth mls-proto :from-lowers (attribute)
  (mapcar #'(lambda (low-obj) (send low-obj :slot-value attribute))
          (slot-value 'lowers)))

(defmeth mls-proto :create-lowers (obj number &rest args)
  (dotimes (n number)
           (push (apply #' send obj :new self args)
                 (slot-value 'lowers))))

(defmacro create-lowers (obj number &rest args)
  `(send self :create-lowers ,obj ,number ,@args))

(defmeth mls-proto :lowers ()
  (slot-value 'lowers))

(defmeth mls-proto :num-lowers ()
  (length (slot-value 'lowers)))


;;;  trace package

(defvar *mls-trace* nil "The attributes for which changes in value will be traced")

(defmacro mls-trace (&rest attributes)
"Args: (&rest attributes)
Sets tracing on for the ATTRIBUTES named as arguments"
  (let ((val (gensym)))
    `(let ((,val (quote ,attributes)))
       (when ,val 
             (setq *mls-trace* (append *mls-trace* ,val)))
       *mls-trace*)))

(defmacro mls-untrace (&rest attributes)
"Args: (&rest attributes)
Sets tracing off for the ATTRIBUTES named as arguments, or for all if NIL"
  (let ((val (gensym)))
    `(let ((,val (quote ,attributes)))
       (setq *mls-trace*
             (when ,val
                   (set-difference *mls-trace* ,val))))))

       
;;; Access macros and functions


(defmacro attribute (attribute)
  `(slot-value (quote ,attribute)))

(defmacro its-attribute (obj attribute)
  `(send ,object :slot-value (quote ,attribute)))

(defmacro set-attribute (attribute value)
  (let ((val (gensym)))
    `(let ((,val (slot-value (quote ,attribute) ,value)))
       (when (and *mls-trace* (or (eql *mls-trace* t) 
                                  (member (quote ,attribute) *mls-trace*)))
             (format t "Attribute ~A of ~A set to ~A~%" 
                     (quote ,attribute) self ,val))
       ,val)))

(defmacro upper-attribute (attribute)
  `(send (slot-value 'upper) :slot-value (quote ,attribute)))

(defmacro prev-attribute (attribute &optional past)
  `(its-prev-attribute self (quote ,attribute) ,past))

(defmacro prev-upper-attribute (attribute &optional past)
  `(its-prev-attribute (slot-value 'upper) (quote ,attribute) ,past))

(defun its-prev-attribute (obj attribute &optional past)
  (let ((hist (get (send obj :slot-value 'histories) attribute)))
    (if past
        (nth past hist)
        (car hist))))

(defun its-history (obj attribute)
  (cdr (reverse (get (send obj :slot-value 'histories) attribute))))

;; make 'cond' macros look a bit more intelligible
(defconstant otherwise t)

;;;
;;;  Some stochastic utilities
;;;

(defun uniform  (lobound hibound  &optional (precision 1000))
"Args: (lobound hibound  &optional (precision 1000))
Return a random number between LOBOUND and HIBOUND drawn from 
a uniform distribution of numbers with a granularity of 1/PRECISION"

  (+ lobound (/ (* (- hibound lobound) (random precision)) precision)))

(defun chance (odds)
"Args: (odds)
Returns true with a probability of 1 in ODDS (an integer >= 1), otherwise NIL"

  (zerop (random odds)))

(defun normal (mean st-dev &optional (number 1))
"Args: (mean standard-deviation &optional (number 1))
Returns NUMBER values sampled from a normal distribution with mean MEAN and
standard deviation STANDARD-DEVIATION"

  (values-list (+ mean (* st-dev (normal-rand number)))))

(defmacro randomly-choose (&rest options)
"Args: (&rest options)
Selects one of the options at random and returns it"
`(case (random ,(length options))
   ,@(let ((key -1))
       (mapcar #'(lambda (option)
                   `(,(incf key) ,option))
               options))))

(defun prob (probability &optional (precision 1000))
"Args: (probability &optional (precision 1000))
Returns true PROBABILITY (a float <= 1) proportion of the time, else NIL"
  (<= (random precision) (* probability precision)))