bad-news.rkt

#lang racket/base

;; Minimized version of `good-news.rkt`
;; Runs on (slowly) on 6.3, crashes on 6.3.0.11
;;
;; Error message:
;; vector-ref: chaperone produced a result that is not a chaperone of the original result
;;  chaperone result: (object:automata% ...)
;;  original result: (object:automata% ...)
;;  context...:
;;   /Users/ben/code/racket/fork/racket/share/pkgs/typed-racket-lib/typed-racket/base-env/prims.rkt:834:9: for-loop
;;   /Users/ben/code/racket/fork/racket/share/pkgs/typed-racket-lib/typed-racket/base-env/class-prims.rkt:53:23: payoffs method in population%
;;   /Users/ben/code/racket/fork/racket/share/pkgs/typed-racket-lib/typed-racket/base-env/class-prims.rkt:53:23: regenerate method in population%
;;   /Users/ben/code/racket/gtp/fsmoo-crash.rkt:136:4: for-loop
;;   /Users/ben/code/racket/gtp/fsmoo-crash.rkt:135:2: main
;;   /Users/ben/code/racket/gtp/fsmoo-crash.rkt:145:2
;;   /Users/ben/code/racket/fork/racket/share/pkgs/sandbox-lib/racket/sandbox.rkt:379:0: call-with-limits
;;   /Users/ben/code/racket/gtp/fsmoo-crash.rkt: [running body]

(module automata racket/base
  (provide
   choose-randomly
   build-automata)

  (require racket/class racket/match)

  (define (choose-randomly vals num-to-choose)
    (define %s (accumulated-% vals))
    (define L (vector-length vals))
    (for/list ([n (in-range num-to-choose)])
      (define r (random))
      (for/last ([i (in-range L)]
                 #:final (< r (vector-ref %s i)))
        i)))

  (define (accumulated-% vals)
    (define total (for/sum ([v (in-vector vals)]) v))
    (build-vector (vector-length vals)
                  (lambda (i)
                    (if (zero? i)
                        (/ (vector-ref vals 0) total)
                        (+ (vector-ref vals (- i 1))
                           (/ (vector-ref vals i) total))))))

  (define (build-automata)
    (new automata% [current 0] [payoff 0] [table '#(#(0 0) #(0 0))]))

  (define PAYOFF-TABLE
    '#(#((3 . 3) (0 . 4))
       #((4 . 0) (1 . 1))))

  (define automata%
    (class object%
      (super-new)
      (init-field
       current
       payoff
       table
       [initial current])

      (define/public (interact other num-turns)
        (for ([_i (in-range num-turns)])
          (define input (get-field current other))
          (match-define (cons p1 p2) (vector-ref (vector-ref PAYOFF-TABLE current) input))
          (set-field! current this (vector-ref (vector-ref table current) input))
          (set-field! payoff this (+ (get-field payoff this) p1))
          (set-field! current other (vector-ref (vector-ref (get-field table other) input) current))
          (set-field! payoff other (+ (get-field payoff other) p2))
          (void))
        (values this other))

      (define/public (clone)
        (new automata% (current initial) (payoff 0) (table table)))

      (define/public (pay)
        payoff)
      ))
  )

(module population typed/racket/base
  (provide build-population)

  (require typed/racket/class)

  (define-type Automata%
    (Class
     (init-field [current Natural] [payoff Natural] [table (Vector (Vector Natural Natural) (Vector Natural Natural))])
     (clone (-> (Instance Automata%)))
     (interact (-> (Instance Automata%) Natural (Values (Instance Automata%) (Instance Automata%))))
     (pay (-> Natural))))

  (define-type Population%
    (Class
     (init-field [a* (Vectorof (Instance Automata%))]
                 [b* (Vectorof (Instance Automata%))])
     (match-up* (-> Natural (Instance Population%)))
     (payoffs (-> (Vectorof Natural)))
     (regenerate (-> Natural (Instance Population%)))))

  (require/typed (submod ".." automata)
    (choose-randomly (-> (Vectorof Natural) Natural (Listof Natural)))
    (build-automata (-> (Instance Automata%))))

  (: build-population (-> Natural (Instance Population%)))
  (define (build-population n)
    (define v (build-vector n (lambda (_) (build-automata))))
    (new population% [a* v] [b* v]))

  (: population% Population%)
  (define population%
    (class object%
      (super-new)
      (init-field a* b*)

      (define/public (match-up* num-rounds)
        (for ([i (in-range 0 (- (vector-length a*) 2) 2)])
          (let* ([a1 (vector-ref a* i)]
                 [a2 (vector-ref a* (+ i 1))])
            (define-values (a1+ a2+) (send a1 interact a2 num-rounds))
            (vector-set! a* i a1+)
            (vector-set! a* (+ i 1) a2+)
            (void)))
        this)

      (define/public (payoffs)
        (for/vector : (Vectorof Natural)
                    ([a (in-vector (get-field a* this))])
          (send a pay)))

      (define/public (regenerate rate)
        (define pay* (payoffs))
        (define sub* (choose-randomly pay* rate))
        (for ([i : Natural (in-range rate)] [p (in-list sub*)])
          (vector-set! a* i (send (vector-ref b* p) clone)))
        this)
      ))
  )

(module evolve racket/base
  (provide main)

  (require (submod ".." population)
           racket/class)

  (define (main N)
    (for/fold ([p (build-population 100)])
              ([_i (in-range N)])
      (let* ([p (send p match-up* 20)]
             [p (send p regenerate 10)])
        p))
    (void)))

(require 'evolve racket/sandbox)
(call-with-limits 1 1
  (lambda () (time (main 20)) (void)))

good-news.rkt

#lang racket/base

;; Original FSM program
;; Runs very slowly on 6.3, but quickly on 6.3.0.11 (after efcbd1211?)

(module automata racket

;; An N-states, N-inputs Automaton

;; type  Automaton = 
;;   Class
;;      [match-pair (-> Automata N (values Automata Automata))
;;      the sum of pay-offs for the two respective automata over all rounds
;; 
;;     [interact (-> Automaton (values Automaton Automaton))]
;;      give each automaton the reaction of the other in the current state
;;      determine payoff for each and transition the automaton
;; 
;;     [pay (-> Payoff)]
;;
;;     [reset (-> Automaton)]
;;     wipe out the historic payoff
;;
;;     [clone (-> Automaton)]
;;     create new automaton from given one (same original state)
;;
;;     [equal (-> Automaton)]

(provide
 ;; type Automaton
 ;; type Payoff = N 
 
 ;; Payoff -> Automaton 
 defects
 cooperates
 tit-for-tat
 grim-trigger
 
 ;; N -> Automaton
 ;; (make-random-automaton n k) builds an n states x k inputs automaton
 ;; with a random transition table 
 make-random-automaton)

;; =============================================================================
;; -----------------------------------------------------------------------------
;; Table      = [Vectorof n Transition])
;; Transition = [Vectorof n State]
;;            ~ [Vectorof [Input --> State]]
;;            ~ [State -> [Input --> State]]
;; State      = [0,n)
;; Input      = [0,n)
;; Payoff     = N

(define (make-random-automaton n)
  (new automaton%
       [current (random n)]
       [payoff 0]
       [table
        (build-vector n (lambda _ (build-vector n (lambda _ (random n)))))]))

;; Automaton = (instance automaton% State Payoff Table)
(define automaton%
  (let ()
    ;; static [measure overhead]
    ;; PayoffTable = [Vectorof [Vectorof (cons Payoff Payoff)]]
    ;;             ~ [Input -> [Input -> (cons Payoff Payoff)]]
    (define PAYOFF-TABLE
      (vector (vector (cons 3 3) (cons 0 4))
              (vector (cons 4 0) (cons 1 1))))
    
    (class object%
      (init-field
       current ;; State 
       payoff  ;; Payoff 
       table   ;; [Vectorof [Vectorof State]] 
       (original current))
      (super-new)
      
      (define/public (match-pair other r)
        (define c1 (box (get-field current this)))
        (define y1 (box (get-field payoff this)))
        (define t1 (get-field table this))
        (define c2 (box (get-field current other)))
        (define y2 (box (get-field payoff other)))
        (define t2 (get-field table this))
        (for ([_i (in-range r)])
          (define input (unbox c2))
          (match-define (cons p1 p2)
            (vector-ref (vector-ref PAYOFF-TABLE (unbox c1)) input))
          ;; (jump input p1)
          (set-box! c1 (vector-ref (vector-ref t1 (unbox c1)) input))
          (set-box! y1 (+ (unbox y1) p1))
          ;; (send other jump current p2)
          (set-box! c2 (vector-ref (vector-ref t2 (unbox c2)) (unbox c1)))
          (set-box! y2 (+ (unbox y2) p2))
          (void))
        (set-field! current this (unbox c1))
        (set-field! payoff  this (unbox y1))
        (set-field! current other (unbox c2))
        (set-field! payoff  other (unbox y2))
        (values this other))
      
      ;; State Payoff -> Void
      (define/public (jump input delta) ;; <--- should be friendly
        (set! current (vector-ref (vector-ref table current) input))
        (set! payoff (+ payoff delta)))
      
      (define/public (pay)
        payoff)
      
      (define/public (reset)
        (new automaton% [current original][payoff 0][table table]))
      
      (define/public (clone)
        (new automaton% [current original][payoff 0][table table]))
      
      ;; State -> [Cons Payoff Payoff]
      (define/private (compute-payoffs other-current)
        (vector-ref (vector-ref PAYOFF-TABLE current) other-current))
      
      (define/public (equal other)
        (and (= current (get-field current other))
             (= original (get-field original other))
             (= payoff (get-field payoff other))
             (equal? table (get-field table other))))
      
      (define/public (guts)
        (list current original payoff table)))))


(define COOPERATE 0)
(define DEFECT    1)

(define (defects p0)
  (new automaton%
       [current DEFECT]
       [payoff p0]
       [table
        (transitions
         #:i-cooperate/it-cooperates DEFECT 
         #:i-cooperate/it-defects    DEFECT
         #:i-defect/it-cooperates    DEFECT
         #:i-defect/it-defects       DEFECT)]))

(define (cooperates p0)
  (new automaton%
       [current COOPERATE]
       [payoff p0]
       [table
        (transitions
         #:i-cooperate/it-cooperates COOPERATE 
         #:i-cooperate/it-defects    COOPERATE
         #:i-defect/it-cooperates    COOPERATE
         #:i-defect/it-defects       COOPERATE)]))

(define (tit-for-tat p0)
  (new automaton%
       [current COOPERATE]
       [payoff p0]
       [table
        (transitions
         #:i-cooperate/it-cooperates COOPERATE 
         #:i-cooperate/it-defects    DEFECT
         #:i-defect/it-cooperates    COOPERATE
         #:i-defect/it-defects       DEFECT)]))

(define (grim-trigger p0)
  (new automaton%
       [current COOPERATE]
       [payoff p0]
       [table
        (transitions
         #:i-cooperate/it-cooperates COOPERATE 
         #:i-cooperate/it-defects    DEFECT
         #:i-defect/it-cooperates    DEFECT
         #:i-defect/it-defects       DEFECT)]))

(define (transitions #:i-cooperate/it-cooperates cc
                     #:i-cooperate/it-defects    cd
                     #:i-defect/it-cooperates    dc
                     #:i-defect/it-defects       dd)
  (vector (vector cc cd) (vector dc dd)))

;; -----------------------------------------------------------------------------
)


(module automata-adapted typed/racket

(provide
 oAutomaton
 Payoff
 make-random-automaton
)

(require/typed (submod ".." automata)
 (make-random-automaton
  (-> Natural oAutomaton)))

(define-type oAutomaton (Instance Automaton))
(define-type Payoff Nonnegative-Real)
(define-type Transition* [Vectorof [Vectorof State]])
(define-type State Natural)
(define-type Input Natural)
(define-type Automaton
    (Class
     (init-field [current State]
                 [payoff Payoff] 
                 [table Transition*] 
                 [original State #:optional])
     [match-pair
      ;; the sum of pay-offs for the two respective automata over all rounds
      (-> oAutomaton Natural (values oAutomaton oAutomaton))]
     [jump
      ;; this has no business being public 
      (-> State Payoff Void)]
     [pay
      (-> Payoff)]
     [reset
      ;; reset the historic payoff 
      (-> oAutomaton)]
     [clone
      ;; reset payoff and current state to original strategy
      (-> oAutomaton)]
     [equal (-> oAutomaton Boolean)])))


(module utilities racket

;; Utility Functions

(provide
 ;; [Listof Number] -> Number 
 sum
 
 ;; [Listof Number] Number -> Number 
 relative-average
 
 ;; type Probability = NonNegativeReal 
 ;; [Listof Probability] N -> [Listof N]
 ;; choose n random indices i such i's likelihood is (list-ref probabilities i)
 choose-randomly)

;; =============================================================================
(define (sum l)
  (apply + l))

;; -----------------------------------------------------------------------------
(define (relative-average l w)
  (exact->inexact
   (/ (sum l)
      w (length l))))

;; -----------------------------------------------------------------------------

(define (choose-randomly probabilities speed #:random (q #false))
  (define %s (accumulated-%s probabilities))
  (for/list ([n (in-range speed)])
    [define r (or q (random))]
    ;; population is non-empty so there will be some i such that ... 
    (for/last ([p (in-naturals)] [% (in-list %s)] #:final (< r %)) p)))

;; [Listof Probability] -> [Listof Probability]
;; calculate the accumulated probabilities 

(define (accumulated-%s probabilities)
  (define total (sum probabilities))
  (let relative->absolute ([payoffs probabilities][so-far #i0.0])
    (cond
      [(empty? payoffs) '()]
      [else (define nxt (+ so-far (first payoffs)))
            (cons (/ nxt total) (relative->absolute (rest payoffs) nxt))]))))


(module population racket

;; Populations of Automata

;; population-payoffs (-> [Listof Payoff])

;; match-up* (-> N Population)
;; (match-ups p r) matches up neighboring pairs of
;; automata in population p for r rounds 
;; 

;; death-birth N -> Population 
;; (death-birth p r) replaces r elements of p with r "children" of 
;; randomly chosen fittest elements of p, also shuffle 
;; constraint (< r (length p))

(provide
 ;; type Population
 
 ;; N -> Population
 ;; (build-population n c) for even n, build a population of size n 
 ;; with c constraint: (even? n)
 build-random-population
 
 )

;; =============================================================================
(require (submod ".." automata) (submod ".." utilities))

;; Population = (Cons Automaton* Automaton*)
;; Automaton* = [Vectorof Automaton]

(define DEF-COO 2)

;; -----------------------------------------------------------------------------
(define (build-random-population n)
  (define v (build-vector n (lambda (_) (make-random-automaton DEF-COO))))
  (new population% [a* v]))

(define population%
  (class object%
    (init-field a* (b* a*))
    (super-new)
    
    (define/public (payoffs)
      (for/list ([a a*]) (send a pay)))
    
    (define/public (match-up* rounds-per-match)
      ;; comment out this line if you want cummulative payoff histories:
      ;; see below in birth-death
      (reset)
      ;; -- IN --
      (for ([i (in-range 0 (- (vector-length a*) 1) 2)])
        (define p1 (vector-ref a* i))
        (define p2 (vector-ref a* (+ i 1)))
        (define-values (a1 a2) (send p1 match-pair p2 rounds-per-match))
        (vector-set! a* i a1)
        (vector-set! a* (+ i 1) a2))
      this)
    
    (define/public (death-birth rate #:random (q #false))
      (define payoffs (for/list ([x (in-vector a*)]) (send x pay)))
      [define substitutes (choose-randomly payoffs rate #:random q)]
      (for ([i (in-range rate)][p (in-list substitutes)])
        (vector-set! a* i (send (vector-ref b* p) clone)))
      (shuffle-vector))
    
    ;; -> Void
    ;; effec: reset all automata in a*
    (define/private (reset)
      (for ([x a*][i (in-naturals)]) (vector-set! a* i (send x reset))))
    
    ;; -> Population
    ;; effect: shuffle vector b into vector a
    ;; constraint: (= (vector-length a) (vector-length b))
    ;; Fisher-Yates Shuffle
    
    (define/private (shuffle-vector)
      ;; copy b into a
      (for ([x (in-vector a*)][i (in-naturals)])
        (vector-set! b* i x))
      ;; now shuffle a 
      (for ([x (in-vector a*)] [i (in-naturals)])
        (define j (random (add1 i)))
        (unless (= j i) (vector-set! b* i (vector-ref b* j)))
        (vector-set! b* j x))
      (define tmp a*)
      (set! a* b*)
      (set! b* tmp)
      this)))

;; -----------------------------------------------------------------------------
)


(module population-adapted typed/racket

(provide
 oPopulation
 build-random-population
)
(require
  (submod ".." automata-adapted)
)
(require/typed (submod ".." population)
 (build-random-population
  (-> Natural oPopulation)))

(define-type Automaton* (Vectorof oAutomaton))
(define-type oPopulation (Instance Population))
(define-type Population
  (Class
   (init-field (a* Automaton*) (b* Automaton* #:optional))
   (payoffs (-> [Listof Payoff]))
   (match-up*
    ;; (match-ups p r) matches up neighboring pairs of
    ;; automata in population p for r rounds 
    (-> Natural oPopulation))

   (death-birth
    ;; (death-birth p r) replaces r elements of p with r "children" of 
    ;; randomly chosen fittest elements of p, also shuffle 
    ;; constraint (< r (length p))
    (-> Natural [#:random (U False Payoff)] oPopulation)))))


(module main typed/racket
(random-seed 7480)

;; Run a Simulation of Interacting Automata
;; Run a Simulation of Interacting Automata

;; =============================================================================
(require
  (submod ".." automata-adapted)
  (submod ".." population-adapted)
)
(require/typed (submod ".." utilities)
 (relative-average (-> [Listof Real] Real Real))
)

;; effect: run timed simulation, create and display plot of average payoffs
;; effect: measure time needed for the simulation
(define (main)
   (simulation->lines
    (evolve (build-random-population 100) 1000 10 20))
   (void))

(: simulation->lines (-> [Listof Payoff] (Listof (List Integer Real))))
;; turn average payoffs into a list of Cartesian points 
(define (simulation->lines data)
    (for/list : [Listof [List Integer Real]]
      ([d : Payoff (in-list data)][n : Integer (in-naturals)])
      (list n d)))

(: evolve (-> oPopulation Natural Natural Natural [Listof Payoff]))
;; computes the list of average payoffs over the evolution of population p for
;; c cycles of of match-ups with r rounds per match and at birth/death rate of s
(define (evolve p c s r)
  (cond
    [(zero? c) '()]
    [else (define p2 (send p match-up* r))
          ;; Note: r is typed as State even though State is not exported 
          (define pp (send p2 payoffs))
          (define p3 (send p2 death-birth s))
          ;; Note: s same as r
          ({inst cons Payoff [Listof Payoff]}
           (cast (relative-average pp r) Payoff)
           ;; Note: evolve is assigned (-> ... [Listof Probability])
           ;; even though it is explicitly typed ... [Listof Payoff]
           (evolve p3 (- c 1) s r))]))

(time (main)))