diff --git a/bugafriend/ncurses/ncurses-stuff.scm b/bugafriend/ncurses/ncurses-stuff.scm new file mode 100644 index 0000000..062c238 --- /dev/null +++ b/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 , arrow keys, etc + (start-color!) ; turn on colors + (nodelay! screen #t) + (install-colors!) ; enable specific colors + screen) diff --git a/bugafriend/ncurses/ncurses-vat.scm b/bugafriend/ncurses/ncurses-vat.scm new file mode 100644 index 0000000..12d0ce8 --- /dev/null +++ b/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)) diff --git a/hall.scm b/hall.scm index 90dd71f..40a5bb0 100644 --- a/hall.scm +++ b/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