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)
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)
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)
149 (let* ((prog (file->prog file))
150 (name (prog-name prog))
151 (author (prog-author prog))
152 (submitted (seconds->string)))
153 (copy-file file (make-pathname dir name ".red"))
154 (with-output-to-file (make-pathname dir name ".info")
156 (pretty-print (list author submitted))))))
158 (define (hill-remove dir name)
159 (delete-file (make-pathname dir name ".red"))
160 (delete-file (make-pathname dir name ".info")))
162 (define (make-spec core-size match-length games-per-match hill-size)
163 (list 'spec hill-size core-size match-length games-per-match))
166 (and (pair? spec) (eq? (car spec) 'spec)))
168 (define (spec-hill-size spec) (list-ref spec 1))
169 (define (spec-core-size spec) (list-ref spec 2))
170 (define (spec-game-length spec) (list-ref spec 3))
171 (define (spec-games-per-match spec) (list-ref spec 4))
173 (define (init-hill-dir dir hill-size core-size game-length games-per-match)
174 (if (or (not (directory-exists? dir)) (not (file-writable? dir)))
175 (print "Directory " dir " doesn't exist or is not writable.")
176 (if (not (null? (glob (make-pathname dir "*"))))
177 (print "Directory " dir " exists but is non-empty.")
179 (with-output-to-file (make-pathname dir "spec")
181 (print ";; Hill specifications.")
182 (print ";; ('spec hill-size core-size game-length games-per-match\n")
183 (pp (make-spec core-size game-length games-per-match hill-size))))
184 (hill-save-scores-and-rankings dir '() '())
185 (with-output-to-file (make-pathname dir "news")
186 (lambda () (print '())))
187 (hill-news-add dir "Hill created.")))))
193 (define default-core-size 8000)
194 (define default-game-length 80000)
195 (define default-games-per-match 3)
196 (define default-hill-size 10)
198 (define (print-usage)
199 (let ((binary (pathname-file (car (argv)))))
200 (print "King of the Hill Tournament Manager")
201 (print "\nUsage:\t" binary " hill-directory challenger-file")
202 (print "\t" binary " [-r|--rankings] hill-directory")
203 (print "\t" binary " [-h|--help]")
204 (print "\t" binary " [-i|--init] hill-directory [hill-size [core-size game-length games-per-match]]")
205 (print "\nDefault values are as follows:\n"
206 "\thill-size: " default-hill-size "\n"
207 "\tcore-size: " default-core-size "\n"
208 "\tgame-length: " default-game-length "\n"
209 "\tgames-per-match: " default-games-per-match)))
213 ((or () ((or "-h" "--help")))
215 (((or "-i" "--init") dir hill-size core-size game-length games-per-match)
217 (string->number hill-size)
218 (string->number core-size)
219 (string->number game-length)
220 (string->number games-per-match)))
221 (((or "-i" "--init") dir)
226 default-games-per-match))
227 (((or "-i" "--init") dir hill-size)
229 (string->number hill-size)
232 default-games-per-match))
233 (((or "-r" "--rankings") dir)
234 (let ((rankings (reverse (hill-rankings dir))))
236 (print "No warriors on hill!")
238 (print "Warrior" "\t" "Score")
239 (print "-=-=-=-" "\t" "=-=-=")
240 (for-each (lambda (r) (print (car r) "\t\t" (cadr r))) rankings)))))
241 ((hill-dir challenger-file)
242 (challenge hill-dir challenger-file))
244 (print "Invalid arguments: " (apply conc else)))))