3 (chicken process-context)
17 (define (file->prog file)
18 (string->prog (with-input-from-file file read-string)))
20 (define (score-challenger-matches spec challenger-prog other-progs)
24 (score-match spec challenger-prog other-prog))
27 (define (score-match spec prog1 prog2)
28 (print "Matching " (prog-name prog1) " against " (prog-name prog2))
31 (lambda (score-a score-b)
32 (list (+ (car score-a) (car score-b))
33 (+ (cadr score-a) (cadr score-b))))
35 (let loop ((remaining (spec-games-per-match spec))
39 (cons (score-game spec prog1 prog2)
42 (let ((prog1-name (prog-name prog1))
43 (prog2-name (prog-name prog2)))
44 `((,prog1-name ,prog2-name ,(car tally))
45 (,prog2-name ,prog1-name ,(cadr tally))))))
47 (define (score-game spec prog1 prog2)
48 (let* ((core (make-core (spec-core-size spec)))
49 (queues (install-progs core (list prog1 prog2)))
50 (result (run-mars core queues (spec-game-length spec))))
52 ((null? result) (error "Invalid game result."))
53 ((= (length result) 1)
54 (let ((winner-name (caar result)))
55 (if (equal? winner-name (prog-name prog1))
61 (define (scores->rankings scores)
62 (let* ((prog-names (delete-duplicates (map car scores)))
64 (map (lambda (prog-name)
67 (filter (lambda (score)
68 (equal? prog-name (car score)))
71 (sort (zip prog-names prog-scores)
73 (< (cadr a) (cadr b))))))
75 (define (challenge hill-dir challenger-file)
76 (let* ((spec (hill-spec hill-dir))
77 (scores (hill-scores hill-dir))
78 (challenger-prog (file->prog challenger-file))
79 (hill-progs (map file->prog (hill-files hill-dir))))
80 (if (member (prog-name challenger-prog) (map prog-name hill-progs))
81 (print "Challenger already on hill!")
82 (let* ((new-scores (append (score-challenger-matches spec challenger-prog hill-progs)
84 (rankings (scores->rankings new-scores)))
85 (if (<= (length rankings) (spec-hill-size spec))
87 (save-hill-scores-and-rankings new-scores rankings hill-dir)
88 (hill-add-file challenger-file (prog-name challenger-prog) hill-dir))
89 (let ((loser (caar rankings)))
90 (save-hill-scores-and-rankings (filter (lambda (score)
91 (not (or (equal? (car score) loser)
92 (equal? (cadr score) loser))))
96 (hill-remove loser hill-dir)))))))
99 ;;; Hill initialization and specs
102 (define (hill-scores dir)
103 (with-input-from-file (make-pathname dir "scores") read))
105 (define (save-hill-scores-and-rankings scores rankings dir)
106 (with-output-to-file (make-pathname dir "scores")
107 (lambda () (pretty-print scores)))
108 (with-output-to-file (make-pathname dir "rankings")
109 (lambda () (pretty-print rankings))))
111 (define (hill-spec dir)
112 (with-input-from-file (make-pathname dir "spec") read))
114 (define (hill-files dir)
115 (glob (make-pathname dir "*.red")))
117 (define (hill-rankings dir)
118 (with-input-from-file (make-pathname dir "rankings") read))
120 (define (hill-add-file file name dir)
121 (copy-file file (make-pathname dir (->string name) ".red")))
123 (define (hill-remove-file name dir)
124 (delete-file (make-pathname dir name ".red")))
126 (define (make-spec core-size match-length games-per-match hill-size)
127 (list 'spec hill-size core-size match-length games-per-match))
130 (and (pair? spec) (eq? (car spec) 'spec)))
132 (define (spec-hill-size spec) (list-ref spec 1))
133 (define (spec-core-size spec) (list-ref spec 2))
134 (define (spec-game-length spec) (list-ref spec 3))
135 (define (spec-games-per-match spec) (list-ref spec 4))
137 (define (init-hill-dir dir hill-size core-size game-length games-per-match)
138 (if (or (not (directory-exists? dir)) (not (file-writable? dir)))
139 (print "Directory " dir " doesn't exist or is not writable.")
140 (if (not (null? (glob (make-pathname dir "*"))))
141 (print "Directory " dir " exists but is non-empty.")
143 (with-output-to-file (make-pathname dir "spec")
145 (print ";; Hill specifications.")
146 (print ";; ('spec hill-size core-size game-length games-per-match\n")
147 (pp (make-spec core-size game-length games-per-match hill-size))))
148 (with-output-to-file (make-pathname dir "scores")
149 (lambda () (pp '())))
150 (with-output-to-file (make-pathname dir "rankings")
151 (lambda () (pp '())))))))
157 (define default-core-size 8000)
158 (define default-game-length 80000)
159 (define default-games-per-match 3)
160 (define default-hill-size 10)
162 (define (print-usage)
163 (let ((binary (pathname-file (car (argv)))))
164 (print "King of the Hill Tournament Manager")
165 (print "\nUsage:\t" binary " hill-directory challenger-file")
166 (print "\t" binary " [-r|--rankings] hill-directory")
167 (print "\t" binary " [-h|--help]")
168 (print "\t" binary " [-i|--init] hill-directory [hill-size [core-size game-length games-per-match]]")
169 (print "\nDefault values are as follows:\n"
170 "\thill-size: " default-hill-size "\n"
171 "\tcore-size: " default-core-size "\n"
172 "\tgame-length: " default-game-length "\n"
173 "\tgames-per-match: " default-games-per-match)))
177 ((or () ((or "-h" "--help")))
179 (((or "-i" "--init") dir hill-size core-size game-length games-per-match)
180 (init-hill-dir dir hill-size core-size game-length games-per-match))
181 (((or "-i" "--init") dir)
186 default-games-per-match))
187 (((or "-i" "--init") dir hill-size)
192 default-games-per-match))
193 (((or "-r" "--rankings") dir)
194 (let ((rankings (reverse (hill-rankings dir))))
196 (print "No warriors on hill!")
199 (print "Warrior" "\t" "Score")
200 (print "-=-=-=-" "\t" "=-=-=")
201 (for-each (lambda (r) (print (car r) "\t" (cadr r))) rankings)))))
202 ((hill-dir challenger-file)
203 (challenge hill-dir challenger-file))
205 (print "Invalid arguments: " (apply conc else)))))