mirror of
https://github.com/osmarks/random-stuff
synced 2025-10-30 05:23:00 +00:00
iterated prisoner's dilemma challenge things
This commit is contained in:
158
dilemma.scm
Normal file
158
dilemma.scm
Normal file
@@ -0,0 +1,158 @@
|
||||
;; prisond.scm: iterated prisoner's dilemma simulation
|
||||
;; by matt
|
||||
;; this program is in the public domain
|
||||
|
||||
(define strategies '())
|
||||
|
||||
(define add-strategy
|
||||
(lambda (x y)
|
||||
(set! strategies (cons (cons x y) strategies))))
|
||||
|
||||
(define angel
|
||||
(lambda (x y) 0))
|
||||
|
||||
(define devil
|
||||
(lambda (x y) 1))
|
||||
|
||||
(define tat-for-tit
|
||||
(lambda (x y)
|
||||
(if (null? x)
|
||||
1
|
||||
(if (= (car x) 0)
|
||||
1
|
||||
0))))
|
||||
|
||||
(define tit-for-tat
|
||||
(lambda (x y)
|
||||
(if (null? x)
|
||||
0
|
||||
(car x))))
|
||||
|
||||
(define time-machine
|
||||
(lambda (x y)
|
||||
(if (> 3 (length x))
|
||||
0
|
||||
(caddr x))))
|
||||
|
||||
(define random-choice
|
||||
(lambda (x y)
|
||||
(random 2)))
|
||||
|
||||
(define grudger
|
||||
(lambda (x y)
|
||||
(if (memq 1 x)
|
||||
1
|
||||
0)))
|
||||
|
||||
(define angry-tit-for-tat
|
||||
(lambda (x y)
|
||||
(if (null? x)
|
||||
1
|
||||
(car x))))
|
||||
|
||||
(define apl
|
||||
(lambda (x y)
|
||||
(if (null? x)
|
||||
1
|
||||
(if (= ( car y) 0)
|
||||
1
|
||||
0))))
|
||||
|
||||
(load-shared-object "/usr/lib/libc.so.6")
|
||||
(define fork (foreign-procedure #f "fork" () unsigned))
|
||||
;(define waitpid (foreign-procedure #f "waitpid" (unsigned uptr unsigned) integer-32))
|
||||
(define wait (foreign-procedure #f "wait" (uptr) integer-32))
|
||||
(define mmap (foreign-procedure #f "mmap" (uptr unsigned integer-32 integer-32 integer-32 unsigned) uptr))
|
||||
(define shmem (mmap 0 8 3 33 -1 0))
|
||||
|
||||
(define tt-run
|
||||
(lambda (pid)
|
||||
(if (> pid 0) (begin
|
||||
(wait 0)
|
||||
(foreign-ref 'integer-64 shmem 0)
|
||||
) 'temporary-timeline)))
|
||||
(define tt-send (lambda (x) (begin
|
||||
(foreign-set! 'integer-64 shmem 0 3)
|
||||
(exit))))
|
||||
(define tt-recv (lambda () (tt-run (fork))))
|
||||
|
||||
(set! strategized 0)
|
||||
(set! running 0)
|
||||
(define apiomemetics
|
||||
(lambda (x y)
|
||||
(if (null? x)
|
||||
(if (= running 0) (let ((ttr (tt-recv))) (if (eq? ttr 'temporary-timeline)
|
||||
(begin (set! running 1) (display "temporary TL\n") 0)
|
||||
(begin (set! running 1) (display "primary TL, got result ") (display ttr) (newline) (set! strategized 1) 0))) 0)
|
||||
(if (= (length x) 99)
|
||||
(if (= strategized 0) (begin
|
||||
(display "end of game, reversing\n")
|
||||
(tt-send 3)
|
||||
) (begin
|
||||
(set! running 0)
|
||||
(display "end of game in primary\n")
|
||||
0
|
||||
))
|
||||
(car x)))))
|
||||
|
||||
(define prisond
|
||||
(lambda (x y)
|
||||
(if (= x y)
|
||||
(if (= x 1)
|
||||
'(-2 -2)
|
||||
'(-1 -1))
|
||||
(if (= x 1)
|
||||
'(0 -3)
|
||||
'(-3 0)))))
|
||||
|
||||
(define iter-prisond
|
||||
(lambda (x y z)
|
||||
(define scores '(0 0))
|
||||
(define moves-x '())
|
||||
(define moves-y '())
|
||||
(define current-moves '())
|
||||
(define helper
|
||||
(lambda (x y z)
|
||||
(if (= z 0)
|
||||
scores
|
||||
(begin
|
||||
(set! current-moves (list (x moves-x moves-y) (y moves-y moves-x)))
|
||||
(set! moves-x (cons (cadr current-moves) moves-x))
|
||||
(set! moves-y (cons (car current-moves) moves-y))
|
||||
(set! scores (map + scores (prisond (car current-moves) (cadr current-moves))))
|
||||
(helper x y (- z 1)))))) (helper x y z)))
|
||||
|
||||
(define get-strategy-scores
|
||||
(lambda (x)
|
||||
(define score 0)
|
||||
(define helper
|
||||
(lambda (y)
|
||||
(if (eqv? (car x) (car y))
|
||||
0
|
||||
(set! score (+ score (car (iter-prisond (cdr x) (cdr y) 100)))))))
|
||||
(map helper strategies)
|
||||
score))
|
||||
|
||||
(define get-all-scores
|
||||
(lambda ()
|
||||
(define helper
|
||||
(lambda (x)
|
||||
(write (list (car x) (get-strategy-scores x)))
|
||||
(newline)))
|
||||
(map helper strategies)))
|
||||
|
||||
(add-strategy 'angel angel)
|
||||
(add-strategy 'devil devil)
|
||||
(add-strategy 'tit-for-tat tit-for-tat)
|
||||
(add-strategy 'tat-for-tit tat-for-tit)
|
||||
(add-strategy 'time-machine time-machine)
|
||||
(add-strategy 'random-choice random-choice)
|
||||
(add-strategy 'grudger grudger)
|
||||
(add-strategy 'angry-tit-for-tat angry-tit-for-tat)
|
||||
(add-strategy 'apl apl)
|
||||
(add-strategy 'apiomemetics apiomemetics)
|
||||
|
||||
(random-seed (time-second (current-time)))
|
||||
|
||||
(get-all-scores)
|
||||
(exit)
|
||||
170
dilemma2.scm
Normal file
170
dilemma2.scm
Normal file
@@ -0,0 +1,170 @@
|
||||
;; prisond.scm: iterated prisoner's dilemma simulation
|
||||
;; by matt
|
||||
;; this program is in the public domain
|
||||
|
||||
(define strategies '())
|
||||
|
||||
(define add-strategy
|
||||
(lambda (x y)
|
||||
(set! strategies (cons (cons x y) strategies))))
|
||||
|
||||
(define angel
|
||||
(lambda (x y) 0))
|
||||
|
||||
(define devil
|
||||
(lambda (x y) 1))
|
||||
|
||||
(define tat-for-tit
|
||||
(lambda (x y)
|
||||
(if (null? x)
|
||||
1
|
||||
(if (= (car x) 0)
|
||||
1
|
||||
0))))
|
||||
|
||||
(define tit-for-tat
|
||||
(lambda (x y)
|
||||
(if (null? x)
|
||||
0
|
||||
(car x))))
|
||||
|
||||
(define time-machine
|
||||
(lambda (x y)
|
||||
(if (> 3 (length x))
|
||||
0
|
||||
(caddr x))))
|
||||
|
||||
(define random-choice
|
||||
(lambda (x y)
|
||||
(random 2)))
|
||||
|
||||
(define grudger
|
||||
(lambda (x y)
|
||||
(if (memq 1 x)
|
||||
1
|
||||
0)))
|
||||
|
||||
(define angry-tit-for-tat
|
||||
(lambda (x y)
|
||||
(if (null? x)
|
||||
1
|
||||
(car x))))
|
||||
|
||||
(define apl
|
||||
(lambda (x y)
|
||||
(if (null? x)
|
||||
1
|
||||
(if (= ( car y) 0)
|
||||
1
|
||||
0))))
|
||||
|
||||
(define forgiving-grudge
|
||||
(lambda (x y) (let* (
|
||||
(defection-count (length (filter (lambda (m) (= m 1)) x)))
|
||||
(result (if (> defection-count 3) 1 0))
|
||||
) result)))
|
||||
|
||||
(define (take n xs)
|
||||
(let loop ((n n) (xs xs) (zs (list)))
|
||||
(if (or (zero? n) (null? xs))
|
||||
(reverse zs)
|
||||
(loop (- n 1) (cdr xs)
|
||||
(cons (car xs) zs)))))
|
||||
|
||||
(define (zip . xss) (apply map list xss))
|
||||
|
||||
(define actually-forgiving-grudge
|
||||
(lambda (x y) (let* (
|
||||
(defection-count (length (filter (lambda (m) (= m 1)) x)))
|
||||
(lookback (+ 1 (inexact->exact (floor (expt 1.8 defection-count)))))
|
||||
(result (if (member '(1 0) (take lookback (zip x y))) 1 0))
|
||||
) result)))
|
||||
|
||||
(define apiomemetics
|
||||
(lambda (x y) (random-seed 334278294) ; NOTE TO SELF: 3227883998 (0/1)
|
||||
(if (null? x)
|
||||
(begin 0)
|
||||
(if (> (length x) 93)
|
||||
1
|
||||
(car x)))))
|
||||
|
||||
(define meapiometics
|
||||
(lambda (x y)
|
||||
(if (null? x)
|
||||
0
|
||||
(if (> (length x) 97)
|
||||
1
|
||||
(car x)))))
|
||||
|
||||
(define prisond
|
||||
(lambda (x y)
|
||||
(if (= x y)
|
||||
(if (= x 1)
|
||||
'(-2 -2)
|
||||
'(-1 -1))
|
||||
(if (= x 1)
|
||||
'(0 -3)
|
||||
'(-3 0)))))
|
||||
|
||||
(define iter-prisond
|
||||
(lambda (x y z)
|
||||
(define scores '(0 0))
|
||||
(define moves-x '())
|
||||
(define moves-y '())
|
||||
(define current-moves '())
|
||||
(define helper
|
||||
(lambda (x y z)
|
||||
(if (= z 0)
|
||||
scores
|
||||
(begin
|
||||
(set! current-moves (list (x moves-x moves-y) (y moves-y moves-x)))
|
||||
(set! moves-x (cons (cadr current-moves) moves-x))
|
||||
(set! moves-y (cons (car current-moves) moves-y))
|
||||
(set! scores (map + scores (prisond (car current-moves) (cadr current-moves))))
|
||||
(helper x y (- z 1)))))) (helper x y z)))
|
||||
|
||||
(define get-strategy-scores
|
||||
(lambda (x)
|
||||
(define score 0)
|
||||
(define iters (+ 100 (random 50)))
|
||||
(define helper
|
||||
(lambda (y)
|
||||
(if (eqv? (car x) (car y))
|
||||
0
|
||||
(set! score (+ score (car (iter-prisond (cdr x) (cdr y) iters)))))))
|
||||
(map helper strategies)
|
||||
score))
|
||||
|
||||
(define get-repeated-score
|
||||
(lambda (strategy accumulator counter)
|
||||
(if (= counter 0) accumulator
|
||||
(get-repeated-score strategy
|
||||
(+ accumulator (get-strategy-scores strategy))
|
||||
(- counter 1)))))
|
||||
|
||||
(define get-all-scores
|
||||
(lambda ()
|
||||
(define helper
|
||||
(lambda (x)
|
||||
(write (list (car x) (get-repeated-score x 0 50)))
|
||||
(newline)))
|
||||
(map helper strategies)))
|
||||
|
||||
(add-strategy 'angel angel)
|
||||
(add-strategy 'devil devil)
|
||||
(add-strategy 'tit-for-tat tit-for-tat)
|
||||
(add-strategy 'tat-for-tit tat-for-tit)
|
||||
(add-strategy 'time-machine time-machine)
|
||||
(add-strategy 'random-choice random-choice)
|
||||
(add-strategy 'grudger grudger)
|
||||
(add-strategy 'angry-tit-for-tat angry-tit-for-tat)
|
||||
(add-strategy 'apl apl)
|
||||
(add-strategy 'meapiometics meapiometics)
|
||||
(add-strategy 'apiomemetics apiomemetics)
|
||||
(add-strategy 'forgiving-grudge forgiving-grudge)
|
||||
(add-strategy 'actually-forgiving-grudge actually-forgiving-grudge)
|
||||
|
||||
(random-seed (time-second (current-time)))
|
||||
|
||||
(get-all-scores)
|
||||
(exit)
|
||||
15
srbf.scm
Normal file
15
srbf.scm
Normal file
@@ -0,0 +1,15 @@
|
||||
(define count-zeros
|
||||
(lambda (x) (if (= (random 50) 0) (count-zeros (+ 1 x)) x)))
|
||||
(define try-sequentially (lambda (x max)
|
||||
(random-seed x)
|
||||
(let ((zeros (count-zeros 0))) (if (> zeros max)
|
||||
(begin
|
||||
(display "s=")
|
||||
(display x)
|
||||
(display ", r=")
|
||||
(display zeros)
|
||||
(newline)
|
||||
(try-sequentially (+ 1 x) zeros))
|
||||
(try-sequentially (+ 1 x) max)))))
|
||||
(try-sequentially 1 0)
|
||||
(exit)
|
||||
Reference in New Issue
Block a user