From 7a4ae6a55e8bd93b9b08bbec346caad7b1c2e83d Mon Sep 17 00:00:00 2001
From: plugd <plugd@thelambdalab.xyz>
Date: Sun, 24 Nov 2019 12:19:41 +0100
Subject: [PATCH] Working on KOTH.

---
 koth.scm | 93 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 93 insertions(+)
 create mode 100644 koth.scm

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)
-- 
2.20.1