;; The following COMMON-LISP code gives an example of the kind of system desired. 
;; It is a companion to this paper: http://hanson.gmu.edu/combobet.pdf or .ps
;; Created by Robin Hanson January 2002. Cleaned up by Darius Bacon, March 2004.

;; Here is a sample session to try, after loading this file:

;; (setf joe (new-subject 1024))   ;gives assets of 1000 to start
;; (refresh joe)                   ;show the screen
;; (assume joe 'A 1)               ;assume that P(A)=1
;; (refresh joe)                   ;show the screen
;; (trade joe 'C .6)               ;trade to set P(C|A) = .6
;; (refresh joe)                   ;show the screen
;; (assume joe 'B 0)               ;assume also that P(B)=0
;; (refresh joe)                   ;show the screen
;; (trade joe 'D .01)              ;trade to set P(D|A,notB) = .01
;; (refresh joe)                   ;show the screen  **
;; (unassume joe)                  ;go back to assuming just P(A)=1

;; Sample screen at point ** above:

;; Variable               A      B      C      D      E      F      G      H
;; Assuming                                                                 
;; Percent Chance     50.00  50.00  55.00  37.75  50.00  50.00  50.00  50.00
;; Assuming               T                                                 
;; Percent Chance            50.00  60.00  25.50  50.00  50.00  50.00  50.00
;; Assuming               T      F                                          
;; Percent Chance                   60.00   1.00  50.00  50.00  50.00  50.00
;; Max assets if                     1125    462   1125   1125   1125   1125
;; Ave assets if                     1118    439   1095   1095   1095   1095
;; Min assets if                      462    403    403    403    403    403
;; Max assets if not                 1066   1125   1125   1125   1125   1125
;; Ave assets if not                 1060   1101   1095   1095   1095   1095
;; Min assets if not                  403   1066    403    403    403    403

;;;---------------------- IMPORTED UTILITIES ----------------------------------------------

(defun WITHOUT-INTERRUPTIONS (arg) arg) ;;Would mean something with multiple processes
(define-modify-macro MINF (item) (lambda (n-place m) (min n-place m)))
(define-modify-macro MAXF (item) (lambda (n-place m) (max n-place m)))
(define-modify-macro SCALEF (n) (lambda (old n) (* old n)))
(defmacro LET-RESULT ((var value) &body code) `(let ((,var ,value)) ,@code ,var))
(defconstant +infinity most-positive-double-float)
(defconstant -infinity most-negative-double-float)

;;;---------------------- CUBES AND INDICES ----------------------------------------------
;;; one n-cube holds prob info, and others describe each agent's assets
;;; are implemented as n-dimensional arrays, so read/write via (apply #'aref cube corner)
;;; corners are *n*-length lists of 0 or 1. subcubes can also include the value 2

(defvar *var-names* '(A B C D E F G H))  ;;alt: (setf *var-names* '(A B C D E F G H I J))
(defvar *n* (length *var-names*))

(defun MAKE-CUBE (v &optional (n *n*)) "n is the number of dimensions, v is initial value"
  (make-array (loop repeat n collect 2) :initial-element v))
(defun MAKE-PROB-CUBE () (make-cube (/ (expt 2 *n*))))
(defun MAKE-ASSET-CUBE (factor) (make-cube factor))
(defun CUBE-N (cube) (array-rank cube))

(defun WILDCARD? (v) (eql v 2))
(defun CORNER? (subcube) (every (complement #'wildcard?) subcube))
(defun ROOT-SUBCUBE (&optional (n *n*)) (loop repeat n collect 2))
(defun SET-INDEX (i v subcube) "change the i component to v"
   (let-result (new (copy-list subcube)) (setf (nth i new) v)))
(defun VAR-SUBCUBE (i v) (set-index i v (root-subcube)))

;;;---------------------- ITERATION OVER CUBES --------------------------------------------
;;; if an index of subcube is 0 or 1, deal with that particular value 
;;; if an index is 2, deal with both possible values
;;; function should take args: &rest subcube

(defun MAP-CUBE (subcube function) 
  (let ((r (reverse subcube))) (map-cube-aux function r nil)))
(defun MAP-CUBE-AUX (fn ileft idone)
  (if (null ileft)
      (apply fn idone)
      (let ((i (first ileft)) (ileft (rest ileft)))
        (cond ((wildcard? i)
               (map-cube-aux fn ileft (cons 0 idone))
               (map-cube-aux fn ileft (cons 1 idone)))
              (t (map-cube-aux fn ileft (cons i idone)))))))
(defmacro DO-CUBE ((var cube subcube) &body body) "syntactic sugar for map-cube"
  `(map-cube ,subcube (lambda (&rest is)
                        (symbol-macrolet ((,var (apply #'aref ,cube is)))

(defun SET-CUBE (value cube subcube) (do-cube (x cube subcube) (setf x value)))
(defun INC-CUBE (delta cube subcube) (do-cube (x cube subcube) (incf x delta)))
(defun SCALE-CUBE (factor cube subcube) (do-cube (x cube subcube) (scalef x factor)))
(defun SUM-CUBE (cube subcube)
  (let-result (sum 0) (do-cube (x cube subcube) (incf sum x))))
(defun MIN-CUBE (cube subcube)
  (let-result (min most-positive-fixnum) (do-cube (x cube subcube) (minf min x))))
(defun MAX-CUBE (cube subcube)
  (let-result (max most-negative-fixnum) (do-cube (x cube subcube) (maxf max x))))

(defun SUM-CUBE-TIMES-LOG-CUBE (subcube cube1 cube2)
  (let-result (sum 0)
   (map-cube subcube 
     #'(lambda (&rest is) 
         (incf sum (* (apply #'aref cube1 is)
                      (log (apply #'aref cube2 is))))))))

;;;---------------------- INFORMATION TO DISPLAY --------------------------------------------

(defun PROB-VAR-GIVEN (i probs subcube) "gives P(i=1|subcube)"
   (assert (/= 0 (nth i subcube)))
   (let ((p (sum-cube probs subcube)))
      (if (< 0 p) (/ (sum-cube probs (set-index i 1 subcube)) p))))

(defvar *s* (/ (log 2) 100)) ;;; the scale of the market maker subsidy
(defun ASSET->FACTOR (x &optional (s *s*)) (rationalize (exp (* s x))))
(defun FACTOR->ASSET (f &optional (s *s*)) (/ (log f) s))
(defun AVE-ASSETS (assets probs subcube &optional (s *s*)) "gives E_p(A|subcube)"
   (let ((p (sum-cube probs subcube)))
      (if (< 0 p) (/ (sum-cube-times-log-cube subcube probs assets) p s))))
(defun MIN-ASSETS (ac subcube) (factor->asset (min-cube ac subcube)))
(defun MAX-ASSETS (ac subcube) (factor->asset (max-cube ac subcube)))

;;;---------------------- TRADING  ----------------------------------------------------------
;;; trade-var returns nil if it succeeds, otherwise it returns string describing error

(defun TRADE-VAR (p i ac probs subcube) "set P(i=1|subcube) = p, ac pays"
 (if (not (<= 0 p 1)) "New price must be within [0,1]."
  (if (not (wildcard? (nth i subcube))) "Variable already assumed."
   (without-interruptions ;; only this process should modify probs now 
    (let*   ((c1 (set-index i 1 subcube)) (c0 (set-index i 0 subcube))
             (p1 (sum-cube probs c1))     (p0 (sum-cube probs c0))) ;;old probs
     (if (or (= 0 p1) (= 0 p0)) "Variable value has already been determined."
      (let* ((pp1 (* p (+ p1 p0)))        (pp0 (+ p0 (- p1 pp1)))   ;;new probs
             (f1 (/ pp1 p1))              (f0 (/ pp0 p0)))          ;;factors
       (if (if (< f1 1) (> (/ f1) (min-cube ac c1)) (> (/ f0) (min-cube ac c0)))
        "Not enough assets to pay for trade."
        (progn (scale-cube f1 probs c1) (scale-cube f0 probs c0)
               ;; could allow access to probs at this point
               (scale-cube f1 ac c1) (scale-cube f0 ac c0) nil)))))))))

(defun DECIDE-VAR-VALUE (i v probs) "use to declare that know value for sure"
   (let ((ip (/ (sum-cube probs (var-subcube i v)))))
      (scale-cube ip probs (var-subcube i v))
      (set-cube 0 probs (var-subcube i (- 1 v)))))

(defun PAY-SUBJECT (ac corner &optional (s *s*)) "randomly round off assets to nearest unit"
   (if (not (corner? corner)) "Not all variables are resolved." 
      (multiple-value-bind (x p) (floor (log (apply #'aref ac corner)) s)
        (+ x (if (> p (random 1.0)) 1 0)))))

;;;---------------------- SIMPLE INTERFACE -------------------------------------------------

(defun 01->TF (x) (case x (0 "F") (1 "T") (2 " ")))
(defmacro SHOW-LINE (stream subcube intro format blank (var n) &body code)
  `(progn (terpri) (format ,stream ,intro) 
          (dotimes (,var ,n) (if (wildcard? (nth ,var ,subcube))
                               (format ,stream ,format ,@code)
                               (format ,stream ,blank)))))

(defun SHOW-SCREEN (names probs ac history &optional (stream t) &aux (n (cube-n ac)))
   (terpri) (show-line t (root-subcube) "Variable         " "  ~5@A" ""  (i n) (nth i names))
   (dolist (sc (reverse history))
     (show-line t (root-subcube) "Assuming         " " ~6@A" " ~6@A" (i n) (01->tf (nth i sc)))
     (show-line t sc "Percent Chance   " " ~6,2,2F" "       " (i n) (prob-var-given i probs sc)))
   (let ((sc (first history)))
     (show-line t sc "Max assets if    " " ~6D" "       " (i n) 
        (round (max-assets ac (set-index i 1 sc))))
     (show-line t sc "Ave assets if    " " ~6D" "       " (i n) 
        (round (ave-assets ac probs (set-index i 1 sc))))
     (show-line t sc "Min assets if    " " ~6D" "       " (i n) 
        (round (min-assets ac (set-index i 1 sc))))
     (show-line t sc "Max assets if not" " ~6D" "       " (i n) 
        (round (max-assets ac (set-index i 0 sc))))
     (show-line t sc "Ave assets if not" " ~6D" "       " (i n) 
        (round (ave-assets ac probs (set-index i 0 sc))))
     (show-line t sc "Min assets if not" " ~6D" "       " (i n) 
        (round (min-assets ac (set-index i 0 sc))))))
   ;;Calculating the ave should be the most expensive item here; drop it when sys too slow

(defvar *probs* (make-prob-cube))

(defstruct SUBJECT assets history)
(defun NEW-SUBJECT (factor) 
  (make-subject :assets (make-asset-cube factor)
                :history (list (root-subcube))))

(defun REFRESH (subject &aux var)
  (show-screen *var-names* *probs* (subject-assets subject) (subject-history subject)))
(defun ASSUME (subject name v) 
  (if (not (or (eql v 0) (eql v 1))) "An assumed value must be either 0 or 1."
   (push (set-index (position name *var-names*) v (car (subject-history subject)))
         (subject-history subject))))
(defun UNASSUME (subject) (pop (subject-history subject)))
(defun TRADE (subject name p) 
  (trade-var (rationalize p) (position name *var-names*)
    (subject-assets subject) *probs* (first (subject-history subject))))

;;;---------------------- THATS ALL FOLKS -------------------------------------------------