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