diff --git a/scmvm.scm b/scmvm.scm
index dba87e3..7325574 100755
--- a/scmvm.scm
+++ b/scmvm.scm
@@ -12,6 +12,7 @@ exec guile -L . -e main -s "$0" "$@"
(eval-when (expand load eval)
(g-irepository-require "Gtk" #:version "4.0")
+ (gi-import-by-name "Gdk" "keyval_name")
(for-each (lambda (name)
(gi-import-by-name "Gio" name))
'("SimpleAction"
@@ -19,32 +20,45 @@ exec guile -L . -e main -s "$0" "$@"
(for-each (lambda (name) (gi-import-by-name "Gtk" name))
'("Application"
"ApplicationWindow"
- "CallbackAction"
- "FileDialog"
"Box"
- "TextView"
- "CssProvider")))
+ "Button"
+ "CallbackAction"
+ "CssProvider"
+ "EventControllerKey"
+ "FileDialog"
+ "Frame"
+ "Label")))
(define *css* "
.mono {
font-family: monospace;
}")
+(define-syntax-rule (named-lambda lambda-name args body ...)
+ (lambda args #((name . lambda-name)) body ...))
+
(define %vm (make-vm #:memory-size 100))
(define %program #f)
-(define %buffer #f)
+(define %buffer-label #f)
+(define %selected-byte 0)
(define (load-binary port)
(set! %program port))
-(define (update-memory-buffer!)
- (when (and %buffer %vm)
+(define (update-memory-view!)
+ (when %buffer-label
(define ram (vm-memory %vm))
- (set-text %buffer "" 0)
- (vector-for-each
- (lambda (_ byte)
- (insert-at-cursor %buffer (format #f "~:@(~2'0x~) " byte) -1))
- ram)))
+ (define text
+ (vector-fold
+ (lambda (i s byte)
+ (string-append
+ s
+ (if (and (is-focus (get-parent %buffer-label)) (= %selected-byte i))
+ (format #f "~:@(~2'0x~) " byte)
+ (format #f "~:@(~2'0x~) " byte))))
+ ""
+ ram))
+ (set-markup %buffer-label text)))
(define (open-file win cb)
(define dialog (make ))
@@ -58,6 +72,8 @@ exec guile -L . -e main -s "$0" "$@"
(connect action 'activate (lambda (a v) (callback))))
(define (activate app)
+ (newline)
+ ;; Setup window
(define win (make
#:application app
#:title "Scheme Compiler"))
@@ -65,8 +81,12 @@ exec guile -L . -e main -s "$0" "$@"
(load-from-string css-provider *css*)
(gtk-style-context-add-provider-for-display
(gdk-display-get-default) css-provider #xffff)
-
- ;; All this to make a menu...
+ (define box (make
+ #:orientation 'vertical
+ #:focusable #t))
+ (set-child win box)
+
+ ;; Setup menu
(let ([app-action-group (make )]
[menu (make )]
[file-menu (make )])
@@ -78,30 +98,53 @@ exec guile -L . -e main -s "$0" "$@"
(install-action
app-action-group
"open-file"
- (lambda ()
- (open-file win load-binary))))
-
- (define box (make
- #:orientation 'vertical))
- (define textview (make
- #:vexpand #t
- #:editable #f
- #:cursor-visible #f
- #:wrap-mode 'word
- #:css-classes '("mono")))
- (set! %buffer (get-buffer textview))
- (update-memory-buffer!)
- (append box textview)
- (set-child win box)
+ (lambda () (open-file win load-binary))))
+ ;; Setup buffer view
+ (set! %buffer-label (make
+ #:css-classes '("mono")
+ #:wrap #t
+ #:focusable #t))
+ (set-can-focus %buffer-label #t)
+ (set! %selected-byte 0)
+ (define frame (make
+ #:focusable #t))
+ (define buffer-controller (make ))
+ (gtk-widget-add-controller frame buffer-controller)
+ (connect buffer-controller 'key-pressed handle-key-event)
+ (set-child frame %buffer-label)
+ (append box frame)
+ (update-memory-view!)
+ ;(connect win 'move-focus move-focus) ; TODO needs some sort of return value
+
+
+ (append box (make ))
+ (append box (make ))
+
+ ;; Present window
(present win))
+
+(define (move-focus . args)
+ (update-memory-view!)
+ #t)
+
+(define (handle-key-event e val code mod)
+ (if
+ (case (string->symbol (gdk-keyval-name val))
+ [(Left) (set! %selected-byte (max (1- %selected-byte) 0)) #t]
+ [(Right) (set! %selected-byte (min (1+ %selected-byte) 99)) #t]
+ [else #f])
+ (begin (update-memory-view!) #t)
+ #f))
+
+
(define* (main #:optional args)
(define app (make ))
(connect app 'activate activate)
(let ([status (run app args)])
(exit status)))
-
+
;;; DEBUG
(use-modules (ice-9 threads))
(define (debug)