(import (chicken io) (chicken process-context) (chicken file) (chicken pathname) (chicken string) (chicken pretty-print) (chicken sort) (chicken time posix) srfi-1 matchable mars parser) ;;; Games and Matches ;; (define (file->prog file) (string->prog (with-input-from-file file read-string))) (define (score-challenger-matches spec challenger-prog other-progs) (foldl append '() (map (lambda (other-prog) (score-match spec challenger-prog other-prog)) other-progs))) (define (score-match spec prog1 prog2) (print "... Matching " (prog-name prog1) " against " (prog-name 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)) (results '())) (if (> remaining 0) (loop (- remaining 1) (cons (score-game spec prog1 prog2) results)) results))))) (let ((prog1-name (prog-name prog1)) (prog2-name (prog-name prog2))) `((,prog1-name ,prog2-name ,(car tally)) (,prog2-name ,prog1-name ,(cadr tally)))))) (define (score-game spec prog1 prog2) (let* ((core (make-core (spec-core-size spec))) (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 (equal? winner-name (prog-name prog1)) '(3 0) '(0 3)))) (else '(1 1))))) (define (scores->rankings scores) (let* ((prog-names (delete-duplicates (map car scores))) (prog-scores (map (lambda (prog-name) (apply + (map caddr (filter (lambda (score) (equal? prog-name (car score))) scores)))) prog-names))) (sort (zip prog-names prog-scores) (lambda (a b) (< (cadr a) (cadr b)))))) (define (challenge hill-dir challenger-file) (let* ((spec (hill-spec hill-dir)) (scores (hill-scores hill-dir)) (challenger-prog (file->prog challenger-file)) (challenger-name (prog-name challenger-prog)) (hill-progs (map file->prog (hill-files hill-dir)))) (hill-news-add hill-dir "Challenger '" challenger-name "' accepted for battle.") (if (member challenger-name (map prog-name hill-progs)) (hill-news-add hill-dir "Challenge aborted: challenger already on hill!") (let* ((new-scores (append (score-challenger-matches spec challenger-prog hill-progs) scores)) (rankings (scores->rankings new-scores))) (if (<= (length rankings) (spec-hill-size spec)) (begin (hill-save-scores-and-rankings hill-dir new-scores rankings) (hill-add hill-dir challenger-file challenger-name) (hill-news-add hill-dir "Challenger '" challenger-name "' added to the hill.")) (let ((loser-name (caar rankings))) (hill-save-scores-and-rankings hill-dir (filter (lambda (score) (not (or (equal? (car score) loser-name) (equal? (cadr score) loser-name)))) new-scores) (cdr rankings)) (hill-add hill-dir challenger-file challenger-name) (hill-remove hill-dir loser-name) (if (equal? loser-name challenger-name) (hill-news-add hill-dir "Challenger '" challenger-name "' failed to best any warrior on the hill.") (begin (hill-news-add hill-dir "Challenger '" challenger-name "' defeated at least one warrior on the hill.") (hill-news-add hill-dir "Warrior '" loser-name "' has been pushed off the hill!"))))))))) ;;; Hill initialization and specs ;; (define (hill-scores dir) (with-input-from-file (make-pathname dir "scores") read)) (define (hill-save-scores-and-rankings dir scores rankings) (for-each (lambda (p) (with-output-to-file (make-pathname dir (car p)) (lambda () (pretty-print (cdr p))))) `(("scores" . ,scores) ("rankings" . ,rankings)))) (define (hill-spec dir) (with-input-from-file (make-pathname dir "spec") read)) (define (hill-files dir) (glob (make-pathname dir "*.red"))) (define (hill-rankings dir) (with-input-from-file (make-pathname dir "rankings") read)) (define (hill-news dir) (with-input-from-file (make-pathname dir "news") read)) (define (hill-news-add dir . args) (let* ((old-news (hill-news dir)) (news-string (apply conc args)) (new-news (cons (cons (seconds->string) news-string) old-news))) (print news-string) (with-output-to-file (make-pathname dir "news") (lambda () (pretty-print new-news))))) (define (hill-add dir file name) (copy-file file (make-pathname dir (->string name) ".red"))) (define (hill-remove dir name) (delete-file (make-pathname dir name ".red"))) (define (make-spec core-size match-length games-per-match hill-size) (list 'spec hill-size core-size match-length games-per-match)) (define (spec? spec) (and (pair? spec) (eq? (car spec) 'spec))) (define (spec-hill-size spec) (list-ref spec 1)) (define (spec-core-size spec) (list-ref spec 2)) (define (spec-game-length spec) (list-ref spec 3)) (define (spec-games-per-match spec) (list-ref spec 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.") (begin (with-output-to-file (make-pathname dir "spec") (lambda () (print ";; Hill specifications.") (print ";; ('spec hill-size core-size game-length games-per-match\n") (pp (make-spec core-size game-length games-per-match hill-size)))) (hill-save-scores-and-rankings dir '() '()) (with-output-to-file (make-pathname dir "news") (lambda () (print '()))) (hill-news-add dir "Hill created."))))) ;;;; Main ;;;; ;; Default values (define default-core-size 8000) (define default-game-length 80000) (define default-games-per-match 3) (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 " [-r|--rankings] hill-directory") (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 (main) (match (cdr (argv)) ((or () ((or "-h" "--help"))) (print-usage)) (((or "-i" "--init") dir hill-size core-size game-length games-per-match) (init-hill-dir dir (string->number hill-size) (string->number core-size) (string->number game-length) (string->number 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 (string->number hill-size) default-core-size default-game-length default-games-per-match)) (((or "-r" "--rankings") dir) (let ((rankings (reverse (hill-rankings dir)))) (if (null? rankings) (print "No warriors on hill!") (begin (print "Warrior" "\t" "Score") (print "-=-=-=-" "\t" "=-=-=") (for-each (lambda (r) (print (car r) "\t\t" (cadr r))) rankings))))) ((hill-dir challenger-file) (challenge hill-dir challenger-file)) (else (print "Invalid arguments: " (apply conc else))))) (main)