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

Curses implementation, lots stolen from fantasary

This commit is contained in:
Vivianne 2024-02-03 04:49:24 -05:00
parent 62c1d9220a
commit e0f035a7fb
12 changed files with 596 additions and 122 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

84
bugafriend/event-loop.scm Normal file
View File

@ -0,0 +1,84 @@
;;; 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))

27
bugafriend/logging.scm Normal file
View File

@ -0,0 +1,27 @@
(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 msg)
(move win (+ 1 (getcury win)) 0)
(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 ...)))

9
bugafriend/ncurses/ncurses-stuff.scm → bugafriend/ncurses/stuff.scm
View File

@ -1,4 +1,5 @@
;;; 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.
@ -12,7 +13,7 @@
;;; See the License for the specific language governing permissions and
;;; limitations under the License.
(define-module (fantasary ncurses-stuff)
(define-module (bugafriend ncurses stuff)
#:use-module (ncurses curses)
#:use-module (rnrs enums)
#:export (%YELLOW-N
@ -81,7 +82,9 @@
(noecho!) ; disable echoing characters
(raw!) ; don't buffer input
(keypad! screen #t) ; enable <f1>, arrow keys, etc
(start-color!) ; turn on colors
;; (start-color!)
; turn on colors
(nodelay! screen #t)
(install-colors!) ; enable specific colors
;; (install-colors!)
; enable specific colors
screen)

6
bugafriend/ncurses/ncurses-vat.scm → bugafriend/ncurses/vat.scm
View File

@ -1,4 +1,6 @@
;;; 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.
@ -11,8 +13,8 @@
;;; 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)
(define-module (bugafriend ncurses vat)
#:use-module (bugafriend event-loop)
#:use-module (fibers channels)
#:use-module (goblins vat)
#:use-module (ice-9 atomic)

11
bugafriend/room.scm
View File

@ -1,4 +1,5 @@
(define-module (bugafriend room)
#:use-module (bugafriend logging)
#:use-module (goblins)
#:use-module (goblins actor-lib pubsub)
#:use-module (goblins actor-lib methods)
@ -19,7 +20,7 @@
[(me presence message)
($ pubsub 'publish 'me presence message)]))
(define (^room-presence bcom name)
(define (^room-presence bcom logger name)
"Each user has a presence in the room"
(define (run-with-name user thunk)
(on (<- user 'name)
@ -31,16 +32,16 @@
[(join user)
(run-with-name user
(λ (name)
(format #t "~a joined.\n" name)))]
(log-format logger "~a joined." name)))]
[(leave user)
(run-with-name user
(λ (name)
(format #t "~a left.\n" name)))]
(log-format logger "~a left." name)))]
[(say user message)
(run-with-name user
(λ (name)
(format #t "~a: ~a\n" name message)))]
(log-format logger "~a: ~a" name message)))]
[(me user message)
(run-with-name user
(λ (name)
(format #t "* ~a ~a\n" name message)))]))
(log-format logger "* ~a ~a" name message)))]))

244
bugafriend/ui.scm
View File

@ -1,5 +1,11 @@
(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)
@ -14,17 +20,30 @@
#:use-module (ice-9 match)
#:use-module (ice-9 exceptions)
#:use-module (ice-9 suspendable-ports)
#:export (say))
#:use-module (system repl coop-server)
#:declarative? #f
#:export (run-client))
;; 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!)
(define %BACKSPACE 263)
(define screen (screen-setup!))
;; 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 (is-command? str)
(and (> (string-length str) 0) (eq? (string-ref str 0) #\/)))
@ -36,122 +55,171 @@
(help console-command-help)
(thunk console-command-thunk))
(define (get-a-room)
($ user-actor 'room-data))
(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 3 width)
(move prompt-win 1 (+ 3 (length prompt-input)))
(refresh prompt-win))
(define commands
(list
(make-console-command
"/quit"
'quit
"- Exits the chat"
(λ (args) (loop! #f)))
;; TODO
(λ (args) #f))
(make-console-command
"/help"
'help
"- Prints this help"
(λ (args)
(print-help)
(loop! #t)))
(print-help)))
(make-console-command
"/create"
'create
"- Create a new chat and join it."
(λ (args)
($ user-actor 'make-room)
(loop! #t)))
(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"
'me
"<text> - Me command, you like roleplay or whatever"
(λ (args)
(let* ((room-data (get-a-room))
(room (room-data-room room-data))
(presence (room-data-presence room-data)))
;; eww, maybe fix mangling the input by joining
(<- room 'me presence (string-join args " "))
(loop! #t))))
(say-command 'me (string-join args " "))))
(make-console-command
"/join"
'join
"<room-id> - Switch chats to another room"
(λ (args)
(unless (eq? 2 (length args))
(error "Need one argument, the room sturdyref!"))
(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!"))))))
(let* ((room-id (list-ref args 1))
(room-sref (string->ocapn-id room-id)))
(unless room-sref
(error "Badly formatted sturdyref!"))
(unless ocapn-registry
(error "Relay not yet connected."))
(on (<- ocapn-registry 'enliven room-sref)
(λ (r)
($ user-actor 'join-room r)
(loop! #t))
#:catch
(λ (e)
(format #t "Failed: ~a\n" e)
(loop! #t))))))))
(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>!"))))
(define (print-help)
(format #t "Command reference:\n")
(map (λ (x) (format #t " ~a ~a\n" (console-command-name x) (console-command-help x))) commands))
(log-str logger "Command reference:")
(map (λ (x) (log-format logger " ~a ~a" (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 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 first-arg (car args))
(define loop-channel (make-channel))
(define (loop! val) (put-message loop-channel val) val)
(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 vat)
(with-exception-handler
(λ (e)
(format #t "Command failed: ~s\n" e)
(loop! #t))
(λ ()
(let ((line (read-line (current-input-port))))
(with-vat vat
(cond
((eq? 0 (string-length line)) (loop! #t))
((is-command? line)
(%eval-command line))
(else
(let ((room-data (get-a-room)))
(if room-data
(let ((room (room-data-room room-data))
(presence (room-data-presence room-data)))
(on (<- room 'say presence line)
(λ (val) (loop! val))))
(begin
(format #t "Not in a room yet. Use /create or /join <sturdyref>!\n")
(loop! #t)))))))))
#:unwind? #t))
(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 (say setup-sref name)
(define vat (spawn-vat #:name "Speaker Vat"))
(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)
(with-vat
vat
(format #t "Connecting to relay...\n")
(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...")
(on (prelay-sref->mycapn-registry setup-sref)
(λ (r)
(set! ocapn-registry r)
(format #t "Connected. Creating user actor.\n")
(set! user-actor (spawn ^user name ocapn-registry #f))
(loop! #t))
(log-str logger "Connected."))
#:catch
(λ (e)
(format #t "Failed: ~a\n" e)
(loop! #t))))
(log-format logger "Failed: ~a" e))))
(while (get-message loop-channel)
(with-vat vat
(syscaller-free-fiber
(λ ()
(%loop vat))))))
(add-task! tasks refresh-prompt))
(define (handle-input screen char)
(cond
;; Exit
((or (eqv? char #\esc) (eqv? char #\etx))
(halt-event-loop))
;; 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))

30
bugafriend/user.scm
View File

@ -1,16 +1,11 @@
(define-module (bugafriend user)
#:use-module (bugafriend utils registry)
#: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
make-room-data
room-data?
room-data-room
room-data-presence))
#:export (^user))
(define-record-type <room-data>
(make-room-data room presence)
@ -18,32 +13,27 @@
(room room-data-room)
(presence room-data-presence))
(define (^user bcom name registry joined-room-data)
(define (^user bcom logger name joined-room-data)
(methods
[(room-data) joined-room-data]
[(room) (room-data-room joined-room-data)]
[(presence) (room-data-presence joined-room-data)]
[(make-room)
(let* ((my-presence (spawn ^room-presence name))
(let* ((my-presence (spawn ^room-presence logger name))
(room (spawn ^room my-presence))
(room-data (make-room-data room my-presence)))
(on (<- registry 'register room)
(λ (id)
(format #t "New room ID: ~a\n" (ocapn-id->string id))))
(bcom (^user bcom name registry room-data)))]
(bcom (^user bcom logger name room-data)))]
[(join-room room)
(format #t "Connecting...\n")
(let ((my-presence (spawn ^room-presence name)))
(let ((my-presence (spawn ^room-presence logger name)))
(when joined-room-data
(<-np (room-data-room joined-room-data) 'kick-user (room-data-presence joined-room-data)))
(on (<- room 'add-user my-presence)
(λ (_)
(format #t "Joined room.\n")))
(<- room 'add-user my-presence)
(define room-data (make-room-data room my-presence))
(bcom (^user bcom name registry room-data)))]
(bcom (^user bcom logger name room-data)))]
[(leave-room room)
(when (eq? room (room-data-room joined-room-data))
(<-np room 'kick-user (room-data-presence joined-room-data))
(bcom (^user bcom name registry #f)))]))
(bcom (^user bcom logger name #f)))]))

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

@ -0,0 +1,171 @@
;;; 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 Normal file
View File

@ -0,0 +1,102 @@
;;; 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)))))

14
hall.scm
View File

@ -21,16 +21,22 @@
(files (libraries
((directory
"bugafriend"
((directory
((scheme-file "logging")
(directory
"utils"
((scheme-file "array-list")
(scheme-file "concurrent-queue")
(scheme-file "registry")))
(directory
"ncurses"
((scheme-file "ncurses-stuff")
(scheme-file "ncurses-vat")))
(directory "utils" ((scheme-file "registry")))
((scheme-file "vat") (scheme-file "stuff")))
(scheme-file "event-loop")
(scheme-file "user")
(scheme-file "room")
(scheme-file "hconfig")
(scheme-file "listener")
(scheme-file "ui")))
(directory "scripts" ((in-file "run-client")))
(scheme-file "bugafriend")))
(tests ((directory "tests" ())))
(programs

10
scripts/run-client Executable file
View File

@ -0,0 +1,10 @@
#!/home/vv/.guix-profile/bin/guile --no-auto-compile
-*- scheme -*-
!#
(use-modules
(goblins)
(goblins ocapn ids)
(bugafriend ui))
(run-client (string->ocapn-id (list-ref (command-line) 1)) (list-ref (command-line) 2))

10
scripts/run-client.in Normal file
View File

@ -0,0 +1,10 @@
#!@GUILE@ --no-auto-compile
-*- scheme -*-
!#
(use-modules
(goblins)
(goblins ocapn ids)
(bugafriend ui))
(run-client (string->ocapn-id (list-ref (command-line) 1)) (list-ref (command-line) 2))