From d46d99f47aa09abe611b430ee6d8451390a7d07a Mon Sep 17 00:00:00 2001
From: Dane Johnson <daneallenjohnson@protonmail.com>
Date: Mon, 20 Jan 2025 10:16:47 -0600
Subject: [PATCH] Can kind of move the cursor around

---
 scmvm.scm | 103 ++++++++++++++++++++++++++++++++++++++----------------
 1 file changed, 73 insertions(+), 30 deletions(-)

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 "<span background=\"lightblue\">~:@(~2'0x~)</span> " byte)
+              (format #f "~:@(~2'0x~) " byte))))
+       ""
+       ram))
+    (set-markup %buffer-label text)))
 
 (define (open-file win cb)
   (define dialog (make <gtk-file-dialog>))
@@ -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 <gtk-application-window>
                 #: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 <gtk-box>
+                #:orientation 'vertical
+                #:focusable #t))
+  (set-child win box)
+  
+  ;; Setup menu
   (let ([app-action-group (make <g-simple-action-group>)]
         [menu (make <g-menu>)]
         [file-menu (make <g-menu>)])
@@ -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 <gtk-box>
-                #:orientation 'vertical))
-  (define textview (make <gtk-text-view>
-                     #: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 <gtk-label>
+                        #:css-classes '("mono")
+                        #:wrap #t
+                        #:focusable #t))
+  (set-can-focus %buffer-label #t)
+  (set! %selected-byte 0)
+  (define frame (make <gtk-frame>
+                  #:focusable #t))
+  (define buffer-controller (make <gtk-event-controller-key>))
+  (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 <gtk-button>))
+  (append box (make <gtk-button>))
+  
+  ;; 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 <gtk-application>))
   (connect app 'activate activate)
   (let ([status (run app args)])
     (exit status)))
-
+
 ;;; DEBUG
 (use-modules (ice-9 threads))
 (define (debug)