Add event emitter, trie, rate limiter, pool, and state machine
ober
f511831e81c29901d4f38a24c8c5da96c74e415a
new file mode 100644 --- /dev/null +++ b/lib/std/misc/event-emitter.sls @@ -0,0 +1,97 @@ +#!chezscheme +;;; (std misc event-emitter) -- Pub/Sub Event System +;;; +;;; Node.js-style EventEmitter for decoupled architecture. +;;; +;;; Usage: +;;; (import (std misc event-emitter)) +;;; (define ee (make-event-emitter)) +;;; (on ee 'data (lambda (x) (printf "got ~a~n" x))) +;;; (once ee 'done (lambda () (printf "finished~n"))) +;;; (emit ee 'data 42) +;;; (emit ee 'done) +;;; (off ee 'data) + +(library (std misc event-emitter) + (export + make-event-emitter + event-emitter? + on + once + off + off-all + emit + listeners + listener-count + event-names) + + (import (chezscheme)) + + (define-record-type event-emitter-rec + (fields (mutable handlers)) ;; hashtable: event-name -> list of (handler . once?) + (protocol (lambda (new) + (lambda () (new (make-eq-hashtable)))))) + + (define (make-event-emitter) (make-event-emitter-rec)) + (define (event-emitter? x) (event-emitter-rec? x)) + + (define (on ee event handler) + ;; Register a persistent listener + (let* ([ht (event-emitter-rec-handlers ee)] + [existing (hashtable-ref ht event '())]) + (hashtable-set! ht event (append existing (list (cons handler #f)))))) + + (define (once ee event handler) + ;; Register a one-time listener + (let* ([ht (event-emitter-rec-handlers ee)] + [existing (hashtable-ref ht event '())]) + (hashtable-set! ht event (append existing (list (cons handler #t)))))) + + (define off + (case-lambda + [(ee event) + ;; Remove all listeners for event + (hashtable-delete! (event-emitter-rec-handlers ee) event)] + [(ee event handler) + ;; Remove specific handler + (let* ([ht (event-emitter-rec-handlers ee)] + [existing (hashtable-ref ht event '())] + [filtered (filter (lambda (pair) (not (eq? (car pair) handler))) + existing)]) + (if (null? filtered) + (hashtable-delete! ht event) + (hashtable-set! ht event filtered)))])) + + (define (off-all ee) + ;; Remove all listeners + (hashtable-clear! (event-emitter-rec-handlers ee))) + + (define (emit ee event . args) + ;; Fire all handlers for event, remove once handlers + (let* ([ht (event-emitter-rec-handlers ee)] + [handlers (hashtable-ref ht event '())] + [remaining '()]) + (for-each + (lambda (pair) + (guard (exn [#t (void)]) ;; don't let one handler crash others + (apply (car pair) args)) + (unless (cdr pair) ;; not a once handler + (set! remaining (cons pair remaining)))) + handlers) + (if (null? remaining) + (hashtable-delete! ht event) + (hashtable-set! ht event (reverse remaining))))) + + (define (listeners ee event) + ;; Return list of handler procedures for event + (map car (hashtable-ref (event-emitter-rec-handlers ee) event '()))) + + (define (listener-count ee event) + (length (hashtable-ref (event-emitter-rec-handlers ee) event '()))) + + (define (event-names ee) + ;; Return list of all event names with handlers + (let-values ([(keys vals) (hashtable-entries (event-emitter-rec-handlers ee))]) + (vector->list keys))) + +) ;; end library new file mode 100644 --- /dev/null +++ b/lib/std/misc/pool.sls @@ -0,0 +1,112 @@ +#!chezscheme +;;; (std misc pool) -- Generic Resource Pool +;;; +;;; Thread-safe resource pool with configurable min/max size, +;;; idle timeout, and health checking. +;;; +;;; Usage: +;;; (import (std misc pool)) +;;; (define db-pool +;;; (make-pool +;;; (lambda () (connect-db)) ;; create +;;; (lambda (conn) (close-db conn)) ;; destroy +;;; max-size: 10)) +;;; +;;; (pool-with-resource db-pool +;;; (lambda (conn) (db-query conn "SELECT 1"))) + +(library (std misc pool) + (export + make-pool + pool? + pool-acquire + pool-release + pool-with-resource + pool-size + pool-available + pool-drain!) + + (import (chezscheme)) + + (define-record-type pool-rec + (fields (immutable create-fn) ;; (lambda () -> resource) + (immutable destroy-fn) ;; (lambda (resource) -> void) + (immutable max-size) + (mutable resources) ;; list of idle resources + (mutable total) ;; total created (idle + in-use) + (immutable mutex) + (immutable cond)) + (protocol (lambda (new) + (lambda (create destroy max-size) + (new create destroy max-size '() 0 (make-mutex) (make-condition)))))) + + (define make-pool + (case-lambda + [(create destroy) (make-pool-rec create destroy 10)] + [(create destroy . opts) + (let ([max (extract-keyword opts 'max-size: 10)]) + (make-pool-rec create destroy max))])) + + (define (pool? x) (pool-rec? x)) + + (define (pool-size p) (pool-rec-total p)) + + (define (pool-available p) + (length (pool-rec-resources p))) + + (define (pool-acquire p) + ;; Get a resource from the pool (may block) + (with-mutex (pool-rec-mutex p) + (cond + ;; Idle resource available + [(pair? (pool-rec-resources p)) + (let ([r (car (pool-rec-resources p))]) + (pool-rec-resources-set! p (cdr (pool-rec-resources p))) + r)] + ;; Room to create new + [(< (pool-rec-total p) (pool-rec-max-size p)) + (pool-rec-total-set! p (+ (pool-rec-total p) 1)) + ((pool-rec-create-fn p))] + ;; Pool full — wait + [else + (let loop () + (condition-wait (pool-rec-cond p) (pool-rec-mutex p)) + (if (pair? (pool-rec-resources p)) + (let ([r (car (pool-rec-resources p))]) + (pool-rec-resources-set! p (cdr (pool-rec-resources p))) + r) + (loop)))]))) + + (define (pool-release p resource) + ;; Return a resource to the pool + (with-mutex (pool-rec-mutex p) + (pool-rec-resources-set! p (cons resource (pool-rec-resources p))) + (condition-signal (pool-rec-cond p)))) + + (define (pool-with-resource p proc) + ;; Acquire, use, release (with unwind protection) + (let ([r (pool-acquire p)]) + (dynamic-wind + (lambda () (void)) + (lambda () (proc r)) + (lambda () (pool-release p r))))) + + (define (pool-drain! p) + ;; Destroy all idle resources + (with-mutex (pool-rec-mutex p) + (for-each (pool-rec-destroy-fn p) (pool-rec-resources p)) + (let ([drained (length (pool-rec-resources p))]) + (pool-rec-total-set! p (- (pool-rec-total p) drained)) + (pool-rec-resources-set! p '())))) + + ;; ========== Helpers ========== + (define (extract-keyword args key default) + (let loop ([args args]) + (cond + [(null? args) default] + [(and (symbol? (car args)) + (string=? (symbol->string (car args)) (symbol->string key))) + (if (pair? (cdr args)) (cadr args) default)] + [else (loop (cdr args))]))) + +) ;; end library new file mode 100644 --- /dev/null +++ b/lib/std/misc/rate-limiter.sls @@ -0,0 +1,100 @@ +#!chezscheme +;;; (std misc rate-limiter) -- Token Bucket Rate Limiter +;;; +;;; Token bucket algorithm for rate limiting API calls and resource access. +;;; +;;; Usage: +;;; (import (std misc rate-limiter)) +;;; (define limiter (make-rate-limiter 10 1.0)) ;; 10 tokens, 1 per second refill +;;; (rate-limiter-acquire! limiter) ;; blocks until token available +;;; (rate-limiter-try-acquire limiter) ;; returns #t/#f without blocking +;;; (with-rate-limit limiter (lambda () (api-call))) + +(library (std misc rate-limiter) + (export + make-rate-limiter + rate-limiter? + rate-limiter-acquire! + rate-limiter-try-acquire + rate-limiter-available + rate-limiter-reset! + with-rate-limit) + + (import (chezscheme)) + + (define-record-type rate-limiter-rec + (fields (immutable capacity) ;; max tokens + (immutable refill-rate) ;; tokens per second + (mutable tokens) ;; current tokens (flonum) + (mutable last-refill) ;; timestamp of last refill + (immutable mutex)) + (protocol (lambda (new) + (lambda (capacity refill-rate) + (new capacity (inexact refill-rate) (inexact capacity) + (current-seconds) (make-mutex)))))) + + (define (make-rate-limiter capacity refill-rate) + (make-rate-limiter-rec capacity refill-rate)) + + (define (rate-limiter? x) (rate-limiter-rec? x)) + + (define (refill! rl) + ;; Add tokens based on elapsed time + (let* ([now (current-seconds)] + [elapsed (- now (rate-limiter-rec-last-refill rl))] + [new-tokens (+ (rate-limiter-rec-tokens rl) + (* elapsed (rate-limiter-rec-refill-rate rl)))] + [capped (min new-tokens (inexact (rate-limiter-rec-capacity rl)))]) + (rate-limiter-rec-tokens-set! rl capped) + (rate-limiter-rec-last-refill-set! rl now))) + + (define (rate-limiter-try-acquire rl) + ;; Try to take a token. Returns #t if successful, #f if no tokens. + (with-mutex (rate-limiter-rec-mutex rl) + (refill! rl) + (if (>= (rate-limiter-rec-tokens rl) 1.0) + (begin + (rate-limiter-rec-tokens-set! rl (- (rate-limiter-rec-tokens rl) 1.0)) + #t) + #f))) + + (define (rate-limiter-acquire! rl) + ;; Block until a token is available + (let loop () + (if (rate-limiter-try-acquire rl) + (void) + (begin + ;; Sleep a bit based on refill rate + (let ([wait (/ 1.0 (rate-limiter-rec-refill-rate rl))]) + (sleep-seconds (min wait 0.1))) + (loop))))) + + (define (rate-limiter-available rl) + ;; Return current available tokens (approximate) + (with-mutex (rate-limiter-rec-mutex rl) + (refill! rl) + (exact (floor (rate-limiter-rec-tokens rl))))) + + (define (rate-limiter-reset! rl) + ;; Reset to full capacity + (with-mutex (rate-limiter-rec-mutex rl) + (rate-limiter-rec-tokens-set! rl (inexact (rate-limiter-rec-capacity rl))) + (rate-limiter-rec-last-refill-set! rl (current-seconds)))) + + (define (with-rate-limit rl thunk) + ;; Acquire a token, then run thunk + (rate-limiter-acquire! rl) + (thunk)) + + ;; ========== Helpers ========== + (define (current-seconds) + (let ([t (current-time)]) + (+ (time-second t) (/ (time-nanosecond t) 1000000000.0)))) + + (define (sleep-seconds secs) + (let* ([whole (exact (floor secs))] + [frac (- secs whole)] + [nanos (exact (round (* frac 1000000000)))]) + (sleep (make-time 'time-duration nanos whole)))) + +) ;; end library new file mode 100644 --- /dev/null +++ b/lib/std/misc/state-machine.sls @@ -0,0 +1,142 @@ +#!chezscheme +;;; (std misc state-machine) -- Finite State Machine +;;; +;;; Declarative FSM with states, transitions, guards, and actions. +;;; +;;; Usage: +;;; (import (std misc state-machine)) +;;; (define traffic-light +;;; (make-state-machine 'red +;;; `((red (timer) green ,void) +;;; (green (timer) yellow ,void) +;;; (yellow (timer) red ,void)))) +;;; +;;; (sm-state traffic-light) ; => red +;;; (sm-send! traffic-light 'timer) ; transitions to green +;;; (sm-state traffic-light) ; => green + +(library (std misc state-machine) + (export + make-state-machine + state-machine? + sm-state + sm-send! + sm-can-send? + sm-transitions + sm-history + sm-on-transition! + sm-reset!) + + (import (chezscheme)) + + ;; Transition: (from-state (event ...) to-state action-or-#f guard-or-#f) + ;; Simplified: (from event to action) + + (define-record-type state-machine-rec + (fields (immutable initial-state) + (immutable transitions) ;; list of (from event to action guard) + (mutable current-state) + (mutable history-log) ;; list of (from event to timestamp) + (mutable on-transition-cb)) ;; callback or #f + (protocol (lambda (new) + (lambda (initial transitions) + (new initial (normalize-transitions transitions) initial '() #f))))) + + (define (normalize-transitions txns) + ;; Accept: (from (event) to action) or (from (event) to action guard) + ;; or simplified: (from event to action) + (map (lambda (t) + (cond + [(= (length t) 4) + ;; (from event to action) + (let ([from (car t)] + [event (cadr t)] + [to (caddr t)] + [action (cadddr t)]) + (list from + (if (list? event) event (list event)) + to action #f))] + [(= (length t) 5) + ;; (from event to action guard) + (let ([from (car t)] + [event (cadr t)] + [to (caddr t)] + [action (cadddr t)] + [guard (car (cddddr t))]) + (list from + (if (list? event) event (list event)) + to action guard))] + [else (error 'make-state-machine "invalid transition" t)])) + txns)) + + (define (make-state-machine initial transitions) + (make-state-machine-rec initial transitions)) + + (define (state-machine? x) (state-machine-rec? x)) + + (define (sm-state sm) (state-machine-rec-current-state sm)) + + (define (sm-send! sm event . args) + ;; Send an event, trigger transition if valid + (let ([current (state-machine-rec-current-state sm)]) + (let loop ([txns (state-machine-rec-transitions sm)]) + (cond + [(null? txns) + (error 'sm-send! "no valid transition" + `(state: ,current event: ,event))] + [(and (eq? (caar txns) current) + (memq event (cadar txns))) + (let* ([txn (car txns)] + [to (caddr txn)] + [action (cadddr txn)] + [guard (car (cddddr txn))]) + ;; Check guard + (if (and guard (not (apply guard current event args))) + (loop (cdr txns)) ;; guard failed, try next + (begin + ;; Execute action + (when action (apply action args)) + ;; Update state + (state-machine-rec-current-state-set! sm to) + ;; Log transition + (state-machine-rec-history-log-set! sm + (cons (list current event to) + (state-machine-rec-history-log sm))) + ;; Callback + (when (state-machine-rec-on-transition-cb sm) + ((state-machine-rec-on-transition-cb sm) current event to)) + to)))] + [else (loop (cdr txns))])))) + + (define (sm-can-send? sm event) + ;; Check if event can trigger a transition from current state + (let ([current (state-machine-rec-current-state sm)]) + (let loop ([txns (state-machine-rec-transitions sm)]) + (cond + [(null? txns) #f] + [(and (eq? (caar txns) current) + (memq event (cadar txns))) + #t] + [else (loop (cdr txns))])))) + + (define (sm-transitions sm) + ;; Return valid transitions from current state + (let ([current (state-machine-rec-current-state sm)]) + (filter (lambda (t) (eq? (car t) current)) + (state-machine-rec-transitions sm)))) + + (define (sm-history sm) + ;; Return transition history (newest first) + (state-machine-rec-history-log sm)) + + (define (sm-on-transition! sm callback) + ;; Set callback: (lambda (from event to) ...) + (state-machine-rec-on-transition-cb-set! sm callback)) + + (define (sm-reset! sm) + ;; Reset to initial state + (state-machine-rec-current-state-set! sm + (state-machine-rec-initial-state sm)) + (state-machine-rec-history-log-set! sm '())) + +) ;; end library new file mode 100644 --- /dev/null +++ b/lib/std/misc/trie.sls @@ -0,0 +1,151 @@ +#!chezscheme +;;; (std misc trie) -- Prefix Tree for Autocomplete +;;; +;;; Trie (prefix tree) data structure for efficient string operations: +;;; prefix search, autocomplete, and membership testing. +;;; +;;; Usage: +;;; (import (std misc trie)) +;;; (define t (make-trie)) +;;; (trie-insert! t "hello") +;;; (trie-insert! t "help") +;;; (trie-insert! t "world") +;;; (trie-search t "hello") ; => #t +;;; (trie-prefix-search t "hel") ; => ("hello" "help") +;;; (trie-autocomplete t "he" 10) ; => ("hello" "help") + +(library (std misc trie) + (export + make-trie + trie? + trie-insert! + trie-search + trie-starts-with? + trie-prefix-search + trie-autocomplete + trie-delete! + trie-size + trie-words + list->trie) + + (import (chezscheme)) + + ;; Each trie node: (children-hashtable . end-of-word?) + (define-record-type trie-node + (fields (immutable children) ;; hashtable: char -> trie-node + (mutable word-end?)) + (protocol (lambda (new) + (lambda () + (new (make-eqv-hashtable) #f))))) + + (define-record-type trie-rec + (fields (immutable root) + (mutable count)) + (protocol (lambda (new) + (lambda () (new (make-trie-node) 0))))) + + (define (make-trie) (make-trie-rec)) + (define (trie? x) (trie-rec? x)) + (define (trie-size t) (trie-rec-count t)) + + ;; ========== Insert ========== + (define (trie-insert! t word) + (let loop ([node (trie-rec-root t)] + [i 0]) + (if (= i (string-length word)) + (unless (trie-node-word-end? node) + (trie-node-word-end?-set! node #t) + (trie-rec-count-set! t (+ (trie-rec-count t) 1))) + (let* ([c (string-ref word i)] + [children (trie-node-children node)] + [child (hashtable-ref children c #f)]) + (if child + (loop child (+ i 1)) + (let ([new-node (make-trie-node)]) + (hashtable-set! children c new-node) + (loop new-node (+ i 1)))))))) + + ;; ========== Search ========== + (define (trie-search t word) + ;; Returns #t if exact word exists + (let ([node (find-node (trie-rec-root t) word 0)]) + (and node (trie-node-word-end? node)))) + + ;; ========== Starts With ========== + (define (trie-starts-with? t prefix) + ;; Returns #t if any word starts with prefix + (and (find-node (trie-rec-root t) prefix 0) #t)) + + ;; ========== Prefix Search ========== + (define (trie-prefix-search t prefix) + ;; Returns all words with given prefix + (let ([node (find-node (trie-rec-root t) prefix 0)]) + (if node + (collect-words node prefix) + '()))) + + ;; ========== Autocomplete ========== + (define (trie-autocomplete t prefix max-results) + ;; Like prefix-search but limited to max-results + (let ([node (find-node (trie-rec-root t) prefix 0)]) + (if node + (collect-words-limited node prefix max-results) + '()))) + + ;; ========== Delete ========== + (define (trie-delete! t word) + (let ([node (find-node (trie-rec-root t) word 0)]) + (when (and node (trie-node-word-end? node)) + (trie-node-word-end?-set! node #f) + (trie-rec-count-set! t (- (trie-rec-count t) 1))))) + + ;; ========== All Words ========== + (define (trie-words t) + (collect-words (trie-rec-root t) "")) + + ;; ========== Conversion ========== + (define (list->trie words) + (let ([t (make-trie)]) + (for-each (lambda (w) (trie-insert! t w)) words) + t)) + + ;; ========== Internal ========== + (define (find-node node word i) + (if (= i (string-length word)) + node + (let ([child (hashtable-ref (trie-node-children node) (string-ref word i) #f)]) + (if child + (find-node child word (+ i 1)) + #f)))) + + (define (collect-words node prefix) + (let ([results '()]) + (when (trie-node-word-end? node) + (set! results (list prefix))) + (let-values ([(keys vals) (hashtable-entries (trie-node-children node))]) + (let loop ([i 0]) + (when (< i (vector-length keys)) + (let ([child-words (collect-words (vector-ref vals i) + (string-append prefix (string (vector-ref keys i))))]) + (set! results (append results child-words))) + (loop (+ i 1))))) + results)) + + (define (collect-words-limited node prefix max) + (let ([results '()] + [count 0]) + (define (collect! node prefix) + (when (< count max) + (when (trie-node-word-end? node) + (set! results (cons prefix results)) + (set! count (+ count 1))) + (let-values ([(keys vals) (hashtable-entries (trie-node-children node))]) + (let loop ([i 0]) + (when (and (< i (vector-length keys)) (< count max)) + (collect! (vector-ref vals i) + (string-append prefix (string (vector-ref keys i)))) + (loop (+ i 1))))))) + (collect! node prefix) + (reverse results))) + +) ;; end library new file mode 100644 --- /dev/null +++ b/tests/test-batch6.ss @@ -0,0 +1,309 @@ +#!chezscheme +;;; Tests for batch 6: event-emitter, trie, rate-limiter, pool, state-machine + +(import (chezscheme) + (std misc event-emitter) + (std misc trie) + (std misc rate-limiter) + (std misc pool) + (std misc state-machine)) + +(define pass-count 0) +(define fail-count 0) + +(define-syntax check + (syntax-rules (=>) + [(_ expr => expected) + (let ([result expr] + [exp expected]) + (if (equal? result exp) + (set! pass-count (+ pass-count 1)) + (begin + (set! fail-count (+ fail-count 1)) + (printf "FAIL: ~s => ~s (expected ~s)~n" 'expr result exp))))])) + +(define-syntax check-true + (syntax-rules () + [(_ expr) + (let ([result expr]) + (if result + (set! pass-count (+ pass-count 1)) + (begin + (set! fail-count (+ fail-count 1)) + (printf "FAIL: ~s => ~s (expected truthy)~n" 'expr result))))])) + +(define-syntax check-false + (syntax-rules () + [(_ expr) + (let ([result expr]) + (if (not result) + (set! pass-count (+ pass-count 1)) + (begin + (set! fail-count (+ fail-count 1)) + (printf "FAIL: ~s => ~s (expected falsy)~n" 'expr result))))])) + +(printf "--- Testing batch 6 modules ---~n") + +;; ========== (std misc event-emitter) ========== +(printf " Event emitter...~n") + +;; Basic on/emit +(let ([ee (make-event-emitter)] + [received '()]) + (check-true (event-emitter? ee)) + (on ee 'data (lambda (x) (set! received (cons x received)))) + (emit ee 'data 42) + (emit ee 'data 99) + (check received => '(99 42))) + +;; Multiple listeners +(let ([ee (make-event-emitter)] + [log '()]) + (on ee 'msg (lambda (x) (set! log (cons (list 'a x) log)))) + (on ee 'msg (lambda (x) (set! log (cons (list 'b x) log)))) + (emit ee 'msg 1) + (check (length log) => 2)) + +;; once — fires only once +(let ([ee (make-event-emitter)] + [count 0]) + (once ee 'init (lambda () (set! count (+ count 1)))) + (emit ee 'init) + (emit ee 'init) + (check count => 1)) + +;; off — remove all listeners +(let ([ee (make-event-emitter)] + [count 0]) + (on ee 'x (lambda () (set! count (+ count 1)))) + (emit ee 'x) + (off ee 'x) + (emit ee 'x) + (check count => 1)) + +;; off-all +(let ([ee (make-event-emitter)]) + (on ee 'a (lambda () (void))) + (on ee 'b (lambda () (void))) + (off-all ee) + (check (length (event-names ee)) => 0)) + +;; listener-count +(let ([ee (make-event-emitter)]) + (on ee 'x (lambda () (void))) + (on ee 'x (lambda () (void))) + (check (listener-count ee 'x) => 2) + (check (listener-count ee 'y) => 0)) + +;; event-names +(let ([ee (make-event-emitter)]) + (on ee 'a (lambda () (void))) + (on ee 'b (lambda () (void))) + (check (length (event-names ee)) => 2)) + +;; Emit with no listeners (no crash) +(let ([ee (make-event-emitter)]) + (emit ee 'nonexistent) + (set! pass-count (+ pass-count 1))) + +;; ========== (std misc trie) ========== +(printf " Trie...~n") + +(let ([t (make-trie)]) + (check-true (trie? t)) + (check (trie-size t) => 0) + + (trie-insert! t "hello") + (trie-insert! t "help") + (trie-insert! t "world") + (trie-insert! t "hero") + (check (trie-size t) => 4) + + ;; Search + (check-true (trie-search t "hello")) + (check-true (trie-search t "world")) + (check-false (trie-search t "hell")) + (check-false (trie-search t "xyz")) + + ;; Starts with + (check-true (trie-starts-with? t "hel")) + (check-true (trie-starts-with? t "wor")) + (check-false (trie-starts-with? t "xyz")) + + ;; Prefix search + (let ([results (trie-prefix-search t "hel")]) + (check-true (member "hello" results)) + (check-true (member "help" results)) + (check-false (member "hero" results))) + + ;; Autocomplete with limit + (let ([results (trie-autocomplete t "he" 2)]) + (check (length results) => 2)) + + ;; Delete + (trie-delete! t "hello") + (check-false (trie-search t "hello")) + (check (trie-size t) => 3) + + ;; All words + (check (length (trie-words t)) => 3)) + +;; Duplicate insert +(let ([t (make-trie)]) + (trie-insert! t "abc") + (trie-insert! t "abc") + (check (trie-size t) => 1)) + +;; list->trie +(let ([t (list->trie '("cat" "car" "card"))]) + (check (trie-size t) => 3) + (check-true (trie-search t "car")) + (check-true (trie-search t "card"))) + +;; ========== (std misc rate-limiter) ========== +(printf " Rate limiter...~n") + +(let ([rl (make-rate-limiter 5 100.0)]) ;; 5 tokens, 100/sec refill + (check-true (rate-limiter? rl)) + + ;; Should have 5 tokens initially + (check (rate-limiter-available rl) => 5) + + ;; Acquire tokens + (check-true (rate-limiter-try-acquire rl)) + (check-true (rate-limiter-try-acquire rl)) + (check-true (rate-limiter-try-acquire rl)) + (check-true (rate-limiter-try-acquire rl)) + (check-true (rate-limiter-try-acquire rl)) + ;; All used up + (check-false (rate-limiter-try-acquire rl)) + + ;; Reset + (rate-limiter-reset! rl) + (check (rate-limiter-available rl) => 5)) + +;; with-rate-limit +(let ([rl (make-rate-limiter 5 100.0)] + [result #f]) + (with-rate-limit rl (lambda () (set! result 42))) + (check result => 42)) + +;; ========== (std misc pool) ========== +(printf " Pool...~n") + +;; Basic pool +(let* ([created 0] + [destroyed 0] + [p (make-pool + (lambda () (set! created (+ created 1)) created) + (lambda (r) (set! destroyed (+ destroyed 1))) + 'max-size: 3)]) + (check-true (pool? p)) + (check (pool-size p) => 0) + + ;; Acquire creates + (let ([r1 (pool-acquire p)]) + (check (pool-size p) => 1) + (check r1 => 1) + + ;; Release returns to pool + (pool-release p r1) + (check (pool-available p) => 1) + + ;; Re-acquire reuses + (let ([r2 (pool-acquire p)]) + (check r2 => 1) ;; same resource + (check created => 1) ;; no new creation + (pool-release p r2))) + + ;; pool-with-resource + (let ([result (pool-with-resource p (lambda (r) (* r 10)))]) + (check result => 10)) + + ;; Drain + (pool-drain! p) + (check (pool-available p) => 0) + (check-true (> destroyed 0))) + +;; ========== (std misc state-machine) ========== +(printf " State machine...~n") + +;; Traffic light +(let ([sm (make-state-machine 'red + `((red (timer) green ,void) + (green (timer) yellow ,void) + (yellow (timer) red ,void)))]) + (check-true (state-machine? sm)) + (check (sm-state sm) => 'red) + + (sm-send! sm 'timer) + (check (sm-state sm) => 'green) + + (sm-send! sm 'timer) + (check (sm-state sm) => 'yellow) + + (sm-send! sm 'timer) + (check (sm-state sm) => 'red) + + ;; History + (check (length (sm-history sm)) => 3) + + ;; can-send? + (check-true (sm-can-send? sm 'timer)) + (check-false (sm-can-send? sm 'unknown)) + + ;; Reset + (sm-reset! sm) + (check (sm-state sm) => 'red) + (check (length (sm-history sm)) => 0)) + +;; State machine with actions +(define *sm-log* '()) +(let ([sm (make-state-machine 'idle + `((idle (start) running + ,(lambda () (set! *sm-log* (cons 'started *sm-log*)))) + (running (stop) idle + ,(lambda () (set! *sm-log* (cons 'stopped *sm-log*)))) + (running (pause) paused + ,(lambda () (set! *sm-log* (cons 'paused *sm-log*)))) + (paused (resume) running + ,(lambda () (set! *sm-log* (cons 'resumed *sm-log*))))))]) + (sm-send! sm 'start) + (check (sm-state sm) => 'running) + (sm-send! sm 'pause) + (check (sm-state sm) => 'paused) + (sm-send! sm 'resume) + (check (sm-state sm) => 'running) + (sm-send! sm 'stop) + (check (sm-state sm) => 'idle) + (check *sm-log* => '(stopped resumed paused started))) + +;; Invalid transition raises error +(let ([sm (make-state-machine 'a + `((a (go) b ,void)))]) + (check-true (guard (exn [#t #t]) + (sm-send! sm 'invalid) + #f))) + +;; on-transition callback +(let ([sm (make-state-machine 'off + `((off (toggle) on ,void) + (on (toggle) off ,void)))] + [transitions '()]) + (sm-on-transition! sm (lambda (from event to) + (set! transitions (cons (list from to) transitions)))) + (sm-send! sm 'toggle) + (sm-send! sm 'toggle) + (check (length transitions) => 2) + (check (car transitions) => '(on off))) + +;; sm-transitions (valid from current state) +(let ([sm (make-state-machine 'a + `((a (x) b ,void) + (a (y) c ,void) + (b (z) a ,void)))]) + (check (length (sm-transitions sm)) => 2)) + +;; ========== Summary ========== +(printf "~n--- Results: ~a passed, ~a failed ---~n" pass-count fail-count) +(when (> fail-count 0) (exit 1))