koth.scm

   1 (import (chicken process-context)
   2         (chicken file)
   3         (chicken pathname)
   4         (chicken string)
   5         (chicken pretty-print)
   6         matchable
   7         mars parser)
   8
   9 (define INITIAL-INSTR (make-instr 'DAT 'F 'immediate 0 'immediate 0))
  10
  11 (define (file->prog file)
  12   (string->prog (with-input-from-file fname read)))
  13
  14 (define (run-all-challenges challenger-file other-files)
  15   (let ((challenger-prog (file->prog challenger-file))
  16         (challenger-name (prog-name challenger-prog))
  17         (other-progs (apply file->prog other-files)))
  18     (map
  19      (lambda (other-prog)
  20        (let ((other-name (prog-name other-prog))
  21              (result (run-match challenger-prog other-prog)))
  22          (cond ((or (= (length result) 2)
  23                     (= (length result) 0))
  24                 `((,challenger-name 1) (,other-name 1)))
  25                ((eq? (queue-name (car result)) challenger-name)
  26                 `((,challenger-name 3) (,other-name 0)))
  27                (else
  28                 `((,challenger-name 0) (,other-name 3))))))
  29      other-progs)))
  30
  31 (define (run-match . progs)
  32   (let* ((core (make-core CORE-SIZE INITIAL-INSTR))
  33          (queues (install-progs core (list challenger-prog other-prog))))
  34     (run-mars core queues)))
  35
  36 ;;; Score keeping
  37 ;;
  38
  39 (define (load-specs dir)
  40   (with-input-from-file (make-pathname dir "specs") read))
  41
  42 (define (make-specs core-size match-length games-per-match hill-size)
  43   (list 'specs hill-size core-size match-length games-per-match))
  44
  45 (define (specs? specs)
  46   (and (pair? specs) (eq? (car specs) 'specs)))
  47
  48 (define (specs-hill-size specs) (list-ref specs 1))
  49 (define (specs-core-size specs) (list-ref specs 2))
  50 (define (specs-game-length specs) (list-ref specs 3))
  51 (define (specs-games-per-match specs) (list-ref specs 4))
  52
  53 (define (init-hill-dir dir hill-size core-size game-length games-per-match)
  54   (if (or (not (directory-exists? dir)) (not (file-writable? dir)))
  55       (print "Directory " dir " doesn't exist or is not writable.")
  56       (if (not (null? (glob (make-pathname dir "*"))))
  57           (print "Directory " dir " exists but is non-empty.")
  58           (with-output-to-file (make-pathname dir "specs")
  59             (lambda ()
  60               (print ";; Hill specifications.")
  61               (print ";; ('specs hill-size core-size game-length games-per-match\n")
  62               (pp (make-specs core-size game-length games-per-match hill-size)))))))
  63
  64 ;;;; Main ;;;;
  65
  66 ;; Default values
  67
  68 (define default-core-size 8000)
  69 (define default-game-length 80000)
  70 (define default-games-per-match 1)
  71 (define default-hill-size 10)
  72
  73
  74
  75 (define (print-usage)
  76   (let ((binary (pathname-file (car (argv)))))
  77     (print "King of the Hill Tournament Manager")
  78     (print "\nUsage:\t" binary " hill-directory challenger-file")
  79     (print "\t" binary " [-h|--help]")
  80     (print "\t" binary " [-i|--init] hill-directory [hill-size [core-size game-length games-per-match]]")
  81     (print "\nDefault values are as follows:\n"
  82            "\thill-size: " default-hill-size "\n"
  83            "\tcore-size: " default-core-size "\n"
  84            "\tgame-length: " default-game-length "\n"
  85            "\tgames-per-match: " default-games-per-match)))
  86
  87 (define (process-args args)
  88   (match args
  89     ((or () ((or "-h" "--help")))
  90      (print-usage))
  91     (((or "-i" "--init") dir hill-size core-size game-length games-per-match)
  92      (init-hill-dir dir hill-size core-size game-length games-per-match))
  93     (((or "-i" "--init") dir)
  94      (init-hill-dir dir
  95                     default-hill-size
  96                     default-core-size
  97                     default-game-length
  98                     default-games-per-match))
  99     (((or "-i" "--init") dir hill-size)
 100      (init-hill-dir dir
 101                     hill-size
 102                     default-core-size
 103                     default-game-length
 104                     default-games-per-match))
 105     ((hill-dir challenger-file)
 106      (print "Not implemented"))
 107     (else
 108      (print "Invalid arguments: " (apply conc else)))))
 109
 110 (define (main)
 111   (process-args (cdr (argv))))
 112
 113 (main)