;; The first three lines of this file were inserted by DrScheme. They record metadata
;; about the language level of this file in a form that our tools can easily process.
#reader(lib "htdp-advanced-reader.ss" "lang")((modname rpsga) (read-case-sensitive #t) (teachpacks ((lib "image.ss" "teachpack" "htdp") (lib "world.ss" "teachpack" "htdp"))) (htdp-settings #(#t constructor repeating-decimal #t #t none #f ((lib "image.ss" "teachpack" "htdp") (lib "world.ss" "teachpack" "htdp")))))
;; the pay-off-matrix used in our little "Rock, Paper, Scissors" game
(define pay-off-matrix
(list (list (list 0 0) (list 10 0) (list 0 10))
(list (list 0 10) (list 0 0) (list 10 0))
(list (list 10 0) (list 0 10) (list 0 0))))
;; the following matrix operations have been designed to handle vectors as a cell type
;; might not be pretty, but they get the job done
;; matrix transposition
(define (mat-t m)
(cond
[(empty? m) empty]
[(not (list? (car m))) (map (lambda (x) (cons x empty)) m)]
[(empty? (car m)) empty]
[else (cons (map car m) (mat-t (map cdr m)))]))
;; vector addition
(define (v-add p q)
(cond
[(and (number? p) (number? q)) (+ p q)]
[(empty? q) p]
[else (cons (v-add (car p) (car q)) (v-add (cdr p) (cdr q)))]))
;; vector multiplication
(define (v-mul p q)
(cond
[(and (number? p) (number? q)) (* p q)]
[(and (number? p) (list? q)) (map (lambda (x) (* p x)) q)]
[(and (number? q) (list? p)) (map (lambda (x) (* q x)) p)]
[(or (empty? p) (empty? q)) empty]
[else (cons (v-mul (car p) (car q)) (v-mul (cdr p) (cdr q)))]))
;; vector dot product
(define (v-dot p q)
(cond
[(or (empty? p) (empty? q)) empty]
[else (v-add (v-mul (car p) (car q)) (v-dot (cdr p) (cdr q)))]))
;; matrix multiplication
(define (mat-mul a b)
(cond
[(or (empty? a) (empty? b)) empty]
[(and (number? a) (number? b)) (* a b)]
[(number? a) (mat-mul b a)]
[(and (list? a) (number? b)) (map (lambda (x) (mat-mul x b)) a)]
[else (local ((define b-transpose (mat-t b))
(define first-column-t (car b-transpose))
(define rest-columns (mat-t (cdr b-transpose))))
(cons (cons (v-dot (car a) first-column-t) (if (empty? rest-columns) empty (car (mat-mul (list (car a)) rest-columns))))
(mat-mul (cdr a) b)))]
))
;; some quick tests to check the above operations
(define (mathtests)
(and
(equal? (mat-mul (list 0 1 3) 2) (list 0 2 6))
(equal? (mat-mul 2 (list 0 1 3)) (list 0 2 6))
(equal? (mat-mul (mat-t (list 0 1 3)) 2) (list (list 0) (list 2) (list 6)))
(equal? (mat-mul 2 (mat-t (list 0 1 3))) (list (list 0) (list 2) (list 6)))
(equal? (mat-mul (list (list 0 1 2) (list 3 4 5) (list 6 7 8)) 2) (list (list 0 2 4) (list 6 8 10) (list 12 14 16)))
(equal? (mat-mul 2 (list (list 0 1 2) (list 3 4 5) (list 6 7 8))) (list (list 0 2 4) (list 6 8 10) (list 12 14 16)))
(equal? (v-add (list 1 2 4) (list 6 7 8)) (list 7 9 12))
(equal? (v-add (list (list 1 2 3)) (list (list 4 5 6))) (list (list 5 7 9)))
(equal? (v-add (list (list 1) (list 2) (list 3)) (list (list 4) (list 5) (list 6))) (list (list 5) (list 7) (list 9)))
(equal? (v-mul (list 0 2 4) (list 1 3 5)) (list 0 6 20))
(equal? (v-dot (list 0 2 4) (list 1 3 5)) 26)
(equal? (mat-mul (list (list 0 2 4)) (list (list 1) (list 3) (list 5))) (list (list 26)))
(equal? (mat-mul (list (list 1) (list 3) (list 5)) (list (list 0 2 4))) (list (list 0 2 4) (list 0 6 12) (list 0 10 20)))))
(display "Math Test: This should return true\n")
(mathtests)
;; Now that our matrix operations are properly defined,
;; playing the game is as easy as multipling the pay-off-matrix by both players
(define (play p1 p2)
(caar (mat-mul (mat-mul (list p1) pay-off-matrix) (mat-t p2))))
;; Sample matches from blog post
(display "Match 1: (.8 0 .2) vs (.3 .4 .3)\n")
(play (list .8 0 .2) (list .3 .4 .3))
(display "Match 2: (0 .4 .6) vs (.8 0 .2)\n")
(play (list 0 .4 .6) (list .8 0 .2))
(display "Match 3: (0 .4 .6) vs (.3 .4 .3)\n")
(play (list 0 .4 .6) (list .3 .4 .3))
;; creates a list of "n" randomized strategies
(define (random-players n)
(if (> n 0)
(let ((r1 (random)) (r2 (random))) (cons (list r1 (* (- 1 r1) r2) (- 1 (+ r1 (* (- 1 r1) r2)))) (random-players (- n 1))))
empty))
;; takes a given player and a list of opponents
;; plays player against each opponent and sums the results from each game
(define (play-list p r)
(if (empty? r)
0
(+ (car (play p (car r))) (play-list p (cdr r)))))
;; pits every player against every other player, sums the score for each player, then sorts from high to low
;; note: each player is also played against themselves, but since our matrix is symmetric this will always result in a tie
(define (do-play-off players)
(sort (map (lambda (x) (list (play-list x players) x)) players) (lambda (x y) (> (car x) (car y)))))
;; returns the top "n" player's given a list of play-off results
(define (get-top-n play-off-results n)
(if (> n 0)
(cons (cadar play-off-results) (get-top-n (cdr play-off-results) (- n 1)))
empty))
;; evolve -- the main work horse of our genetic algorithm
;; takes a population "pool" containing a list of player strategies
;; plays each player against each other and sorts the results
;; the top "keep" number of players stay in the pool
;; "replace" number of random new players are added to the pool
;; repeats for the specified number of "steps"
(define (evolve pool steps keep replace)
(if (> steps 0)
(evolve (append (get-top-n (do-play-off pool) keep) (random-players replace)) (- steps 1) keep replace)
pool))
;; example of a population at equlibrium
(define pool (list (list (/ 1 3) (/ 1 3) (/ 1 3)) (list (/ 1 3) (/ 1 3) (/ 1 3)) (list (/ 1 3) (/ 1 3) (/ 1 3)) (list (/ 1 3) (/ 1 3) (/ 1 3)) (list (/ 1 3) (/ 1 3) (/ 1 3))))
(display "Example 1: Equilibrium/Stale Metagame\nInitial Player Pool:\n")
pool
(display "\nAfter 10 generations:\n")
(begin (set! pool (evolve pool 10 4 1)) pool)
(display "\nAfter 100 generations:\n")
(begin (set! pool (evolve pool 90 4 1)) pool)
(display "\nAfter 1000 generations:\n")
(begin (set! pool (evolve pool 900 4 1)) pool)
(display "\nAfter 10000 generations:\n")
(begin (set! pool (evolve pool 9000 4 1)) pool)
(display "Example 2: Sensitivity to initial conditions\nInitial Player Pool:\n")
(begin (set! pool (list (list .34 .33 .33) (list .34 .33 .33) (list .34 .33 .33) (list .34 .33 .33) (list .34 .33 .33))) pool)
(display "\nAfter 10 generations:\n")
(begin (set! pool (evolve pool 10 4 1)) pool)
(display "\nAfter 100 generations:\n")
(begin (set! pool (evolve pool 90 4 1)) pool)
(display "\nAfter 1000 generations:\n")
(begin (set! pool (evolve pool 900 4 1)) pool)
(display "\nAfter 10000 generations:\n")
(begin (set! pool (evolve pool 9000 4 1)) pool)
(display "Example 3: Large Pools, Random Initial Conditions\nInitial Player Pool:\n")
(begin (set! pool (random-players 20)) pool)
(display "\nAfter 10 generations:\n")
(begin (set! pool (evolve pool 10 20 5)) pool)
(display "\nAfter 100 generations:\n")
(begin (set! pool (evolve pool 90 20 5)) pool)
(display "\nAfter 1000 generations:\n")
(begin (set! pool (evolve pool 900 20 5)) pool)