vv
/
bugafriend
2
0
Fork 1
Code Issues Pull Requests Packages Activity

Compare commits

base: vv:main
Branches Tags
vv:main
vv:room-experiments
TakeV:room-experiments
TakeV:main
..
compare: TakeV:main
Branches Tags
TakeV:room-experiments
TakeV:main
vv:main
vv:room-experiments

No commits in common. "main" and "main" have entirely different histories.
main ... main

19 changed files with 302 additions and 822 deletions
Show Stats Expand all files Collapse all files

3
.gitignore vendored
View File

@ -27,7 +27,6 @@
/build-aux/texinfo.tex
/config.status
/configure
/configure.ac
/doc/*.1
/doc/.dirstamp
/doc/contributing.*.texi
@ -51,7 +50,6 @@
/doc/version-*.texi
/m4/*
/pre-inst-env
/pre-inst-env.in
/test-env
/test-tmp
/tests/*.trs
@ -59,7 +57,6 @@ GPATH
GRTAGS
GTAGS
Makefile
Makefile.am
Makefile.in
config.cache
stamp-h[0-9]

93
Makefile.am Normal file
View File

@ -0,0 +1,93 @@
bin_SCRIPTS = scripts/listen \
scripts/say \
scripts/listen
nodist_noinst_SCRIPTS = pre-inst-env
GOBJECTS = $(SOURCES:%.scm=%.go)
moddir=$(prefix)/share/guile/site/$(GUILE_EFFECTIVE_VERSION)
godir=$(libdir)/guile/$(GUILE_EFFECTIVE_VERSION)/site-ccache
ccachedir=$(libdir)/guile/$(GUILE_EFFECTIVE_VERSION)/site-ccache
nobase_dist_mod_DATA = $(SOURCES) $(NOCOMP_SOURCES)
nobase_go_DATA = $(GOBJECTS)
# Make sure source files are installed first, so that the mtime of
# installed compiled files is greater than that of installed source
# files. See
# <http://lists.gnu.org/archive/html/guile-devel/2010-07/msg00125.html>
# for details.
guile_install_go_files = install-nobase_goDATA
$(guile_install_go_files): install-nobase_dist_modDATA
GUILE_WARNINGS = -Wunbound-variable -Warity-mismatch -Wformat
SUFFIXES = .scm .go
.scm.go:
$(AM_V_GEN)$(top_builddir)/pre-inst-env $(GUILE_TOOLS) compile $(GUILE_TARGET) $(GUILE_WARNINGS) -o "$@" "$<"
SOURCES = bugafriend.scm \
bugafriend/utils/registry.go \
bugafriend/utils/registry.scm \
bugafriend/hconfig.scm \
bugafriend/hconfig.go \
bugafriend/listener.go \
bugafriend/listener.scm \
bugafriend/ui.go \
bugafriend/ui.scm
TESTS =
TEST_EXTENSIONS = .scm
SCM_LOG_DRIVER = \
$(top_builddir)/pre-inst-env \
$(GUILE) --no-auto-compile -e main \
$(top_srcdir)/build-aux/test-driver.scm
# Tell 'build-aux/test-driver.scm' to display only source file names,
# not indivdual test names.
AM_SCM_LOG_DRIVER_FLAGS = --brief=yes
AM_SCM_LOG_FLAGS = --no-auto-compile -L "$(top_srcdir)"
AM_TESTS_ENVIRONMENT = abs_top_srcdir="$(abs_top_srcdir)"
info_TEXINFOS = doc/version.texi \
doc/bugafriend.texi
EXTRA_DIST = README.org \
README \
HACKING \
COPYING \
doc/.dirstamp \
doc/stamp-vti \
doc/bugafriend.info \
NEWS \
AUTHORS \
ChangeLog \
guix.scm \
.gitignore \
hall.scm \
build-aux/texinfo.tex \
build-aux/test-driver.scm \
build-aux/missing \
build-aux/install-sh \
build-aux/mdate-sh \
configure.ac \
Makefile.am \
pre-inst-env.in \
build-aux/test-driver.scm \
$(TESTS)
ACLOCAL_AMFLAGS = -I m4
AM_DISTCHECK_DVI_TARGET = info # Disable DVI as part of distcheck
clean-go:
-$(RM) $(GOBJECTS)
.PHONY: clean-go
CLEANFILES = \
$(BUILT_SOURCES) \
$(GOBJECTS) \
$(TESTS:tests/%.scm=%.log)

84
bugafriend/event-loop.scm
View File

@ -1,84 +0,0 @@
;;; Copyright 2023 David Thompson
;;; Copyright 2023 Christine Lemmer-Webber
;;; Copyright 2024 Vivianne Langdon
;;; From Fantasary
;;;
;;; 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 (bugafriend event-loop)
#:use-module (bugafriend utils concurrent-queue)
#:use-module (bugafriend ncurses stuff)
#:use-module (ice-9 match)
#:use-module (ncurses curses)
#:use-module (system repl coop-server)
#:export (current-task-queue
add-task!
run-event-loop
halt-event-loop))
(define useconds-per-second 1000000)
;; Ratio for converting high resolution timer values to microseconds.
(define internal-time-divisor
(/ internal-time-units-per-second useconds-per-second))
(define (current-time)
(truncate-quotient (get-internal-run-time) internal-time-divisor))
(define (add-task! tasks thunk)
(concurrent-enqueue! tasks thunk))
(define current-task-queue (make-parameter #f))
(define event-loop-prompt (make-prompt-tag 'event-loop))
(define no-op (lambda _ 'no-op))
(define* (run-event-loop #:key
(init no-op)
(handle-input no-op)
(screen (screen-setup!))
(tasks (make-concurrent-queue))
repl
(hz 60))
(define tick-usecs (truncate-quotient useconds-per-second hz))
(define (consume-all-input)
(match (getch screen)
(#f 'done)
(input
(handle-input screen input)
(consume-all-input))))
(define (process-all-tasks)
(unless (concurrent-queue-empty? tasks)
(let ((thunk (concurrent-dequeue! tasks)))
(when (procedure? thunk)
(thunk)))
(process-all-tasks)))
(define (event-loop)
(define last-usecs (current-time))
(consume-all-input)
(process-all-tasks)
(when repl
(poll-coop-repl-server repl))
(let* ((before-sleep (current-time))
(delay-usecs (max (- (+ last-usecs tick-usecs) before-sleep) 0)))
(usleep delay-usecs))
(event-loop))
(define (boot)
(call-with-prompt event-loop-prompt
(lambda ()
(parameterize ((current-task-queue tasks))
(init screen)
(event-loop)))
(lambda (_k) #t))
(endwin))
(boot))
(define (halt-event-loop)
(abort-to-prompt event-loop-prompt))

16
bugafriend/listener.scm Normal file
View File

@ -0,0 +1,16 @@
(define-module (bugafriend listener)
#:use-module (bugafriend utils registry)
#:use-module (goblins)
#:use-module (goblins ocapn ids)
#:export (listen-chat))
;; Code for the listener
(define (^listener bcom)
(lambda (text) (format #t "~a\n" text)))
(define (listen-chat setup-sref)
(on (prelay-sref->mycapn-registry setup-sref)
(lambda (registry)
(define chat-listener (spawn ^listener))
(define listener-id ($ registry 'register chat-listener))
(format #t "Share this with a friend so they can send a message: ~a\n" (ocapn-id->string listener-id)))))

27
bugafriend/logging.scm
View File

@ -1,27 +0,0 @@
(define-module (bugafriend logging)
#:use-module (bugafriend ncurses stuff)
#:use-module (goblins)
#:use-module (ncurses curses)
#:export (^logger
current-logger
log-str
log-format))
;; Could steal more from fantasary in future...
(define (log-to-curses win prompt-win msg)
(addstr win "\n")
(addstr win msg)
(refresh win)
;; move cursor back to the prompt
(refresh prompt-win))
(define (^logger bcom win prompt-win)
(λ (msg)
(log-to-curses win prompt-win msg)))
(define (log-str logger line)
(<-np logger line))
(define-syntax-rule (log-format logger fmt ...)
(log-str logger (format #f fmt ...)))

90
bugafriend/ncurses/stuff.scm
View File

@ -1,90 +0,0 @@
;;; Copyright 2023 Christine Lemmer-Webber
;;; Copyright 2024 Vivianne Langdon
;;;
;;; 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 (bugafriend 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)

66
bugafriend/ncurses/vat.scm
View File

@ -1,66 +0,0 @@
;;; Copyright 2023 David Thompson
;;; Copyright 2024 Vivianne Langdon
;;; From Fantasary https://gitlab.com/spritely/fantasary
;;;
;;; 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 (bugafriend ncurses vat)
#:use-module (bugafriend 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))

47
bugafriend/room.scm
View File

@ -1,47 +0,0 @@
(define-module (bugafriend room)
#:use-module (bugafriend logging)
#:use-module (goblins)
#:use-module (goblins actor-lib pubsub)
#:use-module (goblins actor-lib methods)
#:export (^room ^room-presence))
(define (^room bcom creator-presence)
"The creator owns the canonical room which publishes to subscribers."
(define pubsub (spawn ^pubsub creator-presence))
(methods
[(add-user presence)
($ pubsub 'subscribe presence)
($ pubsub 'publish 'join presence)]
[(kick-user presence)
($ pubsub 'unsubscribe presence)
($ pubsub 'publish 'leave presence)]
[(say presence message)
($ pubsub 'publish 'say presence message)]
[(me presence message)
($ pubsub 'publish 'me presence message)]))
(define (^room-presence bcom logger name)
"Each user has a presence in the room"
(define (run-with-name user thunk)
(on (<- user 'name)
(λ (name)
(thunk name))))
(methods
[(name) name]
[(join user)
(run-with-name user
(λ (name)
(log-format logger "~a joined." name)))]
[(leave user)
(run-with-name user
(λ (name)
(log-format logger "~a left." name)))]
[(say user message)
(run-with-name user
(λ (name)
(log-format logger "~a: ~a" name message)))]
[(me user message)
(run-with-name user
(λ (name)
(log-format logger "* ~a ~a" name message)))]))

254
bugafriend/ui.scm
View File

@ -1,13 +1,5 @@
(define-module (bugafriend ui)
#:use-module (bugafriend utils registry)
#:use-module (bugafriend utils concurrent-queue)
#:use-module (bugafriend event-loop)
#:use-module (bugafriend ncurses stuff)
#:use-module (bugafriend ncurses vat)
#:use-module (bugafriend logging)
#:use-module (ncurses curses)
#:use-module (bugafriend user)
#:use-module (bugafriend room)
#:use-module (goblins)
#:use-module (goblins vat)
#:use-module (goblins ocapn ids)
@ -19,31 +11,19 @@
#:use-module (ice-9 rdelim)
#:use-module (ice-9 match)
#:use-module (ice-9 exceptions)
#:use-module (ice-9 readline)
#:use-module (ice-9 suspendable-ports)
#:use-module (system repl coop-server)
#:declarative? #f
#:export (run-client))
#:export (say))
(define %BACKSPACE 263)
(define screen (screen-setup!))
;; ;; https://www.gnu.org/software/guile/manual/guile.html#Non_002dBlocking-I_002fO
;; (let* ((input (current-input-port))
;; (flags (fcntl input F_GETFL)))
;; (fcntl input F_SETFL (logior O_NONBLOCK flags)))
;; (install-suspendable-ports!)
;; Can we use the goblins queue actor instead?
(define tasks (make-concurrent-queue))
(define user-vat #f)
(define ui-vat #f)
(define prompt-input '())
(define logger #f)
(define ocapn-registry #f)
(define user-actor #f)
(define setup-sref #f)
(define username #f)
(define title-win #f)
(define log-win #f)
(define prompt-win #f)
(define listener-actor #f)
(define (is-command? str)
(and (> (string-length str) 0) (eq? (string-ref str 0) #\/)))
@ -55,178 +35,100 @@
(help console-command-help)
(thunk console-command-thunk))
(define (refresh-prompt)
(define size (getmaxyx screen))
(define height (list-ref size 0))
(define width (list-ref size 1))
(define prompt-str (list->string (reverse prompt-input)))
(define prompt-str-len (string-length prompt-str))
(define max-prompt-to-show (- width 4))
(clear prompt-win)
(hline prompt-win (acs-hline) width #:x 0 #:y 0)
(addch prompt-win
(color %YELLOW-N (bold #\>))
#:x 1 #:y 1)
(addstr prompt-win
;; cut off the length of the string shown, if the user has typed a lot
(if (> prompt-str-len max-prompt-to-show)
(let ((str-start (- prompt-str-len max-prompt-to-show)))
(substring prompt-str str-start))
prompt-str)
#:x 3 #:y 1)
(resize log-win (- height 2) width)
(resize prompt-win 2 width)
(mvwin prompt-win (- height 2) 0)
(move prompt-win 1 (+ 3 (length prompt-input)))
(refresh prompt-win))
(define commands
(list
(make-console-command
'quit
"/quit"
"- Exits the chat"
;; TODO
(λ (args) #f))
(λ (args) (loop! #f)))
(make-console-command
'help
"/help"
"- Prints this help"
(λ (args)
(print-help)))
(print-help)
(loop! #t)))
(make-console-command
'create
"- Create a new chat and join it."
"/join"
"<listener-id> - Switch chats to another listener"
(λ (args)
($ user-actor 'make-room)
(on (<- ocapn-registry 'register ($ user-actor 'room))
(λ (id)
(format #t "Logger: ~s\n" logger)
(log-str logger (format #f "Room ID: ~a" (ocapn-id->string id)))))))
(make-console-command
'me
"<text> - Me command, you like roleplay or whatever"
(λ (args)
;; eww, maybe fix mangling the input by joining
(say-command 'me (string-join args " "))))
(make-console-command
'join
"<room-id> - Switch chats to another room"
(λ (args)
(if (eq? 2 (length args))
(let* ((room-id (list-ref args 1))
(room-sref (string->ocapn-id room-id)))
(if room-sref
(if ocapn-registry
(on (<- ocapn-registry 'enliven room-sref)
(λ (r)
($ user-actor 'join-room r))
#:catch
(λ (e)
(log-format logger "Failed: ~a" e)))
(log-str logger "Relay not yet connected."))
(log-str logger "Badly formatted sturdyref!")))
(log-str logger "Need one argument, the room sturdyref!"))))))
(unless (eq? 2 (length args))
(error "Need one argument, the listener sturdyref!"))
(define (say-command line method)
"The implicit command"
(let ((room ($ user-actor 'room))
(presence ($ user-actor 'presence)))
(if (and room presence)
(<-np room method presence line)
(log-str logger "Not in a room yet. Use /create or /join <sturdyref>!"))))
(let* ((listener-id (list-ref args 1))
(listener-sref (string->ocapn-id listener-id)))
(unless listener-sref
(error "Badly formatted sturdyref!"))
(unless ocapn-registry
(error "Relay not yet connected."))
(format #t "Connecting...\n")
(on (<- ocapn-registry 'enliven listener-sref)
(λ (l)
(set! listener-actor l)
(format #t "Joined chat.\n")
(loop! #t))
#:catch
(λ (e)
(format #t "Failed: ~a\n" e)
(loop! #t))))))))
(define (print-help)
(log-str logger "Command reference:")
(map (λ (x) (log-format logger " ~a ~a" (console-command-name x) (console-command-help x))) commands))
(format #t "Command reference:\n")
(map (λ (x) (format #t " ~a ~a\n" (console-command-name x) (console-command-help x))) commands))
(define command-names (map console-command-name commands))
(define (%eval-command cmd)
(define args (string-split cmd char-set:whitespace))
(define first-arg (car args))
(define matching-command (find (λ (x) (equal? (console-command-name x) (car args))) commands))
(if matching-command
((console-command-thunk matching-command) args)
(begin
(format #t "Don't know how to handle ~a.\n\n" cmd)
(print-help)
(loop! #t))))
(define (find-matching-command)
(and first-arg
(is-command? first-arg)
(find (λ (x) (equal? (symbol->string (console-command-name x)) (substring first-arg 1))) commands)))
(define loop-channel (make-channel))
(define (loop! val) (put-message loop-channel val) val)
(with-vat user-vat
(let ((matching-command (find-matching-command)))
(cond
(matching-command
((console-command-thunk matching-command) args))
((= 0 (string-length cmd) #f))
(else (say-command cmd 'say))))))
(define (%loop vat)
(with-exception-handler
(λ (e)
(format #t "Command failed: ~s\n" e)
(loop! #t))
(λ ()
(let ((line (readline)))
(with-vat vat
(cond
((eq? 0 (string-length line)) (loop! #t))
((is-command? line)
(%eval-command line))
(else (if listener-actor
(on (<- listener-actor line) (λ (val) (loop! val)))
(begin
(format #t "Not connected to anyone yet. Use /join <sturdyref>!\n")
(loop! #t))))))))
#:unwind? #t))
(define (init screen)
(define size (getmaxyx screen))
(define height (list-ref size 0))
(define width (list-ref size 1))
(define prompt-height 2)
(set! prompt-win
(newwin prompt-height width (- height prompt-height) 0))
(set! log-win
(newwin (- height prompt-height)
width 0 0))
(scrollok! log-win #t)
(idcok! log-win #t)
(setscrreg! log-win 0 (- height prompt-height))
(move log-win (getmaxy log-win) 0)
(define (say setup-sref)
(define vat (spawn-vat #:name "Speaker Vat"))
(with-vat user-vat
(set! logger (spawn ^logger log-win prompt-win))
(set! user-actor (spawn ^user logger username #f))
(log-str logger "Connecting to relay...")
(set-readline-prompt! " 🐞 > ")
(with-vat vat
(format #t "Connecting to relay...\n")
(on (prelay-sref->mycapn-registry setup-sref)
(λ (r)
(set! ocapn-registry r)
(log-str logger "Connected."))
(format #t "Connected.\n")
(loop! #t))
#:catch
(λ (e)
(log-format logger "Failed: ~a" e))))
(format #t "Failed: ~a\n" e)
(loop! #t))))
(add-task! tasks refresh-prompt))
(define (handle-input screen char)
(cond
;; Exit
((or (eqv? char #\esc) (eqv? char #\etx))
(halt-event-loop))
;; Resized window
((eqv? char KEY_RESIZE)
(add-task! tasks refresh-prompt))
;; Backspace
((or (eqv? char %BACKSPACE) (eqv? char #\delete))
(set! prompt-input (match prompt-input
(() '())
((_ chars ...) chars))))
;; Submit command
((eqv? char #\newline)
(let ((input (string-trim-both (list->string (reverse prompt-input)))))
(unless (string-null? input)
(%eval-command input))
(set! prompt-input '())))
;; Add a char to the command line
((and (char? char) ; some "characters" might be integers
(char-set-contains? char-set:printing char))
(set! prompt-input (cons char prompt-input))))
(refresh-prompt))
(define-syntax-rule (trampoline proc args ...)
(lambda (args ...)
(proc args ...)))
(define (run-client setup name)
(parameterize ((current-output-port (%make-void-port "w")))
(set! user-vat (spawn-vat #:name "User" #:log? #t))
(set! ui-vat (spawn-ncurses-vat tasks #:name "UI" #:log? #t)))
(set! username name)
(set! setup-sref setup)
(run-event-loop
#:init (trampoline init screen)
#:handle-input (trampoline handle-input screen char)
#:tasks tasks
#:repl (false-if-exception (spawn-coop-repl-server))
#:screen screen))
(while (get-message loop-channel)
(with-vat vat
(syscaller-free-fiber
(λ ()
(%loop vat))))))

37
bugafriend/user.scm
View File

@ -1,37 +0,0 @@
(define-module (bugafriend user)
#:use-module (bugafriend room)
#:use-module (goblins)
#:use-module (goblins ocapn ids)
#:use-module (goblins actor-lib methods)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-9)
#:export (^user))
(define-record-type <room-data>
(make-room-data room presence)
room-data?
(room room-data-room)
(presence room-data-presence))
(define (^user bcom logger name room-data)
(methods
[(room) (and room-data (room-data-room room-data))]
[(presence) (and room-data (room-data-presence room-data))]
[(make-room)
(let* ((my-presence (spawn ^room-presence logger name))
(room (spawn ^room my-presence))
(room-data (make-room-data room my-presence)))
(bcom (^user bcom logger name room-data)))]
[(join-room room)
(let ((my-presence (spawn ^room-presence logger name)))
(when room-data
(<-np (room-data-room room-data) 'kick-user (room-data-presence room-data)))
(<- room 'add-user my-presence)
(bcom (^user bcom logger name (make-room-data room my-presence))))]
[(leave-room room)
(when (eq? room (room-data-room room-data))
(<-np room 'kick-user (room-data-presence room-data))
(bcom (^user bcom logger name #f)))]))

171
bugafriend/utils/array-list.scm
View File

@ -1,171 +0,0 @@
;;; Snarfed from Chickadee and then Fantasary
;;; Copyright © 2017 David Thompson
;;; Copyright © 2024 Vivianne Langdon
;;;
;;; 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 (bugafriend utils array-list)
#:use-module (ice-9 format)
#:use-module (rnrs base)
#:use-module (srfi srfi-9)
#:use-module (srfi srfi-9 gnu)
#:use-module (srfi srfi-43)
#:export (make-array-list
array-list
array-list?
array-list-empty?
array-list-size
array-list-ref
array-list-set!
array-list-push!
array-list-pop!
array-list-delete!
array-list-clear!
array-list-for-each
array-list-fold))
;; This macro is actually snarfed from (chickadee utils)
(define-syntax for-range
(syntax-rules ()
((_ ((var end start inc)) body ...)
(let* ((s start) ; evaluate start/end only once
(e end)
(reverse? (< e s))
(start* (if reverse? e s))
(end* (if reverse? s e))
(inc* (abs inc)))
(let loop ((var start*))
(when (< var end*)
body ...
(loop (+ var inc*))))))
((_ ((var end start)) body ...)
(for-range ((var end start 1)) body ...))
((_ ((var end)) body ...)
(for-range ((var end 0 1)) body ...))
((_ ((var args ...) rest ...) body ...)
(for-range ((var args ...))
(for-range (rest ...)
body ...)))))
(define-record-type <array-list>
(%make-array-list vector size)
array-list?
(vector array-list-vector set-array-list-vector!)
(size array-list-size set-array-list-size!))
(define (display-array-list array-list port)
(display "<array-list" port)
(array-list-for-each (lambda (i item)
(display " " port)
(display item port))
array-list)
(display ">" port))
(set-record-type-printer! <array-list> display-array-list)
(define* (make-array-list #:optional (initial-capacity 32))
(%make-array-list (make-vector initial-capacity) 0))
(define (array-list . items)
(let ((l (make-array-list)))
(for-each (lambda (item)
(array-list-push! l item))
items)
l))
(define (array-list-capacity array-list)
(vector-length (array-list-vector array-list)))
(define (array-list-full? array-list)
(= (array-list-size array-list)
(array-list-capacity array-list)))
(define (array-list-empty? array-list)
(zero? (array-list-size array-list)))
(define (expand-array-list! array-list)
(let* ((old-vec (array-list-vector array-list))
(old-size (vector-length old-vec))
(new-size (+ old-size (div old-size 2)))
(new-vec (make-vector new-size)))
(vector-copy! new-vec 0 old-vec)
(set-array-list-vector! array-list new-vec)))
(define (array-list-ref array-list i)
(if (and (>= i 0) (< i (array-list-size array-list)))
(vector-ref (array-list-vector array-list) i)
(error "array list index out of bounds" i)))
(define (array-list-set! array-list i x)
(vector-set! (array-list-vector array-list) i x))
(define (array-list-push! array-list item)
(when (array-list-full? array-list)
(expand-array-list! array-list))
(let ((index (array-list-size array-list)))
(set-array-list-size! array-list (1+ index))
(array-list-set! array-list index item)))
(define (array-list-pop! array-list)
(let* ((index (1- (array-list-size array-list)))
(item (array-list-ref array-list index)))
;; Remove element reference so it can be GC'd.
(array-list-set! array-list index #f)
(set-array-list-size! array-list index)
item))
(define* (array-list-delete! array-list item #:key (equal? equal?) fast?)
(let* ((v (array-list-vector array-list))
(n (array-list-size array-list)))
(let loop ((i 0))
(when (< i n)
(if (equal? item (vector-ref v i))
(begin
(if fast?
;; Fast: Swap the last element with the element to be
;; deleted. Constant time but does not preserve
;; order.
(let ((last (- n 1)))
(vector-set! v i (vector-ref v last))
(vector-set! v last #f))
;; Slow: Shift all elements to the left. Linear time
;; but preserves order.
(let shift ((j (+ i 1)))
(if (= j n)
(vector-set! v j #f)
(begin
(vector-set! v (- j 1) (vector-ref v j))
(shift (+ j 1))))))
(set-array-list-size! array-list (- n 1)))
(loop (+ i 1)))))))
(define (array-list-clear! array-list)
(let ((vec (array-list-vector array-list)))
;; Remove all element references so they can be GC'd.
(for-range ((i (array-list-size array-list)))
(vector-set! vec i #f)))
(set-array-list-size! array-list 0)
*unspecified*)
(define (array-list-for-each proc array-list)
(let ((vec (array-list-vector array-list)))
(for-range ((i (array-list-size array-list)))
(proc i (vector-ref vec i)))))
(define (array-list-fold proc init array-list)
(let ((vec (array-list-vector array-list)))
(let loop ((i 0)
(prev init))
(if (< i (array-list-size array-list))
(loop (1+ i) (proc i (vector-ref vec i) prev))
prev))))

102
bugafriend/utils/concurrent-queue.scm
View File

@ -1,102 +0,0 @@
;;; Copyright 2023 David Thompson
;;; Copyright 2024 Vivianne Langdon
;;; From Fantasary https://gitlab.com/spritely/fantasary
;;;
;;; 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 (bugafriend utils concurrent-queue)
#:use-module (bugafriend utils array-list)
#:use-module (ice-9 format)
#:use-module (ice-9 threads)
#:use-module (srfi srfi-9)
#:use-module (srfi srfi-9 gnu)
#:export (make-concurrent-queue
concurrent-queue?
concurrent-queue-length
concurrent-queue-empty?
concurrent-enqueue!
concurrent-dequeue!
concurrent-queue-clear!
concurrent-queue-close!))
(define-record-type <concurrent-queue>
(%make-concurrent-queue input output mutex condvar)
concurrent-queue?
(input concurrent-queue-input)
(output concurrent-queue-output)
(mutex concurrent-queue-mutex)
(condvar concurrent-queue-condvar)
(closed? concurrent-queue-closed? set-concurrent-queue-closed!))
(define (display-concurrent-queue q port)
(format port "#<concurrent-queue length: ~d>" (concurrent-queue-length q)))
(set-record-type-printer! <concurrent-queue> display-concurrent-queue)
(define (make-concurrent-queue)
"Return a new, empty queue."
(%make-concurrent-queue (make-array-list) (make-array-list)
(make-mutex) (make-condition-variable)))
(define (concurrent-queue-length q)
"Return the number of elements in Q."
(+ (array-list-size (concurrent-queue-input q))
(array-list-size (concurrent-queue-output q))))
(define (concurrent-queue-empty? q)
"Return #t if Q is empty."
(zero? (concurrent-queue-length q)))
(define (concurrent-enqueue! q item)
"Add ITEM to Q."
(if (concurrent-queue-closed? q)
(error "queue is closed" q)
(begin
(with-mutex (concurrent-queue-mutex q)
(array-list-push! (concurrent-queue-input q) item))
(signal-condition-variable (concurrent-queue-condvar q)))))
(define (concurrent-dequeue! q)
"Remove the first element of Q."
(if (and (concurrent-queue-empty? q)
(concurrent-queue-closed? q))
#f
(with-mutex (concurrent-queue-mutex q)
;; If the queue is empty, block until there's something to
;; dequeue.
(when (concurrent-queue-empty? q)
(wait-condition-variable (concurrent-queue-condvar q)
(concurrent-queue-mutex q)))
(if (concurrent-queue-empty? q)
#f
(let ((input (concurrent-queue-input q))
(output (concurrent-queue-output q)))
(when (array-list-empty? output)
(let loop ()
(unless (array-list-empty? input)
(array-list-push! output (array-list-pop! input))
(loop))))
(array-list-pop! output))))))
(define (concurrent-queue-clear! q)
"Remove all items from Q."
(with-mutex (concurrent-queue-mutex q)
(array-list-clear! (concurrent-queue-input q))
(array-list-clear! (concurrent-queue-output q))))
(define (concurrent-queue-close! q)
"Close Q so that no more items may be enqueued."
(with-mutex (concurrent-queue-mutex q)
(set-concurrent-queue-closed! q #t)
(when (concurrent-queue-empty? q)
(signal-condition-variable (concurrent-queue-condvar q)))))

41
configure.ac Normal file
View File

@ -0,0 +1,41 @@
dnl -*- Autoconf -*-
AC_INIT(bugafriend, 0.1)
AC_SUBST(HVERSION, "\"0.1\"")
AC_SUBST(AUTHOR, "\"Vivi Langdon\"")
AC_SUBST(COPYRIGHT, "'(2024)")
AC_SUBST(LICENSE, gpl3+)
AC_CONFIG_SRCDIR(bugafriend.scm)
AC_CONFIG_AUX_DIR([build-aux])
AM_INIT_AUTOMAKE([1.12 gnu silent-rules subdir-objects color-tests parallel-tests -Woverride -Wno-portability])
AM_SILENT_RULES([yes])
AC_CONFIG_FILES([Makefile])
AC_CONFIG_FILES([pre-inst-env], [chmod +x pre-inst-env])
AC_CONFIG_FILES([scripts/say],[chmod +x scripts/say])
AC_CONFIG_FILES([scripts/listen],[chmod +x scripts/listen])
dnl Search for 'guile' and 'guild'. This macro defines
dnl 'GUILE_EFFECTIVE_VERSION'.
GUILE_PKG([3.0 2.2 2.0])
GUILE_PROGS
GUILE_SITE_DIR
if test "x$GUILD" = "x"; then
AC_MSG_ERROR(['guild' binary not found; please check your guile-2.x installation.])
fi
if test "$cross_compiling" != no; then
GUILE_TARGET="--target=$host_alias"
AC_SUBST([GUILE_TARGET])
fi
dnl Hall auto-generated guile-module dependencies
GUILE_MODULE_REQUIRED([goblins])
GUILE_MODULE_REQUIRED([ncurses curses])
dnl Installation directories for .scm and .go files.
guilemoduledir="${datarootdir}/guile/site/$GUILE_EFFECTIVE_VERSION"
guileobjectdir="${libdir}/guile/$GUILE_EFFECTIVE_VERSION/site-ccache"
AC_SUBST([guilemoduledir])
AC_SUBST([guileobjectdir])
AC_OUTPUT

40
hall.scm
View File

@ -19,29 +19,26 @@
(native-language-support #f)
(licensing #t)))
(files (libraries
((directory
((scheme-file "bugafriend")
(directory
"bugafriend"
((scheme-file "logging")
(directory
((directory
"utils"
((scheme-file "array-list")
(scheme-file "concurrent-queue")
((compiled-scheme-file "registry")
(scheme-file "registry")))
(directory
"ncurses"
((scheme-file "vat") (scheme-file "stuff")))
(scheme-file "event-loop")
(scheme-file "user")
(scheme-file "room")
(scheme-file "hconfig")
(scheme-file "ui")))
(directory "scripts" ((in-file "run-client")))
(scheme-file "bugafriend")))
(compiled-scheme-file "hconfig")
(compiled-scheme-file "listener")
(scheme-file "listener")
(compiled-scheme-file "ui")
(scheme-file "ui")))))
(tests ((directory "tests" ())))
(programs
((directory
"scripts"
((text-file "run-client")))))
((text-file "listen")
(in-file "say")
(in-file "listen")))))
(documentation
((org-file "README")
(symlink "README" "README.org")
@ -53,7 +50,6 @@
(text-file ".dirstamp")
(text-file "stamp-vti")
(info-file "bugafriend")
(info-file "version")
(texi-file "bugafriend")))
(text-file "NEWS")
(text-file "AUTHORS")
@ -61,4 +57,14 @@
(infrastructure
((scheme-file "guix")
(text-file ".gitignore")
(scheme-file "hall")))))
(scheme-file "hall")
(directory
"build-aux"
((tex-file "texinfo")
(scheme-file "test-driver")
(text-file "missing")
(text-file "install-sh")
(text-file "mdate-sh")))
(autoconf-file "configure")
(automake-file "Makefile")
(in-file "pre-inst-env")))))

13
pre-inst-env.in Normal file
View File

@ -0,0 +1,13 @@
#!/bin/sh
abs_top_srcdir="`cd "@abs_top_srcdir@" > /dev/null; pwd`"
abs_top_builddir="`cd "@abs_top_builddir@" > /dev/null; pwd`"
GUILE_LOAD_COMPILED_PATH="$abs_top_builddir${GUILE_LOAD_COMPILED_PATH:+:}$GUILE_LOAD_COMPILED_PATH"
GUILE_LOAD_PATH="$abs_top_builddir:$abs_top_srcdir${GUILE_LOAD_PATH:+:}:$GUILE_LOAD_PATH"
export GUILE_LOAD_COMPILED_PATH GUILE_LOAD_PATH
PATH="$abs_top_builddir/scripts:$PATH"
export PATH
exec "$@"

17
scripts/listen Executable file
View File

@ -0,0 +1,17 @@
#!/home/vv/.guix-profile/bin/guile --no-auto-compile
-*- scheme -*-
!#
(use-modules
(goblins)
(goblins ocapn ids)
(fibers conditions)
(bugafriend listener))
;; So far nothing triggers this for listener
(define can-quit? (make-condition))
(with-vat (spawn-vat #:name "Listener UI")
(listen-chat (string->ocapn-id (list-ref (command-line) 1))))
(wait can-quit?)

17
scripts/listen.in Normal file
View File

@ -0,0 +1,17 @@
#!@GUILE@ --no-auto-compile
-*- scheme -*-
!#
(use-modules
(goblins)
(goblins ocapn ids)
(fibers conditions)
(bugafriend listener))
;; So far nothing triggers this for listener
(define can-quit? (make-condition))
(with-vat (spawn-vat #:name "Listener UI")
(listen-chat (string->ocapn-id (list-ref (command-line) 1))))
(wait can-quit?)

3
scripts/run-client → scripts/say Normal file → Executable file
View File

@ -5,6 +5,7 @@
(use-modules
(goblins)
(goblins ocapn ids)
(fibers conditions)
(bugafriend ui))
(run-client (string->ocapn-id (list-ref (command-line) 1)) (list-ref (command-line) 2))
(say (string->ocapn-id (list-ref (command-line) 1)))

3
scripts/run-client.in → scripts/say.in
View File

@ -5,6 +5,7 @@
(use-modules
(goblins)
(goblins ocapn ids)
(fibers conditions)
(bugafriend ui))
(run-client (string->ocapn-id (list-ref (command-line) 1)) (list-ref (command-line) 2))
(say (string->ocapn-id (list-ref (command-line) 1)))