(import (chicken process-context) (chicken file) (chicken pathname) (chicken string) (chicken pretty-print) matchable mars parser) ;;; Constants ;; (define INITIAL-INSTR (make-instr 'DAT 'F 'immediate 0 'immediate 0)) ;;; Games and Matches ;; (define (file->prog file) (string->prog (with-input-from-file fname read))) (define (score-challenger-matches spec challenger-file other-files) (let ((challenger-prog (file->prog challenger-file)) (challenger-name (prog-name challenger-prog)) (other-progs (apply file->prog other-files))) (map (lambda (other-prog) (score-match spec challenger-prog other-prog)) other-progs))) (define (score-match spec prog1 prog2) (let ((tally (foldl (lambda (score-a score-b) (list (+ (car score-a) (car score-b)) (+ (cadr score-a) (cadr score-b)))) (list 0 0) (let loop ((remaining (spec-games-per-match spec))) (loop (- remaining 1)))))) `((,(prog-name prog1 ,(car tally))) (,(prog-name prog2 ,(cadr tally)))))) (define (score-game spec prog1 prog2) (let* ((core (make-core (spec-core-size spec) INITIAL-INSTR)) (queues (install-progs core (list prog1 prog2))) (result (run-mars core queues (spec-game-length spec)))) (cond ((null? result) (error "Invalid game result.")) ((= (length result) 1) (let ((winner-name (caar result))) (if (eq? winner-name name1) '(3 0) '(0 3)))) (else '(1 1))))) (define (count-scores-for-progs progs) (map (lambda (prog) (count-scores-for-name scores (prog-name prog))) progs)) (define (count-scores-for-name scores name) (let loop ((score 0) (remaining-scores scores)) (if (null? remaining-scores) score (loop (let ((this-score (car remaining-scores))) (cond ((eq? (caar this-score) name) (loop (+ score (cadar this-score)) (cdr remaining-scores))) ((eq? (caadr this-score) name) (loop (+ score (cadadr this-score)) (cdr remaining-scores))))))))) ;;; Hill initialization and specs ;; (define (load-scores dir) (with-input-from-file (make-pathname dir "scores") read)) (define (load-specs dir) (with-input-from-file (make-pathname dir "specs") read)) (define (make-specs core-size match-length games-per-match hill-size) (list 'specs hill-size core-size match-length games-per-match)) (define (specs? specs) (and (pair? specs) (eq? (car specs) 'specs))) (define (specs-hill-size specs) (list-ref specs 1)) (define (specs-core-size specs) (list-ref specs 2)) (define (specs-game-length specs) (list-ref specs 3)) (define (specs-games-per-match specs) (list-ref specs 4)) (define (init-hill-dir dir hill-size core-size game-length games-per-match) (if (or (not (directory-exists? dir)) (not (file-writable? dir))) (print "Directory " dir " doesn't exist or is not writable.") (if (not (null? (glob (make-pathname dir "*")))) (print "Directory " dir " exists but is non-empty.") (with-output-to-file (make-pathname dir "specs") (lambda () (print ";; Hill specifications.") (print ";; ('specs hill-size core-size game-length games-per-match\n") (pp (make-specs core-size game-length games-per-match hill-size)))) (with-output-to-file (make-pathname dir "scores") (lambda () (pp '())))))) ;;;; Main ;;;; ;; Default values (define default-core-size 8000) (define default-game-length 80000) (define default-games-per-match 1) (define default-hill-size 10) (define (print-usage) (let ((binary (pathname-file (car (argv))))) (print "King of the Hill Tournament Manager") (print "\nUsage:\t" binary " hill-directory challenger-file") (print "\t" binary " [-h|--help]") (print "\t" binary " [-i|--init] hill-directory [hill-size [core-size game-length games-per-match]]") (print "\nDefault values are as follows:\n" "\thill-size: " default-hill-size "\n" "\tcore-size: " default-core-size "\n" "\tgame-length: " default-game-length "\n" "\tgames-per-match: " default-games-per-match))) (define (process-args args) (match args ((or () ((or "-h" "--help"))) (print-usage)) (((or "-i" "--init") dir hill-size core-size game-length games-per-match) (init-hill-dir dir hill-size core-size game-length games-per-match)) (((or "-i" "--init") dir) (init-hill-dir dir default-hill-size default-core-size default-game-length default-games-per-match)) (((or "-i" "--init") dir hill-size) (init-hill-dir dir hill-size default-core-size default-game-length default-games-per-match)) ((hill-dir challenger-file) (print "Not implemented")) (else (print "Invalid arguments: " (apply conc else))))) (define (main) (process-args (cdr (argv)))) (main)