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