1 (import (chicken process-context)
12 (define INITIAL-INSTR (make-instr 'DAT 'F 'immediate 0 'immediate 0))
17 (define (file->prog file)
18 (string->prog (with-input-from-file fname read)))
20 (define (score-challenger-matches spec challenger-file other-files)
21 (let ((challenger-prog (file->prog challenger-file))
22 (challenger-name (prog-name challenger-prog))
23 (other-progs (apply file->prog other-files)))
26 (score-match spec challenger-prog other-prog))
29 (define (score-match spec prog1 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)))
37 (loop (- remaining 1))))))
38 `((,(prog-name prog1 ,(car tally)))
39 (,(prog-name prog2 ,(cadr tally))))))
41 (define (score-game spec prog1 prog2)
42 (let* ((core (make-core (spec-core-size spec) INITIAL-INSTR))
43 (queues (install-progs core (list prog1 prog2)))
44 (result (run-mars core queues (spec-game-length spec))))
46 ((null? result) (error "Invalid game result."))
47 ((= (length result) 1)
48 (let ((winner-name (caar result)))
49 (if (eq? winner-name name1)
55 (define (count-scores-for-progs progs)
57 (count-scores-for-name scores (prog-name prog)))
60 (define (count-scores-for-name scores name)
62 (remaining-scores scores))
63 (if (null? remaining-scores)
66 (let ((this-score (car remaining-scores)))
68 ((eq? (caar this-score) name)
69 (loop (+ score (cadar this-score)) (cdr remaining-scores)))
70 ((eq? (caadr this-score) name)
71 (loop (+ score (cadadr this-score)) (cdr remaining-scores)))))))))
73 ;;; Hill initialization and specs
76 (define (load-scores dir)
77 (with-input-from-file (make-pathname dir "scores") read))
79 (define (load-specs dir)
80 (with-input-from-file (make-pathname dir "specs") read))
82 (define (make-specs core-size match-length games-per-match hill-size)
83 (list 'specs hill-size core-size match-length games-per-match))
85 (define (specs? specs)
86 (and (pair? specs) (eq? (car specs) 'specs)))
88 (define (specs-hill-size specs) (list-ref specs 1))
89 (define (specs-core-size specs) (list-ref specs 2))
90 (define (specs-game-length specs) (list-ref specs 3))
91 (define (specs-games-per-match specs) (list-ref specs 4))
93 (define (init-hill-dir dir hill-size core-size game-length games-per-match)
94 (if (or (not (directory-exists? dir)) (not (file-writable? dir)))
95 (print "Directory " dir " doesn't exist or is not writable.")
96 (if (not (null? (glob (make-pathname dir "*"))))
97 (print "Directory " dir " exists but is non-empty.")
98 (with-output-to-file (make-pathname dir "specs")
100 (print ";; Hill specifications.")
101 (print ";; ('specs hill-size core-size game-length games-per-match\n")
102 (pp (make-specs core-size game-length games-per-match hill-size))))
103 (with-output-to-file (make-pathname dir "scores")
111 (define default-core-size 8000)
112 (define default-game-length 80000)
113 (define default-games-per-match 1)
114 (define default-hill-size 10)
118 (define (print-usage)
119 (let ((binary (pathname-file (car (argv)))))
120 (print "King of the Hill Tournament Manager")
121 (print "\nUsage:\t" binary " hill-directory challenger-file")
122 (print "\t" binary " [-h|--help]")
123 (print "\t" binary " [-i|--init] hill-directory [hill-size [core-size game-length games-per-match]]")
124 (print "\nDefault values are as follows:\n"
125 "\thill-size: " default-hill-size "\n"
126 "\tcore-size: " default-core-size "\n"
127 "\tgame-length: " default-game-length "\n"
128 "\tgames-per-match: " default-games-per-match)))
130 (define (process-args args)
132 ((or () ((or "-h" "--help")))
134 (((or "-i" "--init") dir hill-size core-size game-length games-per-match)
135 (init-hill-dir dir hill-size core-size game-length games-per-match))
136 (((or "-i" "--init") dir)
141 default-games-per-match))
142 (((or "-i" "--init") dir hill-size)
147 default-games-per-match))
148 ((hill-dir challenger-file)
149 (print "Not implemented"))
151 (print "Invalid arguments: " (apply conc else)))))
154 (process-args (cdr (argv))))