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 (hill-spec hill-dir))
  77          (scores (hill-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-hill-scores-and-rankings new-scores rankings hill-dir)
  88                 (hill-add-file challenger-file (prog-name challenger-prog) hill-dir))
  89               (let ((loser (caar rankings)))
  90                 (save-hill-scores-and-rankings (filter (lambda (score)
  91                                                          (not (or (equal? (car score) loser)
  92                                                                   (equal? (cadr score) loser))))
  93                                                        new-scores)
  94                                                (cdr rankings)
  95                                                hill-dir)
  96                 (hill-remove loser hill-dir)))))))
  97
  98
  99 ;;; Hill initialization and specs
 100 ;;
 101
 102 (define (hill-scores dir)
 103   (with-input-from-file (make-pathname dir "scores") read))
 104
 105 (define (save-hill-scores-and-rankings scores rankings dir)
 106   (with-output-to-file (make-pathname dir "scores")
 107     (lambda () (pretty-print scores)))
 108   (with-output-to-file (make-pathname dir "rankings")
 109     (lambda () (pretty-print rankings))))
 110
 111 (define (hill-spec dir)
 112   (with-input-from-file (make-pathname dir "spec") read))
 113
 114 (define (hill-files dir)
 115   (glob (make-pathname dir "*.red")))
 116
 117 (define (hill-rankings dir)
 118   (with-input-from-file (make-pathname dir "rankings") read))
 119
 120 (define (hill-add-file file name dir)
 121   (copy-file file (make-pathname dir (->string name) ".red")))
 122
 123 (define (hill-remove-file name dir)
 124   (delete-file (make-pathname dir name ".red")))
 125
 126 (define (make-spec core-size match-length games-per-match hill-size)
 127   (list 'spec hill-size core-size match-length games-per-match))
 128
 129 (define (spec? spec)
 130   (and (pair? spec) (eq? (car spec) 'spec)))
 131
 132 (define (spec-hill-size spec) (list-ref spec 1))
 133 (define (spec-core-size spec) (list-ref spec 2))
 134 (define (spec-game-length spec) (list-ref spec 3))
 135 (define (spec-games-per-match spec) (list-ref spec 4))
 136
 137 (define (init-hill-dir dir hill-size core-size game-length games-per-match)
 138   (if (or (not (directory-exists? dir)) (not (file-writable? dir)))
 139       (print "Directory " dir " doesn't exist or is not writable.")
 140       (if (not (null? (glob (make-pathname dir "*"))))
 141           (print "Directory " dir " exists but is non-empty.")
 142           (begin
 143             (with-output-to-file (make-pathname dir "spec")
 144               (lambda ()
 145                 (print ";; Hill specifications.")
 146                 (print ";; ('spec hill-size core-size game-length games-per-match\n")
 147                 (pp (make-spec core-size game-length games-per-match hill-size))))
 148             (with-output-to-file (make-pathname dir "scores")
 149               (lambda () (pp '())))
 150             (with-output-to-file (make-pathname dir "rankings")
 151               (lambda () (pp '())))))))
 152
 153 ;;;; Main ;;;;
 154
 155 ;; Default values
 156
 157 (define default-core-size 8000)
 158 (define default-game-length 80000)
 159 (define default-games-per-match 3)
 160 (define default-hill-size 10)
 161
 162 (define (print-usage)
 163   (let ((binary (pathname-file (car (argv)))))
 164     (print "King of the Hill Tournament Manager")
 165     (print "\nUsage:\t" binary " hill-directory challenger-file")
 166     (print "\t" binary " [-r|--rankings] hill-directory")
 167     (print "\t" binary " [-h|--help]")
 168     (print "\t" binary " [-i|--init] hill-directory [hill-size [core-size game-length games-per-match]]")
 169     (print "\nDefault values are as follows:\n"
 170            "\thill-size: " default-hill-size "\n"
 171            "\tcore-size: " default-core-size "\n"
 172            "\tgame-length: " default-game-length "\n"
 173            "\tgames-per-match: " default-games-per-match)))
 174
 175 (define (main)
 176   (match (cdr (argv))
 177     ((or () ((or "-h" "--help")))
 178      (print-usage))
 179     (((or "-i" "--init") dir hill-size core-size game-length games-per-match)
 180      (init-hill-dir dir hill-size core-size game-length games-per-match))
 181     (((or "-i" "--init") dir)
 182      (init-hill-dir dir
 183                     default-hill-size
 184                     default-core-size
 185                     default-game-length
 186                     default-games-per-match))
 187     (((or "-i" "--init") dir hill-size)
 188      (init-hill-dir dir
 189                     hill-size
 190                     default-core-size
 191                     default-game-length
 192                     default-games-per-match))
 193     (((or "-r" "--rankings") dir)
 194      (let ((rankings (reverse (hill-rankings dir))))
 195        (if (null? rankings)
 196            (print "No warriors on hill!")
 197            (begin
 198              (print rankings)
 199              (print "Warrior" "\t" "Score")
 200              (print "-=-=-=-" "\t" "=-=-=")
 201              (for-each (lambda (r) (print (car r) "\t" (cadr r))) rankings)))))
 202     ((hill-dir challenger-file)
 203      (challenge hill-dir challenger-file))
 204     (else
 205      (print "Invalid arguments: " (apply conc else)))))
 206
 207 (main)