fsm-benchmark.rkt

#lang racket/base

(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)
(let ()
  (for ((i (in-range 4 10)))
    (printf "running ~a\n" i)
    (collect-garbage 'major)
    (time (void (main i)))))