From: plugd Date: Sun, 24 Nov 2019 11:19:41 +0000 (+0100) Subject: Working on KOTH. X-Git-Url: https://thelambdalab.xyz/gitweb/index.cgi?a=commitdiff_plain;h=7a4ae6a55e8bd93b9b08bbec346caad7b1c2e83d;p=jars.git Working on KOTH. --- diff --git a/koth.scm b/koth.scm new file mode 100644 index 0000000..1ca77c3 --- /dev/null +++ b/koth.scm @@ -0,0 +1,93 @@ +(import (chicken process-context) + (chicken file) + (chicken pathname) + (chicken string) + (chicken pretty-print) + matchable + mars parser) + +(define CORE-SIZE 8000) +(define GAMES-PER-MATCH 1) +(define INITIAL-INSTR (make-instr 'DAT 'F 'immediate 0 'immediate 0)) + +(define (file->prog file) + (string->prog (with-input-from-file fname read))) + +(define (run-all-challenges 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 . progs) + (let* ((core (make-core CORE-SIZE INITIAL-INSTR)) + (queues (install-progs core (list challenger-prog other-prog)))) + (run-mars core queues))) + +;;; Score keeping +;; + +(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))))))) + +;;;; Main ;;;; + +(define (print-usage) + (let ((binary (pathname-file (car (argv))))) + (print "King of the Hill Tournament Manager") + (print "Usage:\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]]"))) + +(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 10 8000 80000 10)) + (((or "-i" "--init") dir hill-size) + (init-hill-dir dir hill-size 8000 80000 10)) + ((hill-dir challenger-file) + (print "Not implemented")) + (else + (print "Invalid arguments: " (apply conc else))))) + +(define (main) + (process-args (cdr (argv)))) + +(main)