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