3 (chicken process-context)
18 (define (file->prog file)
19 (string->prog (with-input-from-file file read-string)))
21 (define (score-challenger-matches spec challenger-prog other-progs)
25 (score-match spec challenger-prog other-prog))
28 (define (score-match spec prog1 prog2)
29 (print "... Matching " (prog-name prog1) " against " (prog-name prog2))
32 (lambda (score-a score-b)
33 (list (+ (car score-a) (car score-b))
34 (+ (cadr score-a) (cadr score-b))))
36 (let loop ((remaining (spec-games-per-match spec))
40 (cons (score-game spec prog1 prog2)
43 (let ((prog1-name (prog-name prog1))
44 (prog2-name (prog-name prog2)))
45 `((,prog1-name ,prog2-name ,(car tally))
46 (,prog2-name ,prog1-name ,(cadr tally))))))
48 (define (score-game spec prog1 prog2)
49 (let* ((core (make-core (spec-core-size spec)))
50 (queues (install-progs core (list prog1 prog2)))
51 (result (run-mars core queues (spec-game-length spec))))
53 ((null? result) (error "Invalid game result."))
54 ((= (length result) 1)
55 (let ((winner-name (caar result)))
56 (if (equal? winner-name (prog-name prog1))
62 (define (scores->rankings scores)
63 (let* ((prog-names (delete-duplicates (map car scores)))
65 (map (lambda (prog-name)
68 (filter (lambda (score)
69 (equal? prog-name (car score)))
72 (sort (zip prog-names prog-scores)
74 (< (cadr a) (cadr b))))))
76 (define (challenge hill-dir challenger-file)
77 (let* ((spec (hill-spec hill-dir))
78 (scores (hill-scores hill-dir))
79 (challenger-prog (file->prog challenger-file))
80 (challenger-name (prog-name challenger-prog))
81 (hill-progs (map file->prog (hill-files hill-dir))))
82 (hill-news-add hill-dir "Challenger '" challenger-name "' accepted for battle.")
83 (if (member challenger-name (map prog-name hill-progs))
84 (hill-news-add hill-dir "Challenge aborted: challenger already on hill!")
85 (let* ((new-scores (append (score-challenger-matches spec challenger-prog hill-progs)
87 (rankings (scores->rankings new-scores)))
88 (if (<= (length rankings) (spec-hill-size spec))
90 (hill-save-scores-and-rankings hill-dir new-scores rankings)
91 (hill-add hill-dir challenger-file challenger-name)
92 (hill-news-add hill-dir "Challenger '" challenger-name "' added to the hill."))
93 (let ((loser-name (caar rankings)))
94 (hill-save-scores-and-rankings hill-dir
95 (filter (lambda (score)
96 (not (or (equal? (car score) loser-name)
97 (equal? (cadr score) loser-name))))
100 (hill-add hill-dir challenger-file challenger-name)
101 (hill-remove hill-dir loser-name)
102 (if (equal? loser-name challenger-name)
103 (hill-news-add hill-dir
104 "Challenger '" challenger-name
105 "' failed to best any warrior on the hill.")
107 (hill-news-add hill-dir
108 "Challenger '" challenger-name
109 "' defeated at least one warrior on the hill.")
110 (hill-news-add hill-dir
111 "Warrior '" loser-name
112 "' has been pushed off the hill!")))))))))
115 ;;; Hill initialization and specs
118 (define (hill-scores dir)
119 (with-input-from-file (make-pathname dir "scores") read))
121 (define (hill-save-scores-and-rankings dir scores rankings)
124 (with-output-to-file (make-pathname dir (car p))
125 (lambda () (pretty-print (cdr p)))))
126 `(("scores" . ,scores) ("rankings" . ,rankings))))
128 (define (hill-spec dir)
129 (with-input-from-file (make-pathname dir "spec") read))
131 (define (hill-files dir)
132 (glob (make-pathname dir "*.red")))
134 (define (hill-rankings dir)
135 (with-input-from-file (make-pathname dir "rankings") read))
137 (define (hill-news dir)
138 (with-input-from-file (make-pathname dir "news") read))
140 (define (hill-news-add dir . args)
141 (let* ((old-news (hill-news dir))
142 (news-string (apply conc args))
143 (new-news (cons (cons (seconds->string) news-string) old-news)))
145 (with-output-to-file (make-pathname dir "news")
146 (lambda () (pretty-print new-news)))))
148 (define (hill-add dir file name)
149 (copy-file file (make-pathname dir (->string name) ".red")))
151 (define (hill-remove dir name)
152 (delete-file (make-pathname dir name ".red")))
154 (define (make-spec core-size match-length games-per-match hill-size)
155 (list 'spec hill-size core-size match-length games-per-match))
158 (and (pair? spec) (eq? (car spec) 'spec)))
160 (define (spec-hill-size spec) (list-ref spec 1))
161 (define (spec-core-size spec) (list-ref spec 2))
162 (define (spec-game-length spec) (list-ref spec 3))
163 (define (spec-games-per-match spec) (list-ref spec 4))
165 (define (init-hill-dir dir hill-size core-size game-length games-per-match)
166 (if (or (not (directory-exists? dir)) (not (file-writable? dir)))
167 (print "Directory " dir " doesn't exist or is not writable.")
168 (if (not (null? (glob (make-pathname dir "*"))))
169 (print "Directory " dir " exists but is non-empty.")
171 (with-output-to-file (make-pathname dir "spec")
173 (print ";; Hill specifications.")
174 (print ";; ('spec hill-size core-size game-length games-per-match\n")
175 (pp (make-spec core-size game-length games-per-match hill-size))))
176 (hill-save-scores-and-rankings dir '() '())
177 (with-output-to-file (make-pathname dir "news")
178 (lambda () (print '())))
179 (hill-news-add dir "Hill created.")))))
185 (define default-core-size 8000)
186 (define default-game-length 80000)
187 (define default-games-per-match 3)
188 (define default-hill-size 10)
190 (define (print-usage)
191 (let ((binary (pathname-file (car (argv)))))
192 (print "King of the Hill Tournament Manager")
193 (print "\nUsage:\t" binary " hill-directory challenger-file")
194 (print "\t" binary " [-r|--rankings] hill-directory")
195 (print "\t" binary " [-h|--help]")
196 (print "\t" binary " [-i|--init] hill-directory [hill-size [core-size game-length games-per-match]]")
197 (print "\nDefault values are as follows:\n"
198 "\thill-size: " default-hill-size "\n"
199 "\tcore-size: " default-core-size "\n"
200 "\tgame-length: " default-game-length "\n"
201 "\tgames-per-match: " default-games-per-match)))
205 ((or () ((or "-h" "--help")))
207 (((or "-i" "--init") dir hill-size core-size game-length games-per-match)
209 (string->number hill-size)
210 (string->number core-size)
211 (string->number game-length)
212 (string->number games-per-match)))
213 (((or "-i" "--init") dir)
218 default-games-per-match))
219 (((or "-i" "--init") dir hill-size)
221 (string->number hill-size)
224 default-games-per-match))
225 (((or "-r" "--rankings") dir)
226 (let ((rankings (reverse (hill-rankings dir))))
228 (print "No warriors on hill!")
230 (print "Warrior" "\t" "Score")
231 (print "-=-=-=-" "\t" "=-=-=")
232 (for-each (lambda (r) (print (car r) "\t\t" (cadr r))) rankings)))))
233 ((hill-dir challenger-file)
234 (challenge hill-dir challenger-file))
236 (print "Invalid arguments: " (apply conc else)))))