prog-instrs
prog-offset
prog->string
+ dump-prog
install-progs
make-queue
queue-owner
queue-ptrs
+ dump-queue
make-core
run-mars)
(('->string)
(conc opcode
"." modifier
- " " (mode->string A-mode) A-num
+ "\t" (mode->string A-mode) A-num
", " (mode->string B-mode) B-num))
(else
(error "Invalid instr arguments" args)))))
(let loop ((remaining-fns set-functions))
(unless (null? remaining-fns)
((car remaining-fns) i n))))
+ (define (dump i)
+ (print* i ":\t" ((norm-ref core-vec i) '->string))
+ (let ((n (norm-ref names-vec i)))
+ (unless (null? n)
+ (print* "\t;" n)))
+ (print))
(let loop ((i 0))
(unless (>= i core-size)
(vector-set! core-vec i (initial-instr 'make-copy))
((i 'name) (norm-ref names-vec i))
(((? integer? i) v) ((norm-ref core-vec i) v))
(('->addr (? integer? i)) (norm-addr i))
- (('dump)
- (let loop ((i 0))
- (unless (>= i core-size)
- (print* i ":\t" ((vector-ref core-vec i) '->string))
- (let ((n (vector-ref names-vec i)))
- (unless (null? n)
- (print* "\t;" n)))
- (print)
- (loop (+ i 1)))))
+ (('dump i)
+ (let ((i1 (- i 4))
+ (i2 (+ i 4)))
+ (let loop ((idx i1))
+ (unless (> idx i2)
+ (if (= idx i)
+ (print* "*"))
+ (dump idx)
+ (loop (+ idx 1))))))
(('size) core-size)))))
;;; Programmes and task queues
;;
- (define (make-prog name instrs offset)
- (list name instrs offset))
+ (define (make-prog name author instrs offset)
+ (list name author instrs offset))
(define (prog-name prog) (list-ref prog 0))
- (define (prog-instrs prog) (list-ref prog 1))
- (define (prog-offset prog) (list-ref prog 2))
+ (define (prog-author prog) (list-ref prog 1))
+ (define (prog-instrs prog) (list-ref prog 2))
+ (define (prog-offset prog) (list-ref prog 3))
(define (install-prog core prog addr)
(let loop ((ptr addr)
(define (queue-set-ptrs! queue ptrs)
(set-cdr! queue ptrs))
+ (define (dump-queue queue core)
+ (let loop ((ptrs (queue-ptrs queue)))
+ (unless (null? ptrs)
+ (core 'dump (car ptrs))
+ (print)
+ (loop (cdr ptrs)))))
+
(define (prog->string prog)
(conc ";redcode\n\n"
- ";name " (prog-name prog) "\n\n"
+ ";name\t" (prog-name prog) "\n"
+ (if (not (null? (prog-author prog)))
+ (conc ";author\t" (prog-author prog) "\n\n")
+ "\n")
"ORG\t" (prog-offset prog) "\t; Execution offset\n\n"
(apply conc (map (lambda (instr) (conc (instr '->string) "\n")) (prog-instrs prog)))))
+
+ (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
- ;; ((<= (length queues) 1) queues) ;There's only one player left who thus wins
+ ((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 remaining-queues (- steps-left 1))
+ (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 ")")
(let* ((A-ptr (eval-operand core (core ptr 'A-mode) (core ptr 'A-num) ptr name))
(B-ptr (eval-operand core (core ptr 'B-mode) (core ptr 'B-num) ptr name))
(modifier (core ptr 'modifier)))
(list (core '->addr (+ ptr 1))))
((exn arithmetic) '())))
((JMP)
- (list (core '->addr (+ ptr (core A-ptr 'A-num)))))
+ (list (core '->addr A-ptr)))
((JMZ)
- (list (core '->addr (+ ptr (if (instr-zero? B-ptr modifier #f name)
- (core A-ptr 'A-num)
- 1)))))
+ (list (core '->addr (if (instr-zero? B-ptr modifier #f name)
+ A-ptr
+ (+ ptr 1)))))
((JMN)
- (list (core '->addr (+ ptr (if (not (instr-zero? B-ptr modifier #f name))
- (core A-ptr 'A-num)
- 1)))))
+ (list (core '->addr (if (not (instr-zero? B-ptr modifier #f name))
+ A-ptr
+ (+ ptr 1)))))
((DJN)
- (list (core '->addr (+ ptr (if (not (instr-zero? B-ptr modifier #t name))
- (core A-ptr 'A-num)
- 1)))))
+ (list (core '->addr (if (not (instr-zero? B-ptr modifier #t name))
+ A-ptr
+ (+ ptr 1)))))
((SEQ CMP)
(list (core '->addr (+ ptr (if (compare-instrs core A-ptr B-ptr modifier =) 2 1)))))
((SNE)
((SLT)
(list (core '->addr (+ ptr (if (compare-instrs core A-ptr B-ptr modifier <) 2 1)))))
((SPL)
- (list (core '->addr (+ ptr 1) (core '->addr (+ ptr (core A-ptr 'A-num))))))
+ (list (core '->addr (+ ptr 1) (core '->addr A-ptr))))
((NOP)
(list (core '->addr (+ ptr 1))))
(else
(chicken irregex)
(chicken io)
(chicken string)
- mars)
+ srfi-13 mars)
(define (string->prog str)
(let ((idx 0)
(redcode-irx (irregex "^;redcode\n"))
(name-start-irx (irregex "^;[ \t]*name "))
(name-irx (irregex "^[a-zA-Z0-9]+"))
+ (author-start-irx (irregex "^;[ \t]*author "))
+ (author-irx (irregex "^[^\n]*"))
(comment-irx (irregex "^(;[^\n]*)?\n"))
(org-irx (irregex "^ORG"))
(opcode-DAT-irx (irregex "^DAT"))
(accept-token redcode-irx #t)
(let loop ((instrs '())
(offset 0)
- (name '()))
+ (name '())
+ (author '()))
(let ((this-line (line)))
(if this-line
(case (car this-line)
- ((name) (loop instrs offset (cdr this-line)))
- ((comment) (loop instrs offset name))
- ((org) (loop instrs (cdr this-line) name))
- ((instr) (loop (cons (cdr this-line) instrs) offset name)))
- (make-prog name (reverse instrs) offset)))))
+ ((name) (loop instrs offset (cdr this-line) author))
+ ((author) (loop instrs offset name (cdr this-line)))
+ ((comment) (loop instrs offset name author))
+ ((org) (loop instrs (cdr this-line) name author))
+ ((instr) (loop (cons (cdr this-line) instrs) offset name author)))
+ (make-prog name author (reverse instrs) offset)))))
(define (line)
(or (name-line)
+ (author-line)
(comment-line)
(org-line)
(instruction-line)))
(if (accept-token name-start-irx)
(cons 'name (string->symbol (accept-token name-irx #t)))
#f))
+ (define (author-line)
+ (if (accept-token author-start-irx)
+ (cons 'author (string-trim (accept-token author-irx #t)))
+ #f))
(define (comment-line)
(if (accept-token comment-irx)
'(comment)
(let ((x (accept-token period-irx #t))
(modif (modifier))
(A-mode (mode))
- (A-num (accept-token number-irx #t))
+ (A-num (string->number (accept-token number-irx #t)))
(y (accept-token comma-irx #t))
(B-mode (mode))
- (B-num (accept-token number-irx #t))
+ (B-num (string->number (accept-token number-irx #t)))
(z (accept-token comment-irx #t)))
(cons 'instr (make-instr oc modif A-mode A-num B-mode B-num)))
#f)))
-(import mars visualizer parser)
+(import (chicken io)
+ mars visualizer parser)
;; (define addressing-test
;; (make-prog 'at (list
;; (make-instr 'MOV 'I 'direct -2 'indirect-B -2)
;; (make-instr 'JMP 'I 'immediate -2 'immediate 0)) 1))
-(define imp (string->prog (with-input-from-file "imp.red" read-string)))
-(define dwarf (string->prog (with-input-from-file "dwarf.red" read-string)))
+(condition-case
+ (vis 'destroy)
+ ((exn) #f))
-(define palette '((Imp . "red")
- (Dwarf . "blue")))
+;; (define files '("dwarf.red"))
+(define files '("imp.red" "dwarf.red"))
-(define vis (make-vis 640 480 8000 palette))
+(define progs
+ (map
+ (lambda (fname)
+ (string->prog (with-input-from-file fname read-string)))
+ files))
+
+(define colors '("red" "blue" "green" "magenta" "cyan"))
+
+(define color-map
+ (let loop ((entries '())
+ (progs-left progs)
+ (colors-left colors))
+ (if (null? progs-left)
+ entries
+ (let ((this-prog (car progs-left))
+ (this-col (car colors-left)))
+ (loop (cons (cons (prog-name this-prog) this-col) entries)
+ (cdr progs-left)
+ (cdr colors-left))))))
+
+(define vis (make-vis 640 480 8000 color-map))
(define core (make-core 8000 (make-instr 'DAT 'F 'immediate 0 'immediate 0)
(lambda (i n)
(vis 'update-owner i n))))
-(define queues (install-progs core (list dwarf imp)))
+(define queues (install-progs core progs))
+
+(for-each dump-prog progs)
+
+(set! queues (run-mars core queues 10000))
-(run-mars core queues 10000)
+(for-each (lambda (q)
+ (print "Queue for " (queue-owner q) ":")
+ (dump-queue q core)
+ (print))
+ queues)
The Lambda Lab / projects / jars.git / commitdiff