koth.scm

   1 (import
   2   (chicken io)
   3   (chicken process-context)
   4   (chicken file)
   5   (chicken pathname)
   6   (chicken string)
   7   (chicken pretty-print)
   8   srfi-1
   9   matchable
  10   mars parser)
  11
  12
  13 ;;; Games and Matches
  14 ;;
  15
  16 (define (file->prog file)
  17   (string->prog (with-input-from-file file read-string)))
  18
  19 (define (score-challenger-matches spec challenger-prog other-progs)
  20   (map
  21    (lambda (other-prog)
  22      (score-match spec challenger-prog other-prog))
  23    other-progs))
  24
  25 (define (score-match spec prog1 prog2)
  26   (print "Matching " (prog-name prog1) " against " (prog-name prog2))
  27   (let ((tally
  28          (foldl
  29           (lambda (score-a score-b)
  30             (list (+ (car score-a) (car score-b))
  31                   (+ (cadr score-a) (cadr score-b))))
  32           (list 0 0)
  33           (let loop ((remaining (spec-games-per-match spec))
  34                      (results '()))
  35             (if (> remaining 0)
  36                 (loop (- remaining 1)
  37                       (cons (score-game spec prog1 prog2)
  38                             results))
  39                 results)))))
  40     (let ((prog1-name (prog-name prog1))
  41           (prog2-name (prog-name prog2)))
  42       `(((,prog1-name ,prog2-name) ,(car tally))
  43         ((,prog2-name ,prog1-name) ,(cadr tally))))))
  44
  45 (define (score-game spec prog1 prog2)
  46   (let* ((core (make-core (spec-core-size spec)))
  47          (queues (install-progs core (list prog1 prog2)))
  48          (result (run-mars core queues (spec-game-length spec))))
  49     (cond
  50           ((null? result) (error "Invalid game result."))
  51           ((= (length result) 1)
  52            (let ((winner-name (caar result)))
  53              (if (eq? winner-name (prog-name prog1))
  54                  '(3 0)
  55                  '(0 3))))
  56           (else
  57            '(1 1)))))
  58
  59 (define (challenge hill-dir challenger-file)
  60   (let* ((spec (load-spec hill-dir))
  61          (scores (load-scores hill-dir))
  62          (challenger-prog (file->prog challenger-file))
  63          (hill-progs (map file->prog (hill-files hill-dir))))
  64     (if (memq (prog-name challenger-prog) (map prog-name hill-progs))
  65         (print "Challenger already on hill!")
  66         (let ((new-scores (append (score-challenger-matches spec challenger-prog hill-progs)
  67                                   scores)))
  68           (save-scores new-scores hill-dir)
  69           (hill-add-file challenger-file (prog-name challenger-prog) hill-dir)))))
  70
  71
  72 ;;; Hill initialization and specs
  73 ;;
  74
  75 (define (load-scores dir)
  76   (with-input-from-file (make-pathname dir "scores") read))
  77
  78 (define (save-scores scores dir)
  79   (with-output-to-file (make-pathname dir "scores")
  80     (lambda () (pretty-print scores))))
  81
  82 (define (load-spec dir)
  83   (with-input-from-file (make-pathname dir "spec") read))
  84
  85 (define (hill-files dir)
  86   (glob (make-pathname dir "*.red")))
  87
  88 (define (hill-add-file file name dir)
  89   (copy-file file (make-pathname dir (->string name) ".red")))
  90
  91 (define (make-spec core-size match-length games-per-match hill-size)
  92   (list 'spec hill-size core-size match-length games-per-match))
  93
  94 (define (spec? spec)
  95   (and (pair? spec) (eq? (car spec) 'spec)))
  96
  97 (define (spec-hill-size spec) (list-ref spec 1))
  98 (define (spec-core-size spec) (list-ref spec 2))
  99 (define (spec-game-length spec) (list-ref spec 3))
 100 (define (spec-games-per-match spec) (list-ref spec 4))
 101
 102 (define (init-hill-dir dir hill-size core-size game-length games-per-match)
 103   (if (or (not (directory-exists? dir)) (not (file-writable? dir)))
 104       (print "Directory " dir " doesn't exist or is not writable.")
 105       (if (not (null? (glob (make-pathname dir "*"))))
 106           (print "Directory " dir " exists but is non-empty.")
 107           (begin
 108             (with-output-to-file (make-pathname dir "spec")
 109               (lambda ()
 110                 (print ";; Hill specifications.")
 111                 (print ";; ('spec hill-size core-size game-length games-per-match\n")
 112                 (pp (make-spec core-size game-length games-per-match hill-size))))
 113             (with-output-to-file (make-pathname dir "scores")
 114               (lambda ()
 115                 (pp '())))))))
 116
 117 ;;;; Main ;;;;
 118
 119 ;; Default values
 120
 121 (define default-core-size 8000)
 122 (define default-game-length 80000)
 123 (define default-games-per-match 1)
 124 (define default-hill-size 10)
 125
 126 (define (print-usage)
 127   (let ((binary (pathname-file (car (argv)))))
 128     (print "King of the Hill Tournament Manager")
 129     (print "\nUsage:\t" binary " hill-directory challenger-file")
 130     (print "\t" binary " [-h|--help]")
 131     (print "\t" binary " [-i|--init] hill-directory [hill-size [core-size game-length games-per-match]]")
 132     (print "\nDefault values are as follows:\n"
 133            "\thill-size: " default-hill-size "\n"
 134            "\tcore-size: " default-core-size "\n"
 135            "\tgame-length: " default-game-length "\n"
 136            "\tgames-per-match: " default-games-per-match)))
 137
 138 (define (main)
 139   (match (cdr (argv))
 140     ((or () ((or "-h" "--help")))
 141      (print-usage))
 142     (((or "-i" "--init") dir hill-size core-size game-length games-per-match)
 143      (init-hill-dir dir hill-size core-size game-length games-per-match))
 144     (((or "-i" "--init") dir)
 145      (init-hill-dir dir
 146                     default-hill-size
 147                     default-core-size
 148                     default-game-length
 149                     default-games-per-match))
 150     (((or "-i" "--init") dir hill-size)
 151      (init-hill-dir dir
 152                     hill-size
 153                     default-core-size
 154                     default-game-length
 155                     default-games-per-match))
 156     ((hill-dir challenger-file)
 157      (challenge hill-dir challenger-file))
 158     (else
 159      (print "Invalid arguments: " (apply conc else)))))
 160
 161 ;; (main)