iterated bargaining game, deterministic machines

ibar.rkt

CREATE NEW VERSION ON GITHUB. DONT CHANGE THIS VERSION!!! JUST DONT!!!

;(require racket) ; for emacs to call REPL
(require racket/gui/base) ; to have TV
(require plot/no-gui) ; to have plot/dc
(require math/base) ; to have sum
;(require math) ; to have mean
;(require 2htdp/batch-io) ; to import csv
(require "csv.rkt") ; to export csv
(plot-new-window? #t)

(define N 1000) ; population

;; 0 = low
;; 1 = medium
;; 2 = high
(define-struct automaton (init-claim hh hm hl mh mm ml lh lm ll))
(define accommodator (make-automaton 1 0 1 2 0 1 2 0 1 2))
(define all-highs (make-automaton 2 2 2 2 2 2 2 2 2 2))
(define all-mediums (make-automaton 1 1 1 1 1 1 1 1 1 1))
(define all-lows (make-automaton 0 0 0 0 0 0 0 0 0 0))

(define (identify automaton)
  (map (lambda (f) (f automaton))
       (list
        automaton-init-claim
        automaton-hh
        automaton-hm
        automaton-hl
        automaton-mh
        automaton-mm
        automaton-ml
        automaton-lh
        automaton-lm
        automaton-ll)))

(define (all-highs? automaton)
  (equal? automaton all-highs))
(define (all-mediums? automaton)
  (equal? automaton all-mediums))
(define (all-lows? automaton)
  (equal? automaton all-lows))
(define (accommodator? automaton)
  (equal? automaton accommodator))
(define (identify-2-types population)
  (list
   (count all-highs? population)
   (count all-mediums? population)
    ))

;; previous-claim is a list of two claims
;; - the agent's own claim
;; - the opponent's claim
(define (next-claim automaton previous-claims)
  (let ([look-up
         (cond
          [(equal? previous-claims '(2 2)) automaton-hh]
          [(equal? previous-claims '(2 1)) automaton-hm]
          [(equal? previous-claims '(2 0)) automaton-hl]
          [(equal? previous-claims '(1 2)) automaton-mh]
          [(equal? previous-claims '(1 1)) automaton-mm]
          [(equal? previous-claims '(1 0)) automaton-ml]
          [(equal? previous-claims '(0 2)) automaton-lh]
          [(equal? previous-claims '(0 1)) automaton-lm]
          [(equal? previous-claims '(0 0)) automaton-ll])])
    (look-up automaton)))

;; each outcome (-1,0,1,2) is equivalent to payoff (0,2,5,8)
(define (payoff outcome)
  (cond [(zero? outcome) 2]
        [(= outcome 1) 5]
        [(= outcome 2) 8]
       ;[(= outcome -1) 0]
        ))

;; input: claims (l,m,h) ~ (0,1,2)
;; output: payoff (0,2,5,8)
(define (match-claims claims)
  (if (<= (sum claims) 2)
      (map payoff claims)
      (list 0 0)))

(define (match-pair* au1 au2 results previous-claims countdown)
  (if (zero? countdown)
      results
      (match-pair* au1 au2
                   (append results (list
                                    (match-claims previous-claims)))
                   (list (next-claim au1 previous-claims)
                         (next-claim au2 (reverse previous-claims)))
                   (sub1 countdown))))

;; match a pair of automaton for n rounds
;; return a list of round results
(define (match-pair automaton-pair rounds-per-match)
  (match-pair* (first automaton-pair)
               (second automaton-pair)
               '()
               (map automaton-init-claim automaton-pair)
               rounds-per-match))

;; mass production
(define (base10->base3 n)
  (~r n #:base 3 #:min-width 10 #:pad-string "0"))

(define (char->digit c)
  (case c
    ;; (map (lambda (i) (format "[(#\\~a) ~a]" i i))
    ;;      (range 0 10))
    [(#\0) 0]
    [(#\1) 1]
    [(#\2) 2]
    [(#\3) 3]
    [(#\4) 4]
    [(#\5) 5]
    [(#\6) 6]
    [(#\7) 7]
    [(#\8) 8]
    [(#\9) 9]))

(define (base3->digits a-string)
  (map char->digit (string->list a-string)))

(define (number->automaton n)
  (apply make-automaton (base3->digits (base10->base3 n))))

(define la (number->automaton 38722))
(define sa0 (number->automaton 51894))
(define sa1 (number->automaton 51895))
(define sa2 (number->automaton 51896))
(define sa3 (number->automaton 51897))
(define sa4 (number->automaton 51898))
(define sa5 (number->automaton 51899))
(define sa6 (number->automaton 51900))
(define sa7 (number->automaton 51901))
(define sa8 (number->automaton 51920))

(define contestant-list-1
  (list
   all-highs all-mediums all-lows
   accommodator la sa0 sa3 sa5 sa8))

(define w1 (number->automaton 47761))
(define w2 (number->automaton 28321))
(define w3 (number->automaton 37554))
(define w4 (number->automaton 48987))

(define contestant-list-2
  (list w1 w2 w3 w4))

(define (contest automaton contestant-list)
  (map (lambda (x) (match-pair (list automaton x) 10))
       contestant-list))

(define (mass-produce p1 p2)   ; machine p1 to machine p2
  (for/list ([n (in-range p1 (add1 p2))])
    (number->automaton n)))

;; matching
(define series (list (list 0 0)))

(define (create-test-population high medium low accom)
  (set! series (list (list high medium)))
  (set! N (sum (list high medium low accom)))
  (shuffle
   (append
    (make-list high all-highs)
    (make-list medium all-mediums)
    (make-list low all-lows)
    (make-list accom accommodator))))

;; in each match, take mean of round results for each automaton
;; returns a pair of means
(define (take-sums round-results)
  (map (lambda (f) (sum  (map f round-results)))
       (list first second)))

(define (take-discounts delta round-results)
  (map (lambda (f)
         (sum
          (for/list ([i (length round-results)])
            (* (list-ref (map f round-results) i)
               (expt delta i)))))
         (list first second)))

(define (match-population population rounds-per-match)
  (for/list ([i (/ (length population)
                   2)])
    (take-sums
     (match-pair (list
                  (list-ref population (* 2 i))
                  (list-ref population (add1 (* 2 i))))
                 rounds-per-match))))

;; hmm payoff 0 may not need to be add1

(define (reductions-h f accumulated init a-list)
  (if (null? a-list)
      accumulated
      (let ((next-init (f init (first a-list))))
        (reductions-h f
                      (append accumulated (list next-init))
                      next-init
                      (rest a-list)))))
(define (reductions f init a-list)
  (if (null? a-list)
      accumulated
      (reductions-h f '() init a-list)))
(define (reductions* f a-list)
  (let ([init (first a-list)])
    (reductions-h f (list init) init (rest a-list))))

(define (accumulate a-list)
  (reductions* + (cons 0 a-list)))

(define (payoff-percentages payoff-list)
  (let ([s (sum payoff-list)])
    (for/list ([i N])
      (/ (list-ref payoff-list i)
         s))))

(define (accumulated-fitness population rounds-per-match)
  (accumulate
   (payoff-percentages
    (flatten
     (match-population population rounds-per-match)))))

(define (randomise-over-fitness accumulated-payoff-percentage population speed)
  (for/list
      ([n speed])
    (let ([r (random)])
      (for/and ([i N])
        #:break (< r (list-ref accumulated-payoff-percentage i))
        (list-ref population i)))))

(define (randomisation-test an-accumulated-list)
  (for/list
      ([n 20])
    (let ([r (random)])
      (for/and ([i N])
        #:break (< r (list-ref an-accumulated-list i))
        i))))

#|
;; shuffle
(define (shuffle* a-vector)
  (do
      ([n (vector-length a-vector) (- n 1)])
      ((zero? n) a-vector)
    (let* ([r (random n)]
	   [t (vector-ref a-vector r)])
      (vector-set! a-vector r (vector-ref a-vector (- n 1)))
      (vector-set! a-vector (- n 1) t))))

(define (shuffle-population population)
  (vector->list (shuffle* (list->vector population))))
|#

;; create population
(define (random-population* n-automata-per-type types)
  (shuffle
   (flatten
    (for/list ([i types])
      (make-list n-automata-per-type i)))))

(define (random-population n-automata-per-type n-types)
  (set! N (* n-automata-per-type n-types))
  (random-population*
   n-automata-per-type
   (for/list ([i n-types])
     (number->automaton (random 59049)))
   ))

;; COUNT TYPES

(define (automaton->number automaton)
  (string->number
   (apply string-append (map number->string automaton))
   3))

(define (scan population)
  (foldl
   (lambda (au h)
     (hash-update h au add1 0))
   (hash)
   population))
(define (scan-identify population)
  (foldl
   (lambda (au h)
     (hash-update h (identify au) add1 0))
   (hash)
   population))
(define (rank a-hash)
  (sort (hash->list a-hash) #:key cdr >))

(define (n->xn n)
  (string->symbol
   (string-append "x" (number->string n))))

(define (top t a-hash)
  (let* ([top-list (map car (take (rank a-hash) t))]
         [l (length top-list)])
    (for/list ([i l])
      (eval
       (list 'define (n->xn i)
             (list-ref top-list i))))))

(define (top-identify t a-hash)
  (let* ([top-list (map car (take (rank a-hash) t))]
         [l (length top-list)])
    (for/list ([i l])
      (eval
       (list 'define (n->xn i)
             (apply make-automaton (list-ref top-list i)))))))
(define population-mean (list 0))
(define payoff-space (list 0))

(define (payoff-range population rounds-per-match)
  (let*
   ([payoff-list (map
                  (lambda (x) (/ x rounds-per-match))
                  (flatten (match-population population rounds-per-match)))]
    [low (count (lambda (x) (<= x 3.5)) payoff-list)]
    [high (count (lambda (x) (> x 6.5)) payoff-list)])
   (list low (- 1000 low high) high)))
(define (rank-payoff criterion population rounds-per-match)
  (let ([payoff-list (flatten (match-population population rounds-per-match))])
    (sort (hash->list (scan payoff-list)) #:key criterion >)))

(define (evolve population cycles speed mutants rounds-per-match)
  (let* ([l (length population)]
         [round-results (match-population population rounds-per-match)]
         [accum-fitness (accumulate (payoff-percentages (flatten round-results)))]
         [survivors (drop population (+ speed mutants))]
         [successors
          (randomise-over-fitness accum-fitness population speed)]
         [mutation
          (random-population 1 mutants)]
         [new-population (shuffle (append survivors successors mutation))]
         )
    ;(set! series (append series (list (identify-2-types new-population))))
    (set! population-mean
          (append population-mean (list
                                   (exact->inexact
                                    (/ (sum (flatten round-results))
                                       (* l rounds-per-match))))))
    (if (zero? cycles)
        (begin
          (set! payoff-space round-results)
          population)
        (evolve new-population (sub1 cycles) speed mutants rounds-per-match)
        )))

;; TV
(define dynamic-frame (new frame%
                           [label "replicator dynamic"]
                           [width 400]
                           [height 400]))
(define dynamic-canvas (new canvas%
                            [parent dynamic-frame]))
(define dynamic-dc (send dynamic-canvas get-dc))
(define (plot-dynamic data)
  (plot/dc (lines data
                  #:x-min 0 #:x-max N
                  #:y-min 0 #:y-max N)
           dynamic-dc
           0 0 400 400))

(define (plot-mean data)
  (let* ([l (length data)]
         [coors (map list
                     (build-list l values)
                     data)])
    (plot/dc (lines coors
                    #:x-min 0 #:x-max l
                    #:y-min 0 #:y-max 11)
             dynamic-dc
             0 0 400 400)))

(define (plot-payoff-space pay-list)
  (plot/dc (points pay-list
                   #:x-min 0 #:x-max 420
                   #:y-min 0 #:y-max 420)
           dynamic-dc
           0 0
           400 400))





;; data:
;; '((1 2..)
;;   (2 3..))

(define (report a-population-list)
  (for/list ([i (length a-population-list)])
    (rank (scan-identify (list-ref a-population-list i)))))





;; if needed, map list data..
(define (out-data filename data)
  (define out (open-output-file filename #:mode 'text #:exists 'append))
  (write-table data out)
  (close-output-port out))


;; TRIAL RUN
; (load "ibar2.rkt")
; (define A (random-population 10 100))
; (define A1 (evolve A 200 50 100))
; (rank (scan A1))
; (winners (scan A1))
; (send dynamic-frame show #t)
; (plot-mean population-mean)