(make-instr
make-prog
prog-name
+ prog-author
prog-instrs
prog-offset
prog->string
;;; Memory setup and addressing
;;
- (define (make-core core-size initial-instr . set-functions)
+ (define INITIAL-INSTR (make-instr 'DAT 'F 'immediate 0 'immediate 0))
+
+ (define (make-core core-size . set-functions)
(let ((core-vec (make-vector core-size '()))
(names-vec (make-vector core-size '())))
(define (norm-addr i)
(print))
(let loop ((i 0))
(unless (>= i core-size)
- (vector-set! core-vec i (initial-instr 'make-copy))
+ (vector-set! core-vec i (INITIAL-INSTR 'make-copy))
(loop (+ i 1))))
(lambda args
(match args
(define (dump-prog prog)
(print (prog->string prog)))
-
+
+
;;; Executive function
;;
- (define (run-mars core queues steps-left)
- (cond
- ((<= steps-left 0) queues) ;Tie between remaining players
- ((null? queues) queues) ;Everyone's dead
- (else
- (let* ((queue (car queues))
- (remaining-queues (cdr queues))
- (ptrs (queue-ptrs queue))
- (new-ptrs (execute-instr core (car ptrs) (queue-owner queue))))
- (if (null? new-ptrs)
- (run-mars core remaining-queues (- steps-left 1))
- (begin
- (queue-set-ptrs! queue (append (cdr ptrs) new-ptrs))
- (run-mars core (append remaining-queues (list queue)) (- steps-left 1))))))))
+ (define (run-mars core queues steps-left . rest)
+ (let ((min-queue-count (if (null? rest) 2 (car rest))))
+ (if (or (<= steps-left 0)
+ (< (length queues) min-queue-count))
+ queues
+ (let* ((queue (car queues))
+ (remaining-queues (cdr queues))
+ (ptrs (queue-ptrs queue))
+ (new-ptrs (execute-instr core (car ptrs) (queue-owner queue))))
+ (if (null? new-ptrs)
+ (run-mars core remaining-queues (- steps-left 1))
+ (begin
+ (queue-set-ptrs! queue (append (cdr ptrs) new-ptrs))
+ (run-mars core (append remaining-queues (list queue)) (- steps-left 1))))))))
(define (execute-instr core ptr name)
;; (print ptr "\t" (core ptr '->string) "\t(" name ")")
((SLT)
(list (core '->addr (+ ptr (if (compare-instrs core A-ptr B-ptr modifier <) 2 1)))))
((SPL)
- (list (core '->addr (+ ptr 1) (core '->addr A-ptr))))
+ (list (core '->addr (+ ptr 1)) (core '->addr A-ptr)))
((NOP)
(list (core '->addr (+ ptr 1))))
(else