3 (chicken process-context)
16 (define (file->prog file)
17 (string->prog (with-input-from-file file read-string)))
19 (define (score-challenger-matches spec challenger-prog other-progs)
22 (score-match spec challenger-prog other-prog))
25 (define (score-match spec prog1 prog2)
26 (print "Matching " (prog-name prog1) " against " (prog-name prog2))
29 (lambda (score-a score-b)
30 (list (+ (car score-a) (car score-b))
31 (+ (cadr score-a) (cadr score-b))))
33 (let loop ((remaining (spec-games-per-match spec))
37 (cons (score-game spec prog1 prog2)
40 (let ((prog1-name (prog-name prog1))
41 (prog2-name (prog-name prog2)))
42 `(((,prog1-name ,prog2-name) ,(car tally))
43 ((,prog2-name ,prog1-name) ,(cadr tally))))))
45 (define (score-game spec prog1 prog2)
46 (let* ((core (make-core (spec-core-size spec)))
47 (queues (install-progs core (list prog1 prog2)))
48 (result (run-mars core queues (spec-game-length spec))))
50 ((null? result) (error "Invalid game result."))
51 ((= (length result) 1)
52 (let ((winner-name (caar result)))
53 (if (eq? winner-name (prog-name prog1))
59 (define (challenge hill-dir challenger-file)
60 (let* ((spec (load-spec hill-dir))
61 (scores (load-scores hill-dir))
62 (challenger-prog (file->prog challenger-file))
63 (hill-progs (map file->prog (hill-files hill-dir))))
64 (if (memq (prog-name challenger-prog) (map prog-name hill-progs))
65 (print "Challenger already on hill!")
66 (let ((new-scores (append (score-challenger-matches spec challenger-prog hill-progs)
68 (save-scores new-scores hill-dir)
69 (hill-add-file challenger-file (prog-name challenger-prog) hill-dir)))))
72 ;;; Hill initialization and specs
75 (define (load-scores dir)
76 (with-input-from-file (make-pathname dir "scores") read))
78 (define (save-scores scores dir)
79 (with-output-to-file (make-pathname dir "scores")
80 (lambda () (pretty-print scores))))
82 (define (load-spec dir)
83 (with-input-from-file (make-pathname dir "spec") read))
85 (define (hill-files dir)
86 (glob (make-pathname dir "*.red")))
88 (define (hill-add-file file name dir)
89 (copy-file file (make-pathname dir (->string name) ".red")))
91 (define (make-spec core-size match-length games-per-match hill-size)
92 (list 'spec hill-size core-size match-length games-per-match))
95 (and (pair? spec) (eq? (car spec) 'spec)))
97 (define (spec-hill-size spec) (list-ref spec 1))
98 (define (spec-core-size spec) (list-ref spec 2))
99 (define (spec-game-length spec) (list-ref spec 3))
100 (define (spec-games-per-match spec) (list-ref spec 4))
102 (define (init-hill-dir dir hill-size core-size game-length games-per-match)
103 (if (or (not (directory-exists? dir)) (not (file-writable? dir)))
104 (print "Directory " dir " doesn't exist or is not writable.")
105 (if (not (null? (glob (make-pathname dir "*"))))
106 (print "Directory " dir " exists but is non-empty.")
108 (with-output-to-file (make-pathname dir "spec")
110 (print ";; Hill specifications.")
111 (print ";; ('spec hill-size core-size game-length games-per-match\n")
112 (pp (make-spec core-size game-length games-per-match hill-size))))
113 (with-output-to-file (make-pathname dir "scores")
121 (define default-core-size 8000)
122 (define default-game-length 80000)
123 (define default-games-per-match 1)
124 (define default-hill-size 10)
126 (define (print-usage)
127 (let ((binary (pathname-file (car (argv)))))
128 (print "King of the Hill Tournament Manager")
129 (print "\nUsage:\t" binary " hill-directory challenger-file")
130 (print "\t" binary " [-h|--help]")
131 (print "\t" binary " [-i|--init] hill-directory [hill-size [core-size game-length games-per-match]]")
132 (print "\nDefault values are as follows:\n"
133 "\thill-size: " default-hill-size "\n"
134 "\tcore-size: " default-core-size "\n"
135 "\tgame-length: " default-game-length "\n"
136 "\tgames-per-match: " default-games-per-match)))
140 ((or () ((or "-h" "--help")))
142 (((or "-i" "--init") dir hill-size core-size game-length games-per-match)
143 (init-hill-dir dir hill-size core-size game-length games-per-match))
144 (((or "-i" "--init") dir)
149 default-games-per-match))
150 (((or "-i" "--init") dir hill-size)
155 default-games-per-match))
156 ((hill-dir challenger-file)
157 (challenge hill-dir challenger-file))
159 (print "Invalid arguments: " (apply conc else)))))