From 9f989f466f58a33dd3425da3dbcfaee38bd5fac5 Mon Sep 17 00:00:00 2001 From: plugd Date: Fri, 8 May 2020 09:40:14 +0200 Subject: [PATCH] Settled on score format, challengers now added to hill. --- koth.scm | 145 ++++++++++++++++++++++++++------------------------- run-mars.scm | 1 + 2 files changed, 76 insertions(+), 70 deletions(-) diff --git a/koth.scm b/koth.scm index 2324e9c..c6be230 100644 --- a/koth.scm +++ b/koth.scm @@ -1,74 +1,73 @@ -(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) + 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))) + (string->prog (with-input-from-file file read-string))) -(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-challenger-matches spec challenger-prog other-progs) + (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))) - (loop (- remaining 1)))))) - `((,(prog-name prog1 ,(car tally))) - (,(prog-name prog2 ,(cadr tally)))))) + (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) INITIAL-INSTR)) + (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 (eq? winner-name name1) + (if (eq? winner-name (prog-name prog1)) '(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))))))))) +(define (challenge hill-dir challenger-file) + (let* ((spec (load-spec hill-dir)) + (scores (load-scores hill-dir)) + (challenger-prog (file->prog challenger-file)) + (hill-progs (map file->prog (hill-files hill-dir)))) + (if (memq (prog-name challenger-prog) (map prog-name hill-progs)) + (print "Challenger already on hill!") + (let ((new-scores (append (score-challenger-matches spec challenger-prog hill-progs) + scores))) + (save-scores new-scores hill-dir) + (hill-add-file challenger-file (prog-name challenger-prog) hill-dir))))) + ;;; Hill initialization and specs ;; @@ -76,33 +75,44 @@ (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 (save-scores scores dir) + (with-output-to-file (make-pathname dir "scores") + (lambda () (pretty-print scores)))) + +(define (load-spec dir) + (with-input-from-file (make-pathname dir "spec") read)) + +(define (hill-files dir) + (glob (make-pathname dir "*.red"))) + +(define (hill-add-file file name dir) + (copy-file file (make-pathname dir (->string name) ".red"))) -(define (make-specs core-size match-length games-per-match hill-size) - (list 'specs hill-size core-size match-length games-per-match)) +(define (make-spec core-size match-length games-per-match hill-size) + (list 'spec hill-size core-size match-length games-per-match)) -(define (specs? specs) - (and (pair? specs) (eq? (car specs) 'specs))) +(define (spec? spec) + (and (pair? spec) (eq? (car spec) 'spec))) -(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 (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)))) + (with-output-to-file (make-pathname dir "scores") + (lambda () + (pp '()))))))) ;;;; Main ;;;; @@ -113,8 +123,6 @@ (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") @@ -127,8 +135,8 @@ "\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) @@ -146,11 +154,8 @@ default-game-length default-games-per-match)) ((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) +;; (main) diff --git a/run-mars.scm b/run-mars.scm index db5a8b5..1d04af8 100644 --- a/run-mars.scm +++ b/run-mars.scm @@ -64,4 +64,5 @@ (loop rest iters core-size #f)) ((files ...) (mars-runner files iters core-size visualization))))) + (main) -- 2.20.1