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 (score-challenger-matches spec 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        (score-match spec challenger-prog other-prog))
  27      other-progs)))
  28
  29 (define (score-match spec prog1 prog2)
  30   (let ((tally
  31          (foldl
  32           (lambda (score-a score-b)
  33             (list (+ (car score-a) (car score-b))
  34                   (+ (cadr score-a) (cadr score-b))))
  35           (list 0 0)
  36           (let loop ((remaining (spec-games-per-match spec)))
  37             (loop (- remaining 1))))))
  38     `((,(prog-name prog1 ,(car tally)))
  39       (,(prog-name prog2 ,(cadr tally))))))
  40
  41 (define (score-game spec prog1 prog2)
  42   (let* ((core (make-core (spec-core-size spec) INITIAL-INSTR))
  43          (queues (install-progs core (list prog1 prog2)))
  44          (result (run-mars core queues (spec-game-length spec))))
  45     (cond
  46           ((null? result) (error "Invalid game result."))
  47           ((= (length result) 1)
  48            (let ((winner-name (caar result)))
  49              (if (eq? winner-name name1)
  50                  '(3 0)
  51                  '(0 3))))
  52           (else
  53            '(1 1)))))
  54
  55 (define (count-scores-for-progs progs)
  56   (map (lambda (prog)
  57          (count-scores-for-name scores (prog-name prog)))
  58        progs))
  59
  60 (define (count-scores-for-name scores name)
  61   (let loop ((score 0)
  62              (remaining-scores scores))
  63     (if (null? remaining-scores)
  64         score
  65         (loop
  66          (let ((this-score (car remaining-scores)))
  67            (cond
  68             ((eq? (caar this-score) name)
  69              (loop (+ score (cadar this-score)) (cdr remaining-scores)))
  70             ((eq? (caadr this-score) name)
  71              (loop (+ score (cadadr this-score)) (cdr remaining-scores)))))))))
  72
  73 ;;; Hill initialization and specs
  74 ;;
  75
  76 (define (load-scores dir)
  77   (with-input-from-file (make-pathname dir "scores") read))
  78
  79 (define (load-specs dir)
  80   (with-input-from-file (make-pathname dir "specs") read))
  81
  82 (define (make-specs core-size match-length games-per-match hill-size)
  83   (list 'specs hill-size core-size match-length games-per-match))
  84
  85 (define (specs? specs)
  86   (and (pair? specs) (eq? (car specs) 'specs)))
  87
  88 (define (specs-hill-size specs) (list-ref specs 1))
  89 (define (specs-core-size specs) (list-ref specs 2))
  90 (define (specs-game-length specs) (list-ref specs 3))
  91 (define (specs-games-per-match specs) (list-ref specs 4))
  92
  93 (define (init-hill-dir dir hill-size core-size game-length games-per-match)
  94   (if (or (not (directory-exists? dir)) (not (file-writable? dir)))
  95       (print "Directory " dir " doesn't exist or is not writable.")
  96       (if (not (null? (glob (make-pathname dir "*"))))
  97           (print "Directory " dir " exists but is non-empty.")
  98           (with-output-to-file (make-pathname dir "specs")
  99             (lambda ()
 100               (print ";; Hill specifications.")
 101               (print ";; ('specs hill-size core-size game-length games-per-match\n")
 102               (pp (make-specs core-size game-length games-per-match hill-size))))
 103           (with-output-to-file (make-pathname dir "scores")
 104             (lambda ()
 105               (pp '()))))))
 106
 107 ;;;; Main ;;;;
 108
 109 ;; Default values
 110
 111 (define default-core-size 8000)
 112 (define default-game-length 80000)
 113 (define default-games-per-match 1)
 114 (define default-hill-size 10)
 115
 116
 117
 118 (define (print-usage)
 119   (let ((binary (pathname-file (car (argv)))))
 120     (print "King of the Hill Tournament Manager")
 121     (print "\nUsage:\t" binary " hill-directory challenger-file")
 122     (print "\t" binary " [-h|--help]")
 123     (print "\t" binary " [-i|--init] hill-directory [hill-size [core-size game-length games-per-match]]")
 124     (print "\nDefault values are as follows:\n"
 125            "\thill-size: " default-hill-size "\n"
 126            "\tcore-size: " default-core-size "\n"
 127            "\tgame-length: " default-game-length "\n"
 128            "\tgames-per-match: " default-games-per-match)))
 129
 130 (define (process-args args)
 131   (match args
 132     ((or () ((or "-h" "--help")))
 133      (print-usage))
 134     (((or "-i" "--init") dir hill-size core-size game-length games-per-match)
 135      (init-hill-dir dir hill-size core-size game-length games-per-match))
 136     (((or "-i" "--init") dir)
 137      (init-hill-dir dir
 138                     default-hill-size
 139                     default-core-size
 140                     default-game-length
 141                     default-games-per-match))
 142     (((or "-i" "--init") dir hill-size)
 143      (init-hill-dir dir
 144                     hill-size
 145                     default-core-size
 146                     default-game-length
 147                     default-games-per-match))
 148     ((hill-dir challenger-file)
 149      (print "Not implemented"))
 150     (else
 151      (print "Invalid arguments: " (apply conc else)))))
 152
 153 (define (main)
 154   (process-args (cdr (argv))))
 155
 156 (main)