adding some curses stuff from fantasary...

bugafriend/ncurses/ncurses-stuff.scm

@@ -0,0 +1,87 @@
+;;; Copyright 2023 Christine Lemmer-Webber
+;;;
+;;; Licensed under the Apache License, Version 2.0 (the "License");
+;;; you may not use this file except in compliance with the License.
+;;; You may obtain a copy of the License at
+;;;
+;;;    http://www.apache.org/licenses/LICENSE-2.0
+;;;
+;;; Unless required by applicable law or agreed to in writing, software
+;;; distributed under the License is distributed on an "AS IS" BASIS,
+;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+;;; See the License for the specific language governing permissions and
+;;; limitations under the License.
+
+(define-module (fantasary ncurses-stuff)
+  #:use-module (ncurses curses)
+  #:use-module (rnrs enums)
+  #:export (%YELLOW-N
+            %GREEN-N
+            %WHITE-N
+            %RED-N
+            %CYAN-N
+            %MAGENTA-N
+
+            install-colors!
+
+            color-ref
+            color-pair-ref
+
+            screen-setup!))
+
+;; Same order ncurses uses
+(define colors
+  '(black red green yellow blue magenta cyan white))
+(define c-vec
+  (vector COLOR_BLACK
+          COLOR_RED
+          COLOR_GREEN
+          COLOR_YELLOW
+          COLOR_BLUE
+          COLOR_MAGENTA
+          COLOR_CYAN
+          COLOR_WHITE))
+
+(define colors-len
+  (length colors))
+(define colors-enum
+  (make-enumeration colors))
+
+;; Get the id of a color (or a color against black)
+(define color-ref
+  (enum-set-indexer colors-enum))
+
+(define (color-pair-ref fg-sym bg-sym)
+  "Get the id of a color pair"
+  (+ (color-ref fg-sym)
+     (* (color-ref bg-sym) colors-len)))
+
+(define %YELLOW-N (color-ref 'yellow))
+(define %GREEN-N (color-ref 'green))
+(define %WHITE-N (color-ref 'white))
+(define %RED-N (color-ref 'red))
+(define %CYAN-N (color-ref 'cyan))
+(define %MAGENTA-N (color-ref 'magenta))
+
+(define (do-init-pair! fg-color bg-color)
+  (init-pair! (color-pair-ref fg-color bg-color)
+              (vector-ref c-vec (color-ref fg-color))
+              (vector-ref c-vec (color-ref bg-color))))
+
+;; slow but whatevs, only done once
+(define (install-colors!)
+  "Install all colors into ncurses"
+  (for-each (lambda (fg-color)
+              (for-each (lambda (bg-color)
+                          (do-init-pair! fg-color bg-color))
+                        colors))
+            colors))
+
+(define* (screen-setup! #:optional (screen (initscr)))
+  (noecho!)                             ; disable echoing characters
+  (raw!)                                ; don't buffer input
+  (keypad! screen #t)                   ; enable <f1>, arrow keys, etc
+  (start-color!)                        ; turn on colors
+  (nodelay! screen #t)
+  (install-colors!)                     ; enable specific colors
+  screen)

bugafriend/ncurses/ncurses-vat.scm

@@ -0,0 +1,64 @@
+;;; Copyright 2023 David Thompson
+;;;
+;;; Licensed under the Apache License, Version 2.0 (the "License");
+;;; you may not use this file except in compliance with the License.
+;;; You may obtain a copy of the License at
+;;;
+;;;    http://www.apache.org/licenses/LICENSE-2.0
+;;;
+;;; Unless required by applicable law or agreed to in writing, software
+;;; distributed under the License is distributed on an "AS IS" BASIS,
+;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+;;; See the License for the specific language governing permissions and
+;;; limitations under the License.
+(define-module (fantasary ncurses-vat)
+  #:use-module (fantasary event-loop)
+  #:use-module (fibers channels)
+  #:use-module (goblins vat)
+  #:use-module (ice-9 atomic)
+  #:export (make-ncurses-vat
+            spawn-ncurses-vat))
+
+;; There's nothing specific to ncurses in here, but this vat
+;; integrates well with our event loop that uses ncurses.
+(define* (make-ncurses-vat tasks #:key (name "ncurses") (log? #f))
+  (define box:running? (make-atomic-box #f))
+  (define box:churn (make-atomic-box #f))
+  (define (churn envelope)
+    ((atomic-box-ref box:churn) envelope))
+  (define (start churn)
+    (atomic-box-set! box:running? #t)
+    (atomic-box-set! box:churn churn))
+  (define (halt)
+    (atomic-box-set! box:running? #f)
+    (atomic-box-set! box:churn #f))
+  (define (send envelope)
+    (cond
+     ;; Message is being sent from outside of the current task queue
+     ;; context, so use a channel to synchronize passing back a return
+     ;; value.
+     ((and (vat-envelope-return? envelope)
+           (not (eq? tasks (current-task-queue))))
+      (let ((return-channel (make-channel)))
+        (add-task! tasks
+                   (lambda ()
+                     (put-message return-channel (churn envelope))))
+        (get-message return-channel)))
+     ;; Message is being sent from within the current task queue
+     ;; context, so process immediately and return the result.
+     ((vat-envelope-return? envelope)
+      (churn envelope))
+     ;; Caller does not care about the return value, so just add it
+     ;; to the task queue for processing later.
+     (else
+      (add-task! tasks (lambda () (churn envelope))))))
+  (make-vat #:name name
+            #:log? log?
+            #:start start
+            #:halt halt
+            #:send send))
+
+(define* (spawn-ncurses-vat tasks #:key (name "ncurses") (log? #f))
+  (let ((vat (make-ncurses-vat tasks #:name name #:log? log?)))
+    (vat-start! vat)
+    vat))

hall.scm

@@ -12,23 +12,26 @@
   (dependencies
     `(("guile-goblins" (goblins) ,guile-goblins)
       ("guile-ncurses" (ncurses curses) ,guile-ncurses)))
+  (skip ())
   (features
     ((guix #f)
      (use-guix-specs-for-dependencies #f)
      (native-language-support #f)
      (licensing #t)))
   (files (libraries
-           ((scheme-file "bugafriend")
-            (directory
+           ((directory
               "bugafriend"
               ((directory
-                 "utils"
-                 ((scheme-file "registry")))
+                 "ncurses"
+                 ((scheme-file "ncurses-stuff")
+                  (scheme-file "ncurses-vat")))
+               (directory "utils" ((scheme-file "registry")))
                (scheme-file "user")
                (scheme-file "room")
                (scheme-file "hconfig")
                (scheme-file "listener")
-               (scheme-file "ui")))))
+               (scheme-file "ui")))
+            (scheme-file "bugafriend")))
          (tests ((directory "tests" ())))
          (programs
            ((directory