mars.scm

   1 ;;;
   2 ;;; An implementation of the Memory Array Redcode Simulator (MARS)
   3 ;;;
   4
   5 (module mars
   6     (make-instr
   7      make-prog
   8      prog-name
   9      prog-instrs
  10      prog-offset
  11      prog->string
  12      dump-prog
  13      install-progs
  14      make-queue
  15      queue-owner
  16      queue-ptrs
  17      dump-queue
  18      make-core
  19      run-mars)
  20
  21   (import scheme
  22           (chicken base)
  23           (chicken io)
  24           (chicken string)
  25           (chicken random)
  26           (chicken condition)
  27           (chicken process-context)
  28           matchable)
  29
  30
  31   ;;; Instructions
  32   ;;
  33
  34   (define (make-instr opcode modifier A-mode A-num B-mode B-num)
  35     (lambda args
  36       (match args
  37         (('opcode) opcode)
  38         (('modifier) modifier)
  39         (('A-mode) A-mode)
  40         (('A-num) A-num)
  41         (('B-mode) B-mode)
  42         (('B-num) B-num)
  43         (('make-copy) (make-instr opcode modifier A-mode A-num B-mode B-num))
  44         (('set! 'opcode x) (set! opcode x))
  45         (('set! 'modifier x) (set! modifier x))
  46         (('set! 'A-mode x) (set! A-mode x))
  47         (('set! 'A-num x) (set! A-num x))
  48         (('set! 'B-mode x) (set! B-mode x))
  49         (('set! 'B-num x) (set! B-num x))
  50         (('set-from! other)
  51          (set! opcode (other 'opcode))
  52          (set! modifier (other 'modifier))
  53          (set! A-mode (other 'A-mode))
  54          (set! A-num (other 'A-num))
  55          (set! B-mode (other 'B-mode))
  56          (set! B-num (other 'B-num)))
  57         (('->string)
  58          (conc opcode
  59                "." modifier
  60                "\t" (mode->string A-mode) A-num
  61                ", " (mode->string B-mode) B-num))
  62         (else
  63          (error "Invalid instr arguments" args)))))
  64
  65   (define (mode->string mode)
  66     (case mode
  67       ((immediate) "#")
  68       ((direct) "$")
  69       ((indirect-A) "*")
  70       ((indirect-B) "@")
  71       ((pre-indirect-A) "{")
  72       ((pre-indirect-B) "<")
  73       ((post-indirect-A) "}")
  74       ((post-indirect-B) ">")
  75       (else
  76        (error "Unknown mode."))))
  77
  78
  79   ;;; Memory setup and addressing
  80   ;;
  81
  82   (define (make-core core-size initial-instr . set-functions)
  83     (let ((core-vec (make-vector core-size '()))
  84           (names-vec (make-vector core-size '())))
  85       (define (norm-addr i)
  86         (if (< i 0)
  87             (norm-addr (+ i core-size))
  88             (modulo i core-size)))
  89       (define (norm-ref v i)
  90         (vector-ref v (norm-addr i)))
  91       (define (norm-set! v i x)
  92         (vector-set! v (norm-addr i)
  93                      (if (integer? x)
  94                          (norm-addr x)
  95                          x)))
  96       (define (run-set-functions i n)
  97         (let loop ((remaining-fns set-functions))
  98           (unless (null? remaining-fns)
  99             ((car remaining-fns) i n))))
 100       (define (dump i)
 101         (print* i ":\t" ((norm-ref core-vec i) '->string))
 102         (let ((n (norm-ref names-vec i)))
 103           (unless (null? n)
 104             (print* "\t;" n)))
 105         (print))
 106       (let loop ((i 0))
 107         (unless (>= i core-size)
 108           (vector-set! core-vec i (initial-instr 'make-copy))
 109           (loop (+ i 1))))
 110       (lambda args
 111         (match args
 112           ((i 'set-from! j n)
 113            ((norm-ref core-vec i) 'set-from! (norm-ref core-vec j))
 114            (norm-set! names-vec i n)
 115            (run-set-functions i n))
 116           ((i 'set-from-instr! instr n)
 117            ((norm-ref core-vec i) 'set-from! instr)
 118            (norm-set! names-vec i n)
 119            (run-set-functions i n))
 120           ((i 'set! v x n)
 121            ((norm-ref core-vec i) 'set! v x)
 122            (norm-set! names-vec i n)
 123            (run-set-functions i n))
 124           ((i 'name) (norm-ref names-vec i))
 125           (((? integer? i) v) ((norm-ref core-vec i) v))
 126           (('->addr (? integer? i)) (norm-addr i))
 127           (('dump i)
 128            (let ((i1 (- i 4))
 129                  (i2 (+ i 4)))
 130              (let loop ((idx i1))
 131                (unless (> idx i2)
 132                  (if (= idx i)
 133                      (print* "*"))
 134                  (dump idx)
 135                  (loop (+ idx 1))))))
 136           (('size) core-size)))))
 137
 138
 139   ;;; Programmes and task queues
 140   ;;
 141
 142   (define (make-prog name author instrs offset)
 143     (list name author instrs offset))
 144
 145   (define (prog-name prog) (list-ref prog 0))
 146   (define (prog-author prog) (list-ref prog 1))
 147   (define (prog-instrs prog) (list-ref prog 2))
 148   (define (prog-offset prog) (list-ref prog 3))
 149
 150   (define (install-prog core prog addr)
 151     (let loop ((ptr addr)
 152                (instrs (prog-instrs prog)))
 153       (unless (null? instrs)
 154         (core ptr 'set-from-instr! (car instrs) (prog-name prog))
 155         (loop (core '->addr (+ ptr 1)) (cdr instrs))))
 156     (make-queue (prog-name prog)
 157                 (core '->addr (+ addr (prog-offset prog)))))
 158
 159   (define (can-install-prog? core prog-len addr)
 160     (let loop ((ptr addr)
 161                (remaining prog-len))
 162       (if (= remaining 0)
 163           #t
 164           (if (null? (core ptr 'name))
 165               (loop (core '->addr (+ ptr 1))
 166                     (- remaining 1))
 167               #f))))
 168
 169   (define (install-progs core progs)
 170     (let loop ((queues '())
 171                (progs-left progs))
 172       (if (null? progs-left)
 173           queues
 174           (let ((addr (pseudo-random-integer (core 'size)))
 175                 (prog (car progs-left)))
 176             (if (can-install-prog? core (length (prog-instrs prog)) addr)
 177                 (loop (cons (install-prog core prog addr) queues)
 178                       (cdr progs-left))
 179                 (loop queues progs-left))))))
 180
 181   (define (make-queue name ptr)
 182     (list name ptr))
 183
 184   (define (queue-owner queue) (car queue))
 185   (define (queue-ptrs queue) (cdr queue))
 186
 187   (define (queue-set-ptrs! queue ptrs)
 188     (set-cdr! queue ptrs))
 189
 190   (define (dump-queue queue core)
 191     (let loop ((ptrs (queue-ptrs queue)))
 192       (unless (null? ptrs)
 193         (core 'dump (car ptrs))
 194         (print)
 195         (loop (cdr ptrs)))))
 196
 197   (define (prog->string prog)
 198     (conc ";redcode\n\n"
 199           ";name\t" (prog-name prog) "\n"
 200           (if (not (null? (prog-author prog)))
 201               (conc ";author\t" (prog-author prog) "\n\n")
 202               "\n")
 203           "ORG\t" (prog-offset prog) "\t; Execution offset\n\n"
 204           (apply conc (map (lambda (instr) (conc (instr '->string) "\n")) (prog-instrs prog)))))
 205
 206   (define (dump-prog prog)
 207     (print (prog->string prog)))
 208
 209   ;;; Executive function
 210   ;;
 211
 212   (define (run-mars core queues steps-left)
 213     (cond
 214      ((<= steps-left 0) queues)      ;Tie between remaining players
 215      ((null? queues) queues)         ;Everyone's dead
 216      (else
 217       (let* ((queue (car queues))
 218              (remaining-queues (cdr queues))
 219              (ptrs (queue-ptrs queue))
 220              (new-ptrs (execute-instr core (car ptrs) (queue-owner queue))))
 221         (if (null? new-ptrs)
 222             (run-mars core remaining-queues (- steps-left 1))
 223             (begin
 224               (queue-set-ptrs! queue (append (cdr ptrs) new-ptrs))
 225               (run-mars core (append remaining-queues (list queue)) (- steps-left 1))))))))
 226
 227   (define (execute-instr core ptr name)
 228     ;; (print ptr "\t" (core ptr '->string) "\t(" name ")")
 229     (let* ((A-ptr (eval-operand core (core ptr 'A-mode) (core ptr 'A-num) ptr name))
 230            (B-ptr (eval-operand core (core ptr 'B-mode) (core ptr 'B-num) ptr name))
 231            (modifier (core ptr 'modifier)))
 232       (case (core ptr 'opcode)
 233         ((DAT)
 234          '()) ;Game over, man, game over!
 235         ((MOV)
 236          (if (eq? modifier 'I)
 237              (core B-ptr 'set-from! A-ptr name)
 238              (combine-and-store core A-ptr B-ptr modifier name (lambda (x y) y)))
 239          (list (core '->addr (+ ptr 1))))
 240         ((ADD)
 241          (combine-and-store core A-ptr B-ptr modifier name +)
 242          (list (core '->addr (+ ptr 1))))
 243         ((SUB)
 244          (combine-and-store core A-ptr B-ptr modifier name -)
 245          (list (core '->addr (+ ptr 1))))
 246         ((MUL)
 247          (combine-and-store core A-ptr B-ptr modifier name *)
 248          (list (core '->addr (+ ptr 1))))
 249         ((DIV)
 250          (condition-case
 251              (begin
 252                (combine-and-store core A-ptr B-ptr modifier name quotient)
 253
 254                (list (core '->addr (+ ptr 1))))
 255            ((exn arithmetic) '())))
 256         ((MOD)
 257          (condition-case
 258              (begin
 259                (combine-and-store core A-ptr B-ptr modifier name modulo)
 260                (list (core '->addr (+ ptr 1))))
 261            ((exn arithmetic) '())))
 262         ((JMP)
 263          (list (core '->addr A-ptr)))
 264         ((JMZ)
 265          (list (core '->addr (if (instr-zero? core B-ptr modifier #f name)
 266                                  A-ptr
 267                                  (+ ptr 1)))))
 268         ((JMN)
 269          (list (core '->addr (if (not (instr-zero? core B-ptr modifier #f name))
 270                                  A-ptr
 271                                  (+ ptr 1)))))
 272         ((DJN)
 273          (list (core '->addr (if (not (instr-zero? core B-ptr modifier #t name))
 274                                  A-ptr
 275                                  (+ ptr 1)))))
 276         ((SEQ CMP)
 277          (list (core '->addr (+ ptr (if (compare-instrs core A-ptr B-ptr modifier =) 2 1)))))
 278         ((SNE)
 279          (list (core '->addr (+ ptr (if (compare-instrs core A-ptr B-ptr modifier =) 1 2)))))
 280         ((SLT)
 281          (list (core '->addr (+ ptr (if (compare-instrs core A-ptr B-ptr modifier <) 2 1)))))
 282         ((SPL)
 283          (list (core '->addr (+ ptr 1) (core '->addr A-ptr))))
 284         ((NOP)
 285          (list (core '->addr (+ ptr 1))))
 286         (else
 287          (error "Unrecognised opcode" (core ptr 'opcode))))))
 288
 289   (define (compare-instrs core A-ptr B-ptr modifier test)
 290     (case modifier
 291       ((A) (test (core A-ptr 'A-num) (core B-ptr 'A-num)))
 292       ((B) (test (core A-ptr 'B-num) (core B-ptr 'B-num)))
 293       ((AB) (test (core A-ptr 'A-num) (core B-ptr 'B-num)))
 294       ((BA) (test (core A-ptr 'B-num) (core B-ptr 'A-num)))
 295       ((F) (and
 296             (test (core A-ptr 'A-num) (core B-ptr 'A-num))
 297             (test (core A-ptr 'B-num) (core B-ptr 'B-num))))
 298       ((X) (and
 299             (test (core A-ptr 'A-num) (core B-ptr 'B-num))
 300             (test (core A-ptr 'B-num) (core B-ptr 'A-num))))
 301       ((I) (and
 302             (if (eq? test =)
 303                 (and
 304                  (eq? (core A-ptr 'opcode) (core B-ptr 'opcode))
 305                  (eq? (core A-ptr 'modifier) (core B-ptr 'modifier))
 306                  (eq? (core A-ptr 'A-mode) (core B-ptr 'B-mode))
 307                  (eq? (core A-ptr 'B-mode) (core B-ptr 'A-mode)))
 308                 #t)
 309             (test (core A-ptr 'A-num) (core B-ptr 'B-num))
 310             (test (core A-ptr 'B-num) (core B-ptr 'A-num))))))
 311
 312   (define (instr-zero? core ptr modifier decrement name)
 313     (case modifier
 314       ((A AB)
 315        (if decrement (core ptr 'set! 'A-num (- (core ptr 'A-num) 1) name))
 316        (= 0 (core ptr 'A-num)))
 317       ((A AB)
 318        (if decrement (core ptr 'set! 'B-num (- (core ptr 'B-num) 1) name))
 319        (= 0 (core ptr 'B-num)))
 320       ((X I F)
 321        (if decrement
 322            (begin
 323              (core ptr 'set! 'A-num (- (core ptr 'A-num) 1) name)
 324              (core ptr 'set! 'B-num (- (core ptr 'B-num) 1) name)))
 325        (and (= 0 (core ptr 'A-num))
 326             (= 0 (core ptr 'B-num))))))
 327
 328   (define (combine-and-store core A-ptr B-ptr modifier name f)
 329     (case modifier
 330       ((A) (core B-ptr 'set! 'A-num
 331                  (f (core B-ptr 'A-num) (core A-ptr 'A-num)) name))
 332       ((B) (core B-ptr 'set! 'B-num
 333                  (f (core B-ptr 'B-num) (core A-ptr 'B-num)) name))
 334       ((AB) (core B-ptr 'set! 'B-num
 335                   (f (core B-ptr 'B-num) (core A-ptr 'A-num)) name))
 336       ((BA) (core B-ptr 'set! 'A-num
 337                   (f (core B-ptr 'A-num) (core A-ptr 'B-num)) name))
 338       ((F I) (core B-ptr 'set! 'A-num
 339                    (f (core B-ptr 'A-num) (core A-ptr 'A-num)) name)
 340        (core B-ptr 'set! 'B-num
 341              (f (core B-ptr 'B-num) (core A-ptr 'B-num)) name))
 342       ((X) (core B-ptr 'set! 'A-num
 343                  (f (core B-ptr 'A-num) (core A-ptr 'B-num)) name)
 344        (core B-ptr 'set! 'B-num
 345              (f (core B-ptr 'B-num) (core A-ptr 'A-num)) name))))
 346
 347   (define (eval-operand core mode num ptr name)
 348     (core '->addr (+ ptr
 349                      (case mode
 350                        ((immediate) 0)
 351                        ((direct) num)
 352                        ((indirect-A) (+ num (core (+ ptr num) 'A-num)))
 353                        ((indirect-B) (+ num (core (+ ptr num) 'B-num)))
 354                        ((pre-indirect-A)
 355                         (let ((aux-ptr (+ ptr num)))
 356                           (core aux-ptr 'set! 'A-num (- (core aux-ptr 'A-num) 1) name)
 357                           (+ num (core aux-ptr 'A-num))))
 358                        ((pre-indirect-B)
 359                         (let ((aux-ptr (+ ptr num)))
 360                           (core aux-ptr 'set! 'B-num (- (core aux-ptr 'B-num) 1) name)
 361                           (+ num (core aux-ptr 'B-num))))
 362                        ((post-indirect-A)
 363                         (let* ((aux-ptr (+ ptr num))
 364                                (old-A-num (core aux-ptr 'A-num)))
 365                           (core aux-ptr 'set! 'A-num (+ (core aux-ptr 'A-num) 1) name)
 366                           (+ num old-A-num)))
 367                        ((post-indirect-B)
 368                         (let* ((aux-ptr (+ ptr num))
 369                                (old-B-num (core aux-ptr 'B-num)))
 370                           (core aux-ptr 'set! 'B-num (+ (core aux-ptr 'B-num) 1) name)
 371                           (+ num old-B-num)))
 372                        (else
 373                         (error "Unrecognized mode" mode)))))))
 374