From 6d7d7aac5eb776f36025d5c0b33d83e6bb1c6640 Mon Sep 17 00:00:00 2001 From: plugd Date: Mon, 11 May 2020 09:20:56 +0200 Subject: [PATCH] KOTH almost functional. --- README | 2 +- koth.scm | 82 +++++++++++++++++++++++++++++++++++++----------------- parser.scm | 20 +++++++++++++ 3 files changed, 78 insertions(+), 26 deletions(-) diff --git a/README b/README index 17f8560..db77f31 100644 --- a/README +++ b/README @@ -34,4 +34,4 @@ License JaRS is free software, and is distributed under the terms of version 3 of the GNU General Public License. A copy of this license can be found in -the file named COPYING. \ No newline at end of file +the file named COPYING. diff --git a/koth.scm b/koth.scm index 3ad5925..a9c1a84 100644 --- a/koth.scm +++ b/koth.scm @@ -6,6 +6,7 @@ (chicken string) (chicken pretty-print) (chicken sort) + (chicken time posix) srfi-1 matchable mars parser) @@ -25,7 +26,7 @@ other-progs))) (define (score-match spec prog1 prog2) - (print "Matching " (prog-name prog1) " against " (prog-name prog2)) + (print "... Matching " (prog-name prog1) " against " (prog-name prog2)) (let ((tally (foldl (lambda (score-a score-b) @@ -76,24 +77,39 @@ (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)))) - (if (member (prog-name challenger-prog) (map prog-name hill-progs)) - (print "Challenger already on hill!") + (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 - (save-hill-scores-and-rankings new-scores rankings hill-dir) - (hill-add-file challenger-file (prog-name challenger-prog) hill-dir)) - (let ((loser (caar rankings))) - (save-hill-scores-and-rankings (filter (lambda (score) - (not (or (equal? (car score) loser) - (equal? (cadr score) loser)))) + (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-dir) - (hill-remove loser hill-dir))))))) + (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 @@ -102,11 +118,12 @@ (define (hill-scores dir) (with-input-from-file (make-pathname dir "scores") read)) -(define (save-hill-scores-and-rankings scores rankings dir) - (with-output-to-file (make-pathname dir "scores") - (lambda () (pretty-print scores))) - (with-output-to-file (make-pathname dir "rankings") - (lambda () (pretty-print rankings)))) +(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)) @@ -117,10 +134,21 @@ (define (hill-rankings dir) (with-input-from-file (make-pathname dir "rankings") read)) -(define (hill-add-file file name dir) +(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-file name dir) +(define (hill-remove dir name) (delete-file (make-pathname dir name ".red"))) (define (make-spec core-size match-length games-per-match hill-size) @@ -145,10 +173,10 @@ (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 '()))) - (with-output-to-file (make-pathname dir "rankings") - (lambda () (pp '()))))))) + (hill-save-scores-and-rankings dir '() '()) + (with-output-to-file (make-pathname dir "news") + (lambda () (print '()))) + (hill-news-add dir "Hill created."))))) ;;;; Main ;;;; @@ -177,7 +205,11 @@ ((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 @@ -186,7 +218,7 @@ 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)) diff --git a/parser.scm b/parser.scm index 7bc3f90..f116033 100644 --- a/parser.scm +++ b/parser.scm @@ -56,6 +56,7 @@ (mode-post-indirect-A-irx (irregex "^\\}")) (mode-post-indirect-B-irx (irregex "^>")) (number-irx (irregex "^(\\+|-)?[0-9]+"))) + (define (accept-token irx . rest) (let ((wsmatch (irregex-search whitespace-irx (substring str idx)))) (if wsmatch @@ -69,6 +70,7 @@ (if mandatory (error "Unexpected token at input string index" idx) #f)))) + (define (load-file) (accept-token redcode-irx #t) (let loop ((instrs '()) @@ -84,28 +86,34 @@ ((org) (loop instrs (cdr this-line) name author)) ((instr) (loop (cons (cdr this-line) instrs) offset name author))) (make-prog name author (reverse instrs) offset))))) + (define (line) (or (name-line) (author-line) (comment-line) (org-line) (instruction-line))) + (define (name-line) (if (accept-token name-start-irx) (cons 'name (string-trim (accept-token name-irx #t))) #f)) + (define (author-line) (if (accept-token author-start-irx) (cons 'author (string-trim (accept-token author-irx #t))) #f)) + (define (comment-line) (if (accept-token comment-irx) '(comment) #f)) + (define (org-line) (if (accept-token org-irx) (cons 'org (string->number (accept-token number-irx #t))) #f)) + (define (instruction-line) (let ((oc (opcode))) (if oc @@ -119,6 +127,7 @@ (z (accept-token comment-irx #t))) (cons 'instr (make-instr oc modif A-mode A-num B-mode B-num))) #f))) + (define (opcode) (let ((res (or (accept-token opcode-DAT-irx) (accept-token opcode-MOV-irx) @@ -138,6 +147,7 @@ (accept-token opcode-SPL-irx) (accept-token opcode-NOP-irx)))) (if res (string->symbol res) #f))) + (define (modifier) (string->symbol (or (accept-token modifier-AB-irx) @@ -147,6 +157,7 @@ (accept-token modifier-F-irx) (accept-token modifier-X-irx) (accept-token modifier-I-irx)))) + (define (mode) (or (mode-immediate) (mode-direct) @@ -156,28 +167,37 @@ (mode-pre-indirect-B) (mode-post-indirect-A) (mode-post-indirect-B))) + (define (mode-immediate) (and (accept-token mode-immediate-irx) 'immediate)) + (define (mode-direct) (and (accept-token mode-direct-irx) 'direct)) + (define (mode-indirect-A) (and (accept-token mode-indirect-A-irx) 'indirect-A)) + (define (mode-indirect-B) (and (accept-token mode-indirect-B-irx) 'indirect-B)) + (define (mode-pre-indirect-A) (and (accept-token mode-pre-indirect-A-irx) 'pre-indirect-A)) + (define (mode-pre-indirect-B) (and (accept-token mode-pre-indirect-B-irx) 'pre-indirect-B)) + (define (mode-post-indirect-A) (and (accept-token mode-post-indirect-A-irx) 'post-indirect-A)) + (define (mode-post-indirect-B) (and (accept-token mode-post-indirect-B-irx) 'post-indirect-B)) + (load-file)))) -- 2.20.1