;; ====================================================================
;; tatara-lisp standard library — pure-Lisp layer.
;;
;; Loaded after install_primitives + install_hof. Everything here is
;; expressible in terms of those Rust primitives. If a name needs the
;; runtime registry, it lives in hof.rs; if it's pure manipulation, it
;; lives here.
;;
;; Conventions:
;; - Names follow Scheme/Clojure tradition where they overlap. New
;; names follow Clojure (juxt, partial, comp, pipe).
;; - Predicates end in `?`, mutating ops end in `!`.
;; - Macros run with full evaluator access at expansion time — every
;; library fn is in scope inside a macro body. Use (gensym "tag")
;; to mint a hygienic unique symbol when introducing new bindings
;; in a macro.
;; ====================================================================
;; ── Identity / const / flip / comp ─────────────────────────────────
(define (identity x) x)
(define (const x) (lambda (&rest _) x))
(define (flip f) (lambda (a b) (f b a)))
;; Binary composition: (comp f g) → x ↦ (f (g x))
(define (comp f g) (lambda (x) (f (g x))))
;; Right-to-left composition over N functions. (compose f g h) x → (f (g (h x))).
;; Implementation: foldr comp identity.
(define (compose &rest fs) (foldr comp identity fs))
;; Left-to-right composition. (pipe f g h) x → (h (g (f x))).
;; Useful when the data-flow reads top-to-bottom in source.
(define (pipe &rest fs) (foldl (flip comp) identity fs))
;; ── Partial application / juxt ─────────────────────────────────────
;; (partial f a b) returns (lambda (&rest c) (apply f a b c)).
;; The pre-bound args go on the LEFT — this is the standard convention.
(define (partial f &rest more) (lambda (&rest later) (apply f (append more later))))
;; (juxt f g h) x → ((f x) (g x) (h x)).
(define (juxt &rest fs) (lambda (&rest args) (map (lambda (f) (apply f args)) fs)))
;; ── Tap / doto-ish ─────────────────────────────────────────────────
;; (tap f x) runs (f x) for its side effect and returns x unchanged.
;; Useful in pipelines for logging / debugging.
(define (tap f x) (f x) x)
;; ── Threading macros (Clojure-style) ───────────────────────────────
;;
;; Macro bodies are regular Lisp programs evaluated at expansion time —
;; full primitive surface available. Recursive `if`/`cond` dispatch on
;; rest-arg shape works directly; no `\`,(if ...)` ceremony required.
;; (-> x) → x
;; (-> x f1 f2 ...) — chain; each step is either a bare unary fn or a
;; call form (f a b), in which case x is spliced into the FIRST arg
;; position: (f x a b).
(defmacro -> (x &rest steps) (if (null? steps) x `(-> (->1 ,x ,(car steps)) ,@(cdr steps))))
(defmacro ->1 (x step) (if (list? step) `(,(car step) ,x ,@(cdr step)) `(,step ,x)))
;; (->> x f1 f2 ...) — same threading but step's arg slot is the LAST
;; position: (f a b x).
(defmacro ->> (x &rest steps) (if (null? steps) x `(->> (->>1 ,x ,(car steps)) ,@(cdr steps))))
(defmacro ->>1 (x step) (if (list? step) `(,(car step) ,@(cdr step) ,x) `(,step ,x)))
;; ── Control-flow macros ────────────────────────────────────────────
;; (when-let (name expr) body...) — bind name to expr; if truthy run body.
;; Like Clojure's when-let.
(defmacro
when-let
(binding &rest body)
`(let ((,(car binding) ,(car (cdr binding)))) (if ,(car binding) (begin ,@body) ())))
;; (if-let (name expr) then else) — same with an else branch.
(defmacro
if-let
(binding then else)
`(let ((,(car binding) ,(car (cdr binding)))) (if ,(car binding) ,then ,else)))
;; (unless-let (name expr) body...) — body runs when expr is FALSY.
(defmacro
unless-let
(binding &rest body)
`(let ((,(car binding) ,(car (cdr binding)))) (if ,(car binding) () (begin ,@body))))
;; ── Loops ──────────────────────────────────────────────────────────
;; (dotimes (i n) body...) — i counts 0 .. n-1.
(defmacro
dotimes
(binding &rest body)
`(for-each (lambda (,(car binding)) ,@body) (range ,(car (cdr binding)))))
;; (dolist (x xs) body...) — iterate xs.
(defmacro
dolist
(binding &rest body)
`(for-each (lambda (,(car binding)) ,@body) ,(car (cdr binding))))
;; ── Composition macros for program flow ────────────────────────────
;; (defflow name f1 f2 f3 ...) — define a unary function that pipes its
;; argument through f1, then f2, then f3, etc. Reads top-to-bottom.
(defmacro defflow (name &rest fs) `(define ,name (pipe ,@fs)))
;; ── Sequence helpers ───────────────────────────────────────────────
(define (first xs) (car xs))
(define (rest xs) (cdr xs))
(define (second xs) (car (cdr xs)))
(define (third xs) (car (cdr (cdr xs))))
(define (fourth xs) (car (cdr (cdr (cdr xs)))))
(define (last xs) (if (null? (cdr xs)) (car xs) (last (cdr xs))))
(define (butlast xs) (if (null? (cdr xs)) () (cons (car xs) (butlast (cdr xs)))))
;; Safe variants — return nil for out-of-bounds instead of erroring.
;; Useful for "optional" positional fields like state-machine row guards.
(define
(safe-nth n xs)
(cond ((null? xs) ()) ((<= n 0) (car xs)) (else (safe-nth (- n 1) (cdr xs)))))
(define (empty? xs) (null? xs))
(define (not-empty? xs) (not (empty? xs)))
;; (range n) → (0 1 ... n-1)
;; (range a b) → (a a+1 ... b-1)
;; (range a b s) → (a a+s ... < b) for positive s; descending for negative.
(define
(range &rest args)
(cond
((= (length args) 1) (range-impl 0 (car args) 1))
((= (length args) 2) (range-impl (car args) (second args) 1))
((= (length args) 3) (range-impl (car args) (second args) (third args)))
(else (error-msg "range: arity 1, 2, or 3"))))
(define
(range-impl start end step)
(cond
((and (> step 0) (>= start end)) ())
((and (< step 0) (<= start end)) ())
(else (cons start (range-impl (+ start step) end step)))))
(define (error-msg msg) (display msg) (newline))
;; (repeat-list x n) → (x x x ...) length n
(define (repeat-list x n) (if (<= n 0) () (cons x (repeat-list x (- n 1)))))
;; (concat &rest lists) — alias for append (already variadic)
(define (concat &rest lists) (apply append lists))
;; (member? x xs) — true iff (equal? x e) for some e in xs.
(define (member? x xs) (any? (lambda (e) (equal? e x)) xs))
;; (position x xs) — first index where (equal? x e) holds, or -1.
(define (position x xs) (find-index (lambda (e) (equal? e x)) xs))
;; (zip xs ys) → ((x0 y0) (x1 y1) ...). Stops at shorter list.
(define (zip xs ys) (map (lambda (a b) (list a b)) xs ys))
;; (interleave xs ys) → (x0 y0 x1 y1 ...). Stops at shorter list.
(define (interleave xs ys) (apply append (zip xs ys)))
;; (intersperse sep xs) — insert sep between each pair of items.
(define
(intersperse sep xs)
(cond
((null? xs) ())
((null? (cdr xs)) (list (car xs)))
(else (cons (car xs) (cons sep (intersperse sep (cdr xs)))))))
;; (flatten xs) — recursively flatten nested lists into one list.
(define
(flatten xs)
(cond
((null? xs) ())
((list? (car xs)) (append (flatten (car xs)) (flatten (cdr xs))))
(else (cons (car xs) (flatten (cdr xs))))))
;; (distinct xs) — preserve first occurrence; drop duplicates by equal?.
(define
(distinct xs)
(foldl (lambda (acc x) (if (member? x acc) acc (append acc (list x)))) (list) xs))
;; (max-by f xs) / (min-by f xs) — find element with max/min (f x).
(define (max-by f xs) (foldl (lambda (best x) (if (> (f x) (f best)) x best)) (car xs) (cdr xs)))
(define (min-by f xs) (foldl (lambda (best x) (if (< (f x) (f best)) x best)) (car xs) (cdr xs)))
;; ── Numeric helpers ────────────────────────────────────────────────
(define (inc x) (+ x 1))
(define (dec x) (- x 1))
(define (zero? x) (= x 0))
(define (positive? x) (> x 0))
(define (negative? x) (< x 0))
(define (even? x) (= 0 (modulo x 2)))
(define (odd? x) (= 1 (modulo x 2)))
;; ── General predicates ─────────────────────────────────────────────
(define (not= a b) (not (equal? a b)))
(define (some? x) (not (null? x)))
;; ====================================================================
;; STATE MACHINES + AUTOMATA
;; --------------------------------------------------------------------
;; Pure-Lisp finite state machine and friends. The runtime model: an FSM
;; is a closure that captures `current` in a lexical cell and dispatches
;; on a message keyword. No Rust types involved — every layer is editable.
;;
;; API surface:
;;
;; (defsm name :initial S :transitions ((S evt T) ...) ...)
;; ↳ (define name (make-sm <spec>))
;;
;; (sm-send sm event &rest args) → next-state
;; (sm-current sm) → current state
;; (sm-reset! sm) → re-initialize
;; (sm-can? sm event) → bool (transition exists from current?)
;; (sm-history sm) → list of states visited (newest-first)
;;
;; Spec keywords:
;; :initial — starting state
;; :transitions — list of (state event next-state) or
;; (state event next-state guard-fn) or
;; (state event next-state guard-fn action-fn)
;; :on-enter — list of (state action-fn) — runs on entering state
;; :on-exit — list of (state action-fn) — runs on leaving state
;; :on-event — list of (event action-fn) — runs on every fire
;; ====================================================================
;; Plist accessor — pull a value out of a (:k1 v1 :k2 v2 ...) list.
;; Returns nil when not found.
(define
(plist-get plist key)
(cond
((null? plist) ())
((null? (cdr plist)) ())
((equal? (car plist) key) (second plist))
(else (plist-get (cdr (cdr plist)) key))))
;; Lookup a (state event next [guard] [action]) row in the transition
;; table. Returns the matching row or nil.
(define
(sm-lookup-row trans state event)
(find (lambda (row) (and (equal? (car row) state) (equal? (second row) event))) trans))
;; Build a state-machine spec from kv pairs. Just a tagged plist.
(define (sm-spec &rest kvs) (cons :sm-spec kvs))
(define (sm-spec? s) (and (pair? s) (equal? (car s) :sm-spec)))
(define (sm-spec-get s key) (plist-get (cdr s) key))
;; Run all matching action-fns from an alist of (state action-fn) pairs.
(define
(sm-fire-state-actions actions state)
(dolist
(entry actions)
(when-let (action-fn (and (equal? (car entry) state) (second entry))) (action-fn state))))
(define
(sm-fire-event-actions actions event payload)
(dolist
(entry actions)
(when-let (action-fn (and (equal? (car entry) event) (second entry))) (action-fn event payload))))
;; Build an FSM closure. Captures `current` and `history` in a closure.
(define
(make-sm spec)
(let
((current (sm-spec-get spec :initial))
(history (list (sm-spec-get spec :initial)))
(trans (or (sm-spec-get spec :transitions) (list)))
(on-enter (or (sm-spec-get spec :on-enter) (list)))
(on-exit (or (sm-spec-get spec :on-exit) (list)))
(on-event (or (sm-spec-get spec :on-event) (list))))
(sm-fire-state-actions on-enter current)
(lambda
(msg &rest args)
(cond
((equal? msg :send)
(let*
((event (car args))
(payload (if (null? (cdr args)) () (second args)))
(row (sm-lookup-row trans current event)))
(cond
((null? row) current)
(else
(let*
((next (safe-nth 2 row))
(guard (safe-nth 3 row))
(action (safe-nth 4 row))
(passes (or (null? guard) (guard current event payload))))
(cond
((not passes) current)
(else
(sm-fire-state-actions on-exit current)
(when (not (null? action)) (action current event payload))
(sm-fire-event-actions on-event event payload)
(set! current next)
(set! history (cons next history))
(sm-fire-state-actions on-enter current)
current)))))))
((equal? msg :current) current)
((equal? msg :history) history)
((equal? msg :reset!)
(let
((init (sm-spec-get spec :initial)))
(set! current init)
(set! history (list init))
(sm-fire-state-actions on-enter init)
init))
((equal? msg :can?)
(let ((event (car args))) (not= () (sm-lookup-row trans current event))))
(else (error-msg "unknown SM message"))))))
;; (defsm name &rest kvs) — define a state-machine binding.
(defmacro defsm (name &rest kvs) `(define ,name (make-sm (sm-spec ,@kvs))))
;; Public driver fns.
(define (sm-send sm event &rest args) (apply sm :send (cons event args)))
(define (sm-current sm) (sm :current))
(define (sm-history sm) (sm :history))
(define (sm-reset! sm) (sm :reset!))
(define (sm-can? sm event) (sm :can? event))
;; ====================================================================
;; ACTOR PATTERN
;; --------------------------------------------------------------------
;; An actor is a closure carrying:
;; - a mailbox (FIFO queue of messages)
;; - a state cell
;; - a behavior fn: (state, msg) -> state
;;
;; Messages enqueue synchronously; a single (actor-step!) dequeues and
;; processes one. (actor-run! actor n) processes up to n messages.
;; (actor-drain! actor) processes until the mailbox is empty.
;;
;; This is a single-threaded actor — no real concurrency, but the model
;; is identical and the API is the same.
;; ====================================================================
(define
(make-actor initial-state behavior)
(let
((state initial-state) (mailbox (list)))
(lambda
(msg &rest args)
(cond
((equal? msg :tell) (set! mailbox (append mailbox (list (car args)))) state)
((equal? msg :step!)
(cond
((null? mailbox) state)
(else
(let
((m (car mailbox)))
(set! mailbox (cdr mailbox))
(set! state (behavior state m))
state))))
((equal? msg :state) state)
((equal? msg :mailbox) mailbox)
((equal? msg :empty?) (null? mailbox))))))
(defmacro
defactor
(name initial-state behavior-fn)
`(define ,name (make-actor ,initial-state ,behavior-fn)))
(define (actor-tell a m) (a :tell m))
(define (actor-step! a) (a :step!))
(define (actor-state a) (a :state))
(define (actor-empty? a) (a :empty?))
(define
(actor-drain! a)
(define (loop) (if (actor-empty? a) (actor-state a) (begin (actor-step! a) (loop))))
(loop))
(define
(actor-run! a n)
(cond
((<= n 0) (actor-state a))
((actor-empty? a) (actor-state a))
(else (actor-step! a) (actor-run! a (- n 1)))))
;; ====================================================================
;; OBSERVER (pub/sub)
;; --------------------------------------------------------------------
;; (make-subject) → a subject that holds a subscriber list.
;; (subject-subscribe! subj fn) → subscription handle (just the fn).
;; (subject-unsubscribe! subj fn).
;; (subject-emit! subj msg) → calls every subscriber with msg.
;; ====================================================================
(define
(make-subject)
(let
((subs (list)))
(lambda
(msg &rest args)
(cond
((equal? msg :subscribe!) (set! subs (cons (car args) subs)) (car args))
((equal? msg :unsubscribe!) (set! subs (filter (lambda (f) (not= f (car args))) subs)) ())
((equal? msg :emit!) (dolist (f subs) (f (car args))) ())
((equal? msg :subs) subs)))))
(define (subject-subscribe! s f) (s :subscribe! f))
(define (subject-unsubscribe! s f) (s :unsubscribe! f))
(define (subject-emit! s m) (s :emit! m))
;; ====================================================================
;; COMMAND / QUERY (CQRS-flavored separation)
;; --------------------------------------------------------------------
;; A Bus dispatches commands and queries via a registry of handlers.
;; - register-command! + dispatch-command — usually returns nothing,
;; may mutate state inside the handler closure.
;; - register-query! + dispatch-query — returns a value.
;;
;; (defcommand BUS NAME (args...) body...) registers the handler.
;; (defquery BUS NAME (args...) body...) registers the query handler.
;; ====================================================================
(define
(make-bus)
(let
((commands (list)) (queries (list)))
(lambda
(msg &rest args)
(cond
((equal? msg :register-command!)
(set! commands (cons (list (car args) (second args)) commands))
(car args))
((equal? msg :register-query!)
(set! queries (cons (list (car args) (second args)) queries))
(car args))
((equal? msg :dispatch-command)
(let
((cmd-name (car args)) (cmd-args (cdr args)))
(let
((entry (find (lambda (kv) (equal? (car kv) cmd-name)) commands)))
(if
(null? entry)
(error-msg (string-append "no command: " (keyword->string cmd-name)))
(apply (second entry) cmd-args)))))
((equal? msg :dispatch-query)
(let
((q-name (car args)) (q-args (cdr args)))
(let
((entry (find (lambda (kv) (equal? (car kv) q-name)) queries)))
(if
(null? entry)
(error-msg (string-append "no query: " (keyword->string q-name)))
(apply (second entry) q-args)))))))))
(define (register-command! bus name fn) (bus :register-command! name fn))
(define (register-query! bus name fn) (bus :register-query! name fn))
(define (dispatch-command bus name &rest args) (apply bus :dispatch-command (cons name args)))
(define (dispatch-query bus name &rest args) (apply bus :dispatch-query (cons name args)))
(defmacro
defcommand
(bus name params &rest body)
`(register-command! ,bus ,name (lambda ,params ,@body)))
(defmacro
defquery
(bus name params &rest body)
`(register-query! ,bus ,name (lambda ,params ,@body)))
;; ====================================================================
;; EVENT SOURCING (lightweight)
;; --------------------------------------------------------------------
;; An event store holds a list of events. A projection is a fold over
;; events into a state. Both are supplied by the user — this layer is
;; just bookkeeping.
;;
;; (make-event-store) → store
;; (event-append! store evt)
;; (event-history store) ; events oldest-first
;; (event-project store fold init) ; runs fold over history
;; ====================================================================
(define
(make-event-store)
(let
((events (list)))
(lambda
(msg &rest args)
(cond
((equal? msg :append!) (set! events (append events (list (car args)))) (car args))
((equal? msg :history) events)
((equal? msg :project) (foldl (car args) (second args) events))))))
(define (event-append! s e) (s :append! e))
(define (event-history s) (s :history))
(define (event-project s fold init) (s :project fold init))
;; ====================================================================
;; STRATEGY / DECORATOR / VISITOR
;; --------------------------------------------------------------------
;; Strategy: a named handler chosen at call time.
;; (defstrategy s :default fn :variant fn ...)
;; (strategy-call s :variant arg1 ...) — picks variant, falls back
;; to :default.
;;
;; Decorator: wrap an existing fn with before/after/around behavior.
;; (decorate f :before pre :after post)
;;
;; Visitor: dispatch on a tag in the value.
;; (defvisitor v (:tagA fn) (:tagB fn) ...)
;; (visit v tagged-value) — looks up the tag (assumed first elem)
;; and calls the matching fn with (rest).
;; ====================================================================
(define
(make-strategy &rest kvs)
(let
((handlers kvs))
(lambda
(variant &rest args)
(let
((fn (or (plist-get handlers variant) (plist-get handlers :default))))
(if (null? fn) (error-msg "no strategy variant matched + no :default") (apply fn args))))))
(defmacro defstrategy (name &rest kvs) `(define ,name (make-strategy ,@kvs)))
(define (strategy-call s variant &rest args) (apply s (cons variant args)))
(define
(decorate f &rest kvs)
(let
((before (plist-get kvs :before))
(after (plist-get kvs :after))
(around (plist-get kvs :around)))
(lambda
(&rest args)
(cond
((some? around) (apply around (cons f args)))
(else
(when (some? before) (apply before args))
(let
((result (apply f args)))
(when (some? after) (apply after (cons result args)))
result))))))
(define
(make-visitor &rest kvs)
(let
((handlers kvs))
(lambda
(tagged-value)
(cond
((null? tagged-value) ())
(else
(let
((tag (car tagged-value)) (rest (cdr tagged-value)))
(let
((fn (or (plist-get handlers tag) (plist-get handlers :default))))
(if (null? fn) (error-msg "no visitor matched tag") (apply fn rest)))))))))
(defmacro defvisitor (name &rest kvs) `(define ,name (make-visitor ,@kvs)))
(define (visit v tagged-value) (v tagged-value))
;; ====================================================================
;; PIPELINE — typed multi-stage with named hooks
;; --------------------------------------------------------------------
;; Pipeline like a defflow but each stage has a name and you can hook
;; before/after each stage.
;;
;; (make-pipeline (list (list :stage1 fn1) (list :stage2 fn2) ...))
;; (pipeline-run! p init)
;; (pipeline-on-stage! p stage hook-fn) — runs (hook stage in out)
;; ====================================================================
(define
(make-pipeline stages)
(let
((hooks (list)))
(lambda
(msg &rest args)
(cond
((equal? msg :run!)
(foldl
(lambda
(acc stage)
(let*
((name (car stage)) (fn (second stage)) (out (fn acc)))
(dolist
(h hooks)
(when
(or (equal? (car h) :any-stage) (equal? (car h) name))
((second h) name acc out)))
out))
(car args)
stages))
((equal? msg :on-stage!) (set! hooks (cons (list (car args) (second args)) hooks)) ())
((equal? msg :stages) stages)))))
(define (pipeline-run! p init) (p :run! init))
(define (pipeline-on-stage! p s f) (p :on-stage! s f))
;; ====================================================================
;; FINITE STATE TRANSDUCER (Mealy / Moore)
;; --------------------------------------------------------------------
;; A transducer maps an input symbol to (next-state, output-symbol).
;; :type :mealy — output depends on (state, input)
;; :type :moore — output depends only on state
;;
;; (make-transducer :initial S :type :mealy :transitions ((S in T out) ...))
;; (transducer-feed! t input) → output (and advances state)
;; (transducer-run! t input-list) → list of outputs
;; ====================================================================
(define
(make-transducer &rest kvs)
(let
((current (plist-get kvs :initial))
(kind (or (plist-get kvs :type) :mealy))
(trans (or (plist-get kvs :transitions) (list))))
(lambda
(msg &rest args)
(cond
((equal? msg :feed!)
(let
((row
(find
(lambda (r) (and (equal? (car r) current) (equal? (second r) (car args))))
trans)))
(cond
((null? row) ())
(else
(let
((next (third row)) (out (if (equal? kind :moore) (fourth row) (fourth row))))
(set! current next)
out)))))
((equal? msg :state) current)))))
(define (transducer-feed! t in) (t :feed! in))
(define (transducer-state t) (t :state))
(define (transducer-run! t inputs) (map (lambda (i) (transducer-feed! t i)) inputs))
;; ====================================================================
;; DEFINE-RECORD — Clojure defrecord-flavor structured data
;; --------------------------------------------------------------------
;; (define-record point (x y))
;;
;; Defines:
;; make-point(x y) → record (a hash-map tagged :tatara-record-type :point)
;; point-x(r) → field accessor
;; point-y(r) → field accessor
;; point?(v) → type predicate
;; point->map(r) → underlying hash-map (identity, but explicit)
;; point-set-x(r v) → new record with x replaced
;; point-set-y(r v) → new record with y replaced
;; ====================================================================
;; Helpers for the macro body.
;; (record-field-accessor record-name field) → symbol like point-x
(define
(record-field-accessor record-name field)
(string->symbol (string-append (symbol->string record-name) "-" (symbol->string field))))
(define
(record-field-setter record-name field)
(string->symbol (string-append (symbol->string record-name) "-set-" (symbol->string field))))
(define (record-keyword field) (string->keyword (symbol->string field)))
;; The macro itself. Uses the full-eval expander to compute names and
;; emit a `(begin ...)` form that defines all the helpers.
(defmacro
define-record
(name fields)
(let*
((type-key (record-keyword name))
(make-sym (string->symbol (string-append "make-" (symbol->string name))))
(pred-sym (string->symbol (string-append (symbol->string name) "?")))
(to-map-sym (string->symbol (string-append (symbol->string name) "->map")))
(ctor-kvs
(apply
append
(cons
(list :tatara-record-type type-key)
(map (lambda (f) (list (record-keyword f) f)) fields))))
(accessor-defs
(map
(lambda
(f)
`(define (,(record-field-accessor name f) r) (hash-map-get r ,(record-keyword f))))
fields))
(setter-defs
(map
(lambda
(f)
`(define (,(record-field-setter name f) r v) (hash-map-set r ,(record-keyword f) v)))
fields)))
`(begin
(define (,make-sym ,@fields) (hash-map ,@ctor-kvs))
(define
(,pred-sym v)
(and (hash-map? v) (equal? (hash-map-get v :tatara-record-type) ,type-key)))
(define (,to-map-sym r) r)
,@accessor-defs
,@setter-defs)))
;; ====================================================================
;; LAZY SEQUENCES — built on (delay) / (force)
;; --------------------------------------------------------------------
;; A lazy seq is one of:
;; nil — empty
;; (head promise-of-rest) — non-empty cell where rest is a
;; Promise of either nil or another
;; such cell.
;;
;; (lazy-cons head tail-expr) — sugar for (list head (delay tail-expr)).
;; (lazy-empty) — (). Lazy-empty? checks for ().
;;
;; Standard ops:
;; (lazy-take n s) — eagerly realize first n.
;; (lazy-drop n s) — drop n, return new lazy seq.
;; (lazy-map f s) — produce a lazy seq applying f.
;; (lazy-filter p s) — produce a lazy seq keeping items.
;; (realize s) — fully realize (warning: infinite seqs hang).
;;
;; Constructors:
;; (iterate-lazy f x) — (x, f(x), f(f(x)), ...)
;; (cycle xs) — (cycle '(1 2 3)) → (1 2 3 1 2 3 ...)
;; (repeat-lazy x) — (x x x ...)
;;
;; This is a pure-Lisp layer; the runtime work is in delay/force.
;; ====================================================================
(defmacro lazy-cons (head tail-expr) `(list ,head (delay ,tail-expr)))
(define (lazy-empty) ())
(define (lazy-empty? s) (null? s))
(define (lazy-head s) (car s))
(define (lazy-rest s) (force (second s)))
(define
(lazy-take n s)
(cond
((<= n 0) ())
((lazy-empty? s) ())
(else (cons (lazy-head s) (lazy-take (- n 1) (lazy-rest s))))))
(define
(lazy-drop n s)
(cond ((<= n 0) s) ((lazy-empty? s) s) (else (lazy-drop (- n 1) (lazy-rest s)))))
(define (realize s) (if (lazy-empty? s) () (cons (lazy-head s) (realize (lazy-rest s)))))
(define
(lazy-map f s)
(if (lazy-empty? s) (lazy-empty) (lazy-cons (f (lazy-head s)) (lazy-map f (lazy-rest s)))))
(define
(lazy-filter p s)
(cond
((lazy-empty? s) (lazy-empty))
((p (lazy-head s)) (lazy-cons (lazy-head s) (lazy-filter p (lazy-rest s))))
(else (lazy-filter p (lazy-rest s)))))
;; (iterate-lazy f x) → (x, f(x), f(f(x)), ...) — infinite.
(define (iterate-lazy f x) (lazy-cons x (iterate-lazy f (f x))))
;; (cycle xs) → (xs xs xs ...) flattened — infinite.
(define (cycle xs) (if (null? xs) () (cycle-impl xs xs)))
(define
(cycle-impl original remaining)
(if
(null? remaining)
(cycle-impl original original)
(lazy-cons (car remaining) (cycle-impl original (cdr remaining)))))
;; (repeat-lazy x) → (x x x ...) — infinite.
(define (repeat-lazy x) (lazy-cons x (repeat-lazy x)))
;; ====================================================================
;; HYGIENIC MACRO HELPERS — with-gensyms
;; --------------------------------------------------------------------
;; CL-style hygiene: bind a list of names to fresh gensyms and run a
;; body that uses them. Cleanest pattern for introducing fresh symbols
;; in macro expansions without name-capture risk.
;;
;; Usage inside a macro body:
;;
;; (defmacro swap! (a b)
;; (with-gensyms (tmp)
;; `(let ((,tmp ,a))
;; (set! ,a ,b)
;; (set! ,b ,tmp))))
;; ====================================================================
(defmacro
with-gensyms
(names &rest body)
`(let (,@(map (lambda (n) (list n `(gensym ,(symbol->string n)))) names)) ,@body))
;; ====================================================================
;; CLOJURE-FLAVOR SEQUENCE / MAP HELPERS
;; --------------------------------------------------------------------
;; Bridges between hash-maps and lists, plus path-based update.
;; ====================================================================
;; (assoc m k v) — alias for hash-map-set; returns m with k→v.
(define (assoc m k v) (hash-map-set m k v))
;; (dissoc m k) — alias for hash-map-remove.
(define (dissoc m k) (hash-map-remove m k))
;; (get m k) — alias for hash-map-get; returns nil if missing.
(define (get m k) (hash-map-get m k))
;; (get-in m path) — walk a chain of nested hash-maps via the path.
;; (get-in {:a {:b {:c 42}}} '(:a :b :c)) → 42.
(define
(get-in m path)
(cond ((null? path) m) ((null? m) ()) (else (get-in (hash-map-get m (car path)) (cdr path)))))
;; (assoc-in m path v) — set a deeply-nested value, building intermediate
;; hash-maps as needed. Returns a new outer map.
(define
(assoc-in m path v)
(cond
((null? path) v)
((null? (cdr path)) (hash-map-set (or m (hash-map)) (car path) v))
(else
(let
((sub (or (hash-map-get m (car path)) (hash-map))))
(hash-map-set (or m (hash-map)) (car path) (assoc-in sub (cdr path) v))))))
;; (update-in m path fn) — apply fn to the value at path; like assoc-in
;; but value computed from current.
(define (update-in m path f) (assoc-in m path (f (get-in m path))))
;; (frequencies xs) → hash-map of value→count. Counts equal? items.
;; Limitation: keys must be hashable (no list/map keys; throws if so).
(define
(frequencies xs)
(foldl
(lambda (acc x) (hash-map-update acc x (lambda (n) (if (null? n) 1 (+ n 1)))))
(hash-map)
xs))
;; (group-by-into-map f xs) → hash-map of key→list, where each item x
;; in xs is grouped by (f x). Preserves first-seen order WITHIN each
;; group (Clojure semantics).
(define
(group-by-into-map f xs)
(foldl
(lambda
(acc x)
(let*
((k (f x)) (current (or (hash-map-get acc k) (list))))
(hash-map-set acc k (append current (list x)))))
(hash-map)
xs))
;; (into-hash-map plist-or-pairs) — convert an alternating-key-value
;; list (or list of (k v) pairs) into a hash-map.
(define
(into-hash-map xs)
(cond
((null? xs) (hash-map))
((and (list? (car xs)) (= (length (car xs)) 2))
(foldl (lambda (acc pair) (hash-map-set acc (car pair) (second pair))) (hash-map) xs))
(else (apply hash-map xs))))
;; (select-keys m keys) → sub-map containing only the requested keys.
(define
(select-keys m keys)
(foldl
(lambda (acc k) (if (hash-map-has? m k) (hash-map-set acc k (hash-map-get m k)) acc))
(hash-map)
keys))
;; (zipmap keys values) → hash-map pairing keys with values.
(define
(zipmap keys vals)
(foldl (lambda (acc pair) (hash-map-set acc (car pair) (second pair))) (hash-map) (zip keys vals)))
;; (count xs) — universal length: handles list, map, string.
(define
(count xs)
(cond
((null? xs) 0)
((list? xs) (length xs))
((hash-map? xs) (hash-map-count xs))
((string? xs) (string-length xs))
(else (error :count "not countable"))))
;; ====================================================================
;; MISC UTILITIES
;; ====================================================================
;; (assert pred? message) — throws if pred? is false.
(defmacro assert (pred message) `(when (not ,pred) (throw (ex-info ,message ()))))
;; (comment ...) — silently elided. Useful for top-level disabled code.
(defmacro comment (&rest _) ())
;; (unwrap-or value default) — return value if non-nil, else default.
(define (unwrap-or v default) (if (null? v) default v))
;; ====================================================================
;; PATTERN MATCHING — (match expr clauses...)
;; --------------------------------------------------------------------
;; Supported pattern shapes:
;;
;; _ wildcard — matches anything, no binding
;; var symbol — matches anything, binds var
;; 42 / "x" / :k / #t literal — matches by equal?
;; (quote sym) exact symbol match
;; (sub-pattern ...) list pattern — matches list of same length;
;; each element matched against sub-pattern
;; (? pred? name) predicate-with-bind: matches if (pred? val)
;; is truthy; binds name to val
;; (? pred?) predicate without bind
;; else final catch-all clause
;;
;; Patterns compile to nested if/let at expansion time — no runtime
;; pattern-matching engine. Each clause's body runs in a scope where
;; the bound names are visible.
;;
;; Examples:
;;
;; (match shape
;; ((quote circle) "round")
;; ((:square side) (string-append "sq " (string side)))
;; ((? number? n) (string-append "num " (string n)))
;; ((head rest-of-list) "two-elem list")
;; (_ "unknown"))
;; ====================================================================
;; Compile a single pattern against a value-symbol. Returns a list:
;; (test-expr binding-list)
;; where test-expr is a Spanned form that evaluates to truthy iff the
;; value matches the pattern, and binding-list is a list of (name expr)
;; forms suitable for splicing into a `let`.
(define
(compile-match-pattern val-sym pattern)
(cond
((equal? pattern (quote _)) (list #t (list)))
((symbol? pattern) (list #t (list (list pattern val-sym))))
((or (number? pattern) (string? pattern) (boolean? pattern))
(list `(equal? ,val-sym ,pattern) (list)))
((keyword? pattern) (list `(equal? ,val-sym ,pattern) (list)))
((and (list? pattern) (= (length pattern) 2) (equal? (car pattern) (quote quote)))
(list `(equal? ,val-sym (quote ,(second pattern))) (list)))
((and (list? pattern) (>= (length pattern) 2) (equal? (car pattern) (quote ?)))
(let
((pred-expr (second pattern)) (bind-name (if (= (length pattern) 3) (third pattern) ())))
(list
(if (null? bind-name) `(,pred-expr ,val-sym) `(,pred-expr ,val-sym))
(if (null? bind-name) (list) (list (list bind-name val-sym))))))
((list? pattern) (compile-list-pattern val-sym pattern))
(else (error :match "unsupported pattern shape"))))
;; List pattern: emit a test that checks list-ness, length, and each
;; element. Bindings concatenate.
(define
(compile-list-pattern val-sym pattern)
(let*
((n (length pattern))
(idx-patterns (zip (range n) pattern))
(sub-results
(map
(lambda
(i+p)
(let ((i (car i+p)) (p (second i+p))) (compile-match-pattern `(nth ,i ,val-sym) p)))
idx-patterns))
(sub-tests (map car sub-results))
(sub-binds (map second sub-results))
(length-test `(and (list? ,val-sym) (= (length ,val-sym) ,n)))
(combined-test `(and ,length-test ,@sub-tests))
(combined-binds (apply append sub-binds)))
(list combined-test combined-binds)))
;; Emit the cond chain for a list of clauses.
(define
(compile-match-clauses val-sym clauses)
(if
(null? clauses)
()
(let*
((clause (car clauses)) (pattern (car clause)) (body (cdr clause)))
(if
(equal? pattern (quote else))
`(begin ,@body)
(let*
((compiled (compile-match-pattern val-sym pattern))
(test (car compiled))
(binds (second compiled)))
`(if ,test (let ,binds ,@body) ,(compile-match-clauses val-sym (cdr clauses))))))))
;; The macro itself.
(defmacro
match
(expr &rest clauses)
(with-gensyms (m-val) `(let ((,m-val ,expr)) ,(compile-match-clauses m-val clauses))))
;; ====================================================================
;; LOOPS — while
;; --------------------------------------------------------------------
;; (while cond body...) — evaluate body while cond is truthy.
;; Returns nil. Tail-call optimized via the recursive impl.
;; ====================================================================
(defmacro
while
(cond &rest body)
(with-gensyms (loop) `(letrec ((,loop (lambda () (if ,cond (begin ,@body (,loop)) ())))) (,loop))))
;; ====================================================================
;; CASE — Scheme-style equality dispatch
;; --------------------------------------------------------------------
;; (case x
;; ((1 2 3) "small")
;; ((10 20 30) "round")
;; ((:a :b :c) "letter")
;; (else "other"))
;;
;; Each clause's first form is a list of literals; the clause matches if
;; x is `equal?` to any of them. Compiles to nested cond.
;; ====================================================================
;; Build one case clause as a runtime list. Avoids nested quasi-quote
;; (which would need the lambda's `lit` binding to reach inside an
;; inner backtick — currently fragile when nested in a closure).
(define
(case-build-clause k-sym clause)
(let
((head (car clause)) (body (cdr clause)))
(cond
((equal? head (quote else)) (cons (quote else) body))
((list? head)
(cons
(cons
(quote or)
(map (lambda (lit) (list (quote equal?) k-sym (list (quote quote) lit))) head))
body))
(else (cons (list (quote equal?) k-sym (list (quote quote) head)) body)))))
(defmacro
case
(key &rest clauses)
(with-gensyms
(k)
`(let ((,k ,key)) ,(cons (quote cond) (map (lambda (c) (case-build-clause k c)) clauses)))))
;; ====================================================================
;; MEMOIZE — wrap a fn in a hash-map cache keyed by its args
;; --------------------------------------------------------------------
;; (memoize f) → cached fn. Cache is per-fn, lives as long as the
;; returned closure. Keys are arg-tuples (built as a hashable pair-key
;; via string-encoding when args have non-hashable shapes).
;;
;; For simplicity, we encode arg lists by stringifying them with pr-str
;; into a single hashable cache key. This handles all Value types
;; including nested lists.
;; ====================================================================
(define
(memoize f)
(let
((cache (hash-map)))
(lambda
(&rest args)
(let
((k (pr-str args)))
(if
(hash-map-has? cache k)
(hash-map-get cache k)
(let ((v (apply f args))) (set! cache (hash-map-set cache k v)) v))))))
;; ====================================================================
;; DOSEQ — Clojure-style multi-binding iteration
;; --------------------------------------------------------------------
;; (doseq (x xs) body...) iterates xs binding x; identical to dolist.
;; Provided as the more familiar Clojure name.
;; ====================================================================
(defmacro doseq (binding &rest body) `(dolist ,binding ,@body))
;; ====================================================================
;; TYPED FUNCTIONS — gradual runtime type assertions
;; --------------------------------------------------------------------
;; (defn-typed name [(arg ty) ...] -> ret-ty body...) → defines `name`
;; as a function that asserts every arg's type on entry and the return
;; type on exit, then runs body. Authoring sugar over (the type expr).
;;
;; Example:
;; (defn-typed greet [(name :string) (count :int)] -> :string
;; (string-append "hi " name))
;;
;; Untyped functions still use plain (define / lambda); typing is
;; opt-in per definition.
;; ====================================================================
;; Helper: `pairs` is a list of (param-symbol type-spec) cells. Builds
;; a list of param symbols and a list of `(the type param)` checks.
(define
(defn-typed-args pairs)
(map (lambda (pair) (car pair)) pairs))
(define
(defn-typed-checks pairs)
(map (lambda (pair) `(the ,(second pair) ,(car pair))) pairs))
;; (defn-typed name [(arg type) ...] -> ret-type body...)
;; The `->` is matched literally. The arg list uses `()` shape
;; ((param type) (param type) ...).
(defmacro
defn-typed
(name params arrow ret-ty &rest body)
(begin
;; Validate that arrow is the literal `->` symbol.
(when (not (equal? arrow (quote ->)))
(throw (ex-info "defn-typed: missing -> before return type" (list))))
(let ((arg-syms (defn-typed-args params)) (checks (defn-typed-checks params)))
`(define
(,name ,@arg-syms)
,@checks
(the ,ret-ty (begin ,@body))))))
;; ====================================================================
;; Clojure-flavored aliases
;;
;; tatara-lisp's primitives use Scheme conventions (`#t`/`#f`,
;; `lambda`, `modulo`, `null?`); these aliases keep Clojure-trained
;; muscle memory working without reaching for Scheme spelling. Aliases
;; are intentionally shallow — each is one definition, no behavior
;; change. If a script wants to be portable across dialects, it can
;; pick either spelling.
;; ====================================================================
;; (fn (args) body) — alias for `lambda`. Macro expansion since
;; `lambda` is a special form, not a function value.
(defmacro fn (args &rest body) `(lambda ,args ,@body))
;; Boolean literals — Clojure / Java / Python users expect bare
;; `true` and `false` symbols. Bound at the value layer to the
;; Scheme primitives.
(define true #t)
(define false #f)
;; Common arithmetic spellings.
(define mod modulo)
(define rem modulo)
;; Predicate aliases.
(define nil? null?)
;; Equality alias — `==` is what Python/Java/Rust users reach for; the
;; primitive is `=`. Keep both bound. (Already-bound `empty?` from
;; the sequence-helpers section is preserved; do NOT redefine here.)
(define == =)
;; `next` — Clojure spelling for "rest of the list", same semantics
;; as `rest` (we don't distinguish empty-rest from nil-rest).
(define next rest)