dane/scm-to-vm
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Better control over buffer label, select by nibble not byte

Browse Source
This commit is contained in:
Dane Johnson 2025-01-20 14:49:24 -06:00
parent d46d99f47a
commit f89bed316c
1 changed files with 55 additions and 20 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

75
scmvm.scm
View File

@ -4,6 +4,7 @@ exec guile -L . -e main -s "$0" "$@"
(use-modules (rnrs bytevectors) (use-modules (rnrs bytevectors)
(ice-9 binary-ports) (ice-9 binary-ports)
(ice-9 format) (ice-9 format)
(srfi srfi-11)
(srfi srfi-26) (srfi srfi-26)
(srfi srfi-43) (srfi srfi-43)
(scmvm vm) (scmvm vm)
@ -40,7 +41,19 @@ exec guile -L . -e main -s "$0" "$@"
(define %vm (make-vm #:memory-size 100)) (define %vm (make-vm #:memory-size 100))
(define %program #f) (define %program #f)
(define %buffer-label #f) (define %buffer-label #f)
(define %selected-byte 0) (define %selected-nibble 0)
(define (nibble->byte+offset x)
(values (quotient x 2)
(remainder x 2)))
(define (format-nibble val offset)
(string-upcase
(number->string
(if (zero? offset)
(ash val -4)
(logand val #x0F))
16)))
(define (load-binary port) (define (load-binary port)
(set! %program port)) (set! %program port))
@ -49,15 +62,25 @@ exec guile -L . -e main -s "$0" "$@"
(when %buffer-label (when %buffer-label
(define ram (vm-memory %vm)) (define ram (vm-memory %vm))
(define text (define text
(vector-fold (let-values ([(byte offset) (nibble->byte+offset %selected-nibble)])
(lambda (i s byte) (vector-fold
(string-append (lambda (i s val)
s (string-append
(if (and (is-focus (get-parent %buffer-label)) (= %selected-byte i)) s
(format #f "<span background=\"lightblue\">~:@(~2'0x~)</span> " byte) (cond
(format #f "~:@(~2'0x~) " byte)))) [(or (not (is-focus (get-parent %buffer-label)))
"" (not (= i byte)))
ram)) (format #f "~:@(~2'0x~) " val)]
[(= offset 0)
(format #f "<span background=\"lightblue\">~a</span>~a "
(format-nibble val 0)
(format-nibble val 1))]
[(= offset 1)
(format #f "~a<span background=\"lightblue\">~a</span> "
(format-nibble val 0)
(format-nibble val 1))])))
""
ram)))
(set-markup %buffer-label text))) (set-markup %buffer-label text)))
(define (open-file win cb) (define (open-file win cb)
@ -106,7 +129,7 @@ exec guile -L . -e main -s "$0" "$@"
#:wrap #t #:wrap #t
#:focusable #t)) #:focusable #t))
(set-can-focus %buffer-label #t) (set-can-focus %buffer-label #t)
(set! %selected-byte 0) (set! %selected-nibble 0)
(define frame (make <gtk-frame> (define frame (make <gtk-frame>
#:focusable #t)) #:focusable #t))
(define buffer-controller (make <gtk-event-controller-key>)) (define buffer-controller (make <gtk-event-controller-key>))
@ -114,9 +137,8 @@ exec guile -L . -e main -s "$0" "$@"
(connect buffer-controller 'key-pressed handle-key-event) (connect buffer-controller 'key-pressed handle-key-event)
(set-child frame %buffer-label) (set-child frame %buffer-label)
(append box frame) (append box frame)
(grab-focus frame)
(update-memory-view!) (update-memory-view!)
;(connect win 'move-focus move-focus) ; TODO needs some sort of return value
(append box (make <gtk-button>)) (append box (make <gtk-button>))
(append box (make <gtk-button>)) (append box (make <gtk-button>))
@ -129,13 +151,26 @@ exec guile -L . -e main -s "$0" "$@"
#t) #t)
(define (handle-key-event e val code mod) (define (handle-key-event e val code mod)
(if (let ([val (gdk-keyval-name val)])
(case (string->symbol (gdk-keyval-name val)) (if
[(Left) (set! %selected-byte (max (1- %selected-byte) 0)) #t] (cond
[(Right) (set! %selected-byte (min (1+ %selected-byte) 99)) #t] [(string= val "Left")
[else #f]) (set! %selected-nibble (max (1- %selected-nibble) 0))
(begin (update-memory-view!) #t) #t]
#f)) [(string= val "Right")
(set! %selected-nibble (min (1+ %selected-nibble) 199))
#t]
[(string->number val 16)
(let-values ([(byte offset) (nibble->byte+offset %selected-nibble)]
[(val) (string->number val 16)])
(vm-memory-set! %vm byte
(if (zero? offset)
(+ (logand (vm-memory-ref %vm byte) #x0f) (ash val 4))
(+ (logand (vm-memory-ref %vm byte) #xf0) val))))
#t]
[else #f])
(begin (update-memory-view!) #t)
#f)))