From 0dd1d148e53122a31f3cd6f4f440f43e03ba80c5 Mon Sep 17 00:00:00 2001 From: plugd Date: Wed, 20 Nov 2019 18:59:06 +0100 Subject: [PATCH] Improved visualization. --- mars.scm | 7 ++++--- wish.scm | 20 ++++++++++++++++---- 2 files changed, 20 insertions(+), 7 deletions(-) diff --git a/mars.scm b/mars.scm index caccfa1..7e7334c 100644 --- a/mars.scm +++ b/mars.scm @@ -356,15 +356,16 @@ (make-instr 'MOV 'I 'direct -2 'indirect-B -2) (make-instr 'JMP 'I 'immediate -2 'immediate 0)) 1)) -(define w (make-wish 640 480)) -(define colours '((imp . "red") +(define palette '((imp . "red") (dwarf . "blue"))) +(define w (make-wish 640 480 palette)) + (define core (make-core (* 640 480) (make-instr 'DAT 'F 'immediate 0 'immediate 0) (lambda (i n) (set-wish-pixel w (remainder i 640) (quotient i 640) - (cdr (assoc n colours)))))) + (cdr (assoc n palette)))))) (define queues (install-progs core (list dwarf imp))) diff --git a/wish.scm b/wish.scm index d8a45a5..b06e1d8 100644 --- a/wish.scm +++ b/wish.scm @@ -12,14 +12,26 @@ (chicken port) (chicken string)) - (define (make-wish w h) + (define (make-wish w h palette) (let-values (((in out id) (process (conc "wish -geometry " w "x" h)))) (with-output-to-port out (lambda () - (print "canvas .c -width " w " -height " h " -bg black") - (print "pack .c") + (print "wm title . \"MARS Visualizer\"") + (print "frame .fb -borderwidth 10") + (print "pack .fb -side top") + (let loop ((remaining-palette palette)) + (unless (null? remaining-palette) + (let ((name (caar remaining-palette)) + (col (cdar remaining-palette))) + (print "label .fb.l" name " -text " name " -fg " col) + (print "pack .fb.l" name " -side left")) + (loop (cdr remaining-palette)))) + (print "frame .fc -relief sunken -borderwidth 2") + (print "pack .fc -side bottom") + (print "canvas .fc.c -width " w " -height " h " -bg black") + (print "pack .fc.c") (print "image create photo core -width " w " -height " h " -palette 256/256/256") - (print ".c create image 0 0 -anchor nw -image core"))) + (print ".fc.c create image 0 0 -anchor nw -image core"))) (cons in out))) (define (wish-in wish) (car wish)) -- 2.20.1