X-Git-Url: https://thelambdalab.xyz/gitweb/index.cgi?p=jars.git;a=blobdiff_plain;f=koth.scm;h=45e4bb8fe5b7e486b15fa97e4da9053088579cbd;hp=c14008dd45f86d139d1eaeff0948cd0d9b2d5bad;hb=7281b0c1eefce213d11cada1cb9f86a2d8fb0779;hpb=d4f97cb3c89307474ca8eaa812b739af35c2b7f3 diff --git a/koth.scm b/koth.scm index c14008d..45e4bb8 100644 --- a/koth.scm +++ b/koth.scm @@ -1,79 +1,182 @@ -(import (chicken process-context) - (chicken file) - (chicken pathname) - (chicken string) - (chicken pretty-print) - matchable - mars parser) - -;;; Constants -;; +(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) -(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 (run-all-matches 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) - (let ((other-name (prog-name other-prog)) - (result (run-match challenger-prog other-prog))) - (cond ((or (= (length result) 2) - (= (length result) 0)) - `((,challenger-name 1) (,other-name 1))) - ((eq? (queue-name (car result)) challenger-name) - `((,challenger-name 3) (,other-name 0))) - (else - `((,challenger-name 0) (,other-name 3)))))) - other-progs))) - -(define (run-match spec . progs) - (let loop ((remaining (spec-games-per-match spec))) - (let* ((core (make-core (spec-core-size spec) INITIAL-INSTR)) - (queues (install-progs core (list challenger-prog other-prog)))) - (run-mars core queues)) - (loop (- remaining 1)))) - -;;; Score keeping and specs + (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 (load-scores dir) +(define (hill-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 (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 (make-specs core-size match-length games-per-match hill-size) - (list 'specs hill-size core-size match-length games-per-match)) +(define (hill-add dir file name) + (copy-file file (make-pathname dir (->string name) ".red"))) -(define (specs? specs) - (and (pair? specs) (eq? (car specs) 'specs))) +(define (hill-remove dir name) + (delete-file (make-pathname dir name ".red"))) -(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 (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.") - (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 '())))))) + (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 ;;;; @@ -81,15 +184,14 @@ (define default-core-size 8000) (define default-game-length 80000) -(define default-games-per-match 1) +(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" @@ -98,12 +200,16 @@ "\tgame-length: " default-game-length "\n" "\tgames-per-match: " default-games-per-match))) -(define (process-args args) - (match args +(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 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 @@ -112,16 +218,21 @@ default-games-per-match)) (((or "-i" "--init") dir hill-size) (init-hill-dir dir - hill-size + (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) - (print "Not implemented")) + (challenge hill-dir challenger-file)) (else (print "Invalid arguments: " (apply conc else))))) -(define (main) - (process-args (cdr (argv)))) - (main)