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 (run-all-matches 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 (let ((other-name (prog-name other-prog))
27 (result (run-match challenger-prog other-prog)))
28 (cond ((or (= (length result) 2)
29 (= (length result) 0))
30 `((,challenger-name 1) (,other-name 1)))
31 ((eq? (queue-name (car result)) challenger-name)
32 `((,challenger-name 3) (,other-name 0)))
34 `((,challenger-name 0) (,other-name 3))))))
37 (define (run-match spec . progs)
38 (let loop ((remaining (spec-games-per-match spec)))
39 (let* ((core (make-core (spec-core-size spec) INITIAL-INSTR))
40 (queues (install-progs core (list challenger-prog other-prog))))
41 (run-mars core queues))
42 (loop (- remaining 1))))
44 ;;; Score keeping and specs
47 (define (load-scores dir)
48 (with-input-from-file (make-pathname dir "scores") read))
50 (define (load-specs dir)
51 (with-input-from-file (make-pathname dir "specs") read))
53 (define (make-specs core-size match-length games-per-match hill-size)
54 (list 'specs hill-size core-size match-length games-per-match))
56 (define (specs? specs)
57 (and (pair? specs) (eq? (car specs) 'specs)))
59 (define (specs-hill-size specs) (list-ref specs 1))
60 (define (specs-core-size specs) (list-ref specs 2))
61 (define (specs-game-length specs) (list-ref specs 3))
62 (define (specs-games-per-match specs) (list-ref specs 4))
64 (define (init-hill-dir dir hill-size core-size game-length games-per-match)
65 (if (or (not (directory-exists? dir)) (not (file-writable? dir)))
66 (print "Directory " dir " doesn't exist or is not writable.")
67 (if (not (null? (glob (make-pathname dir "*"))))
68 (print "Directory " dir " exists but is non-empty.")
69 (with-output-to-file (make-pathname dir "specs")
71 (print ";; Hill specifications.")
72 (print ";; ('specs hill-size core-size game-length games-per-match\n")
73 (pp (make-specs core-size game-length games-per-match hill-size))))
74 (with-output-to-file (make-pathname dir "scores")
82 (define default-core-size 8000)
83 (define default-game-length 80000)
84 (define default-games-per-match 1)
85 (define default-hill-size 10)
90 (let ((binary (pathname-file (car (argv)))))
91 (print "King of the Hill Tournament Manager")
92 (print "\nUsage:\t" binary " hill-directory challenger-file")
93 (print "\t" binary " [-h|--help]")
94 (print "\t" binary " [-i|--init] hill-directory [hill-size [core-size game-length games-per-match]]")
95 (print "\nDefault values are as follows:\n"
96 "\thill-size: " default-hill-size "\n"
97 "\tcore-size: " default-core-size "\n"
98 "\tgame-length: " default-game-length "\n"
99 "\tgames-per-match: " default-games-per-match)))
101 (define (process-args args)
103 ((or () ((or "-h" "--help")))
105 (((or "-i" "--init") dir hill-size core-size game-length games-per-match)
106 (init-hill-dir dir hill-size core-size game-length games-per-match))
107 (((or "-i" "--init") dir)
112 default-games-per-match))
113 (((or "-i" "--init") dir hill-size)
118 default-games-per-match))
119 ((hill-dir challenger-file)
120 (print "Not implemented"))
122 (print "Invalid arguments: " (apply conc else)))))
125 (process-args (cdr (argv))))