From: plugd <plugd@thelambdalab.xyz>
Date: Sat, 23 Nov 2019 00:36:05 +0000 (+0100)
Subject: Parsing and execution of loadfiles working.
X-Git-Url: https://thelambdalab.xyz/gitweb/index.cgi?a=commitdiff_plain;h=7526b1f66f4c7a0d460d0e267b1eb4553c0d981b;p=jars.git

Parsing and execution of loadfiles working.
---

diff --git a/imp.red b/imp.red
index 4ef2cc1..766ae4e 100644
--- a/imp.red
+++ b/imp.red
@@ -1,6 +1,9 @@
 ;redcode
 
-;name Imp
+;name          Imp
+;author        A. K. Dewdney
+;version       94.1
+;date          April 29, 1993
 
-ORG 0
-MOV.I $0, $1
+ORG            0
+MOV.I          $0, $1
diff --git a/mars.scm b/mars.scm
index 23a0337..9610d10 100644
--- a/mars.scm
+++ b/mars.scm
@@ -9,10 +9,12 @@
      prog-instrs
      prog-offset
      prog->string
+     dump-prog
      install-progs
      make-queue
      queue-owner
      queue-ptrs
+     dump-queue
      make-core
      run-mars)
 
@@ -55,7 +57,7 @@
         (('->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)))))
@@ -95,6 +97,12 @@
         (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))
@@ -116,27 +124,28 @@
           ((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)
@@ -178,11 +187,24 @@
   (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
   ;;
@@ -190,19 +212,20 @@
   (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)))
@@ -237,19 +260,19 @@
                (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)
@@ -257,7 +280,7 @@
         ((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
diff --git a/parser.scm b/parser.scm
index 11491b7..427d398 100644
--- a/parser.scm
+++ b/parser.scm
@@ -6,7 +6,7 @@
           (chicken irregex)
           (chicken io)
           (chicken string)
-          mars)
+          srfi-13 mars)
 
   (define (string->prog str)
     (let ((idx 0)
@@ -18,6 +18,8 @@
           (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"))
@@ -71,17 +73,20 @@
         (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)))
@@ -89,6 +94,10 @@
         (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)
@@ -103,10 +112,10 @@
               (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)))
diff --git a/test.scm b/test.scm
index 7f6f921..178260d 100644
--- a/test.scm
+++ b/test.scm
@@ -1,4 +1,5 @@
-(import mars visualizer parser)
+(import (chicken io)
+        mars visualizer parser)
 
 ;; (define addressing-test
 ;;   (make-prog 'at (list
@@ -20,18 +21,47 @@
 ;;                      (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)