1 (import (chicken process-context)
9 (define CORE-SIZE 8000)
10 (define GAMES-PER-MATCH 1)
11 (define INITIAL-INSTR (make-instr 'DAT 'F 'immediate 0 'immediate 0))
13 (define (file->prog file)
14 (string->prog (with-input-from-file fname read)))
16 (define (run-all-challenges challenger-file other-files)
17 (let ((challenger-prog (file->prog challenger-file))
18 (challenger-name (prog-name challenger-prog))
19 (other-progs (apply file->prog other-files)))
22 (let ((other-name (prog-name other-prog))
23 (result (run-match challenger-prog other-prog)))
24 (cond ((or (= (length result) 2)
25 (= (length result) 0))
26 `((,challenger-name 1) (,other-name 1)))
27 ((eq? (queue-name (car result)) challenger-name)
28 `((,challenger-name 3) (,other-name 0)))
30 `((,challenger-name 0) (,other-name 3))))))
33 (define (run-match . progs)
34 (let* ((core (make-core CORE-SIZE INITIAL-INSTR))
35 (queues (install-progs core (list challenger-prog other-prog))))
36 (run-mars core queues)))
41 (define (load-specs dir)
42 (with-input-from-file (make-pathname dir "specs") read))
44 (define (make-specs core-size match-length games-per-match hill-size)
45 (list 'specs hill-size core-size match-length games-per-match))
47 (define (specs? specs)
48 (and (pair? specs) (eq? (car specs) 'specs)))
50 (define (specs-hill-size specs) (list-ref specs 1))
51 (define (specs-core-size specs) (list-ref specs 2))
52 (define (specs-game-length specs) (list-ref specs 3))
53 (define (specs-games-per-match specs) (list-ref specs 4))
55 (define (init-hill-dir dir hill-size core-size game-length games-per-match)
56 (if (or (not (directory-exists? dir)) (not (file-writable? dir)))
57 (print "Directory " dir " doesn't exist or is not writable.")
58 (if (not (null? (glob (make-pathname dir "*"))))
59 (print "Directory " dir " exists but is non-empty.")
60 (with-output-to-file (make-pathname dir "specs")
62 (print ";; Hill specifications.")
63 (print ";; ('specs hill-size core-size game-length games-per-match\n")
64 (pp (make-specs core-size game-length games-per-match hill-size)))))))
69 (let ((binary (pathname-file (car (argv)))))
70 (print "King of the Hill Tournament Manager")
71 (print "Usage:\t" binary " hill-directory challenger-file")
72 (print "\t" binary " [-h|--help]")
73 (print "\t" binary " [-i|--init] hill-directory [hill-size [core-size game-length games-per-match]]")))
75 (define (process-args args)
77 ((or () ((or "-h" "--help")))
79 (((or "-i" "--init") dir hill-size core-size game-length games-per-match)
80 (init-hill-dir dir hill-size core-size game-length games-per-match))
81 (((or "-i" "--init") dir)
82 (init-hill-dir dir 10 8000 80000 10))
83 (((or "-i" "--init") dir hill-size)
84 (init-hill-dir dir hill-size 8000 80000 10))
85 ((hill-dir challenger-file)
86 (print "Not implemented"))
88 (print "Invalid arguments: " (apply conc else)))))
91 (process-args (cdr (argv))))