;; lib/scheme/runtime.sx — R7RS-small standard environment.
;;
;; Builds scheme-standard-env from scheme-make-env, populating it with
;; arithmetic, comparison, type predicates, list/pair/vector/string/char
;; primitives, and the higher-order combinators (map/filter/fold).
;;
;; Primitives are bound as SX fns taking a list of evaluated arguments.
;; Combinators that re-enter the evaluator (map, filter, fold, apply,
;; for-each) call `scheme-apply` directly on user-supplied procedures.
;;
;; Public API
;;   (scheme-standard-env)  — fresh env with the full R7RS-base surface
;;
;; Consumes: lib/scheme/eval.sx (scheme-apply, scheme-make-env,
;;           scheme-env-bind!, scheme-string?, scheme-char?,
;;           scheme-vector?, scheme-vector-elements,
;;           scheme-string-value, scheme-char-value,
;;           scheme-string-make, scheme-char-make,
;;           scheme-vector-make).

;; ── Arity / fold helpers ─────────────────────────────────────────

(define
  scm-unary
  (fn
    (name f)
    (fn
      (args)
      (cond
        ((not (= (length args) 1))
          (error (str name ": expects 1 argument")))
        (:else (f (first args)))))))

(define
  scm-binary
  (fn
    (name f)
    (fn
      (args)
      (cond
        ((not (= (length args) 2))
          (error (str name ": expects 2 arguments")))
        (:else (f (first args) (nth args 1)))))))

;; Variadic left-fold helper. zero-id is the identity (`(+)` → 0).
;; one-fn handles single-arg case (`(- x)` negates).
(define
  scm-fold-step
  (fn
    (f acc rest-args)
    (cond
      ((or (nil? rest-args) (= (length rest-args) 0)) acc)
      (:else (scm-fold-step f (f acc (first rest-args)) (rest rest-args))))))

(define
  scm-fold
  (fn
    (name f zero-id one-fn)
    (fn
      (args)
      (cond
        ((= (length args) 0) zero-id)
        ((= (length args) 1) (one-fn (first args)))
        (:else (scm-fold-step f (first args) (rest args)))))))

;; n-ary chained comparison: (< 1 2 3) ≡ (< 1 2) ∧ (< 2 3).
(define
  scm-chain-step
  (fn
    (cmp prev rest-args)
    (cond
      ((or (nil? rest-args) (= (length rest-args) 0)) true)
      (:else
        (let
          ((next (first rest-args)))
          (cond
            ((cmp prev next) (scm-chain-step cmp next (rest rest-args)))
            (:else false)))))))

(define
  scm-chain
  (fn
    (name cmp)
    (fn
      (args)
      (cond
        ((< (length args) 2)
          (error (str name ": expects at least 2 arguments")))
        (:else (scm-chain-step cmp (first args) (rest args)))))))

;; ── List helpers ─────────────────────────────────────────────────

(define
  scm-list-append
  (fn
    (xs ys)
    (cond
      ((or (nil? xs) (= (length xs) 0)) ys)
      (:else (cons (first xs) (scm-list-append (rest xs) ys))))))

(define
  scm-list-reverse-step
  (fn
    (xs acc)
    (cond
      ((or (nil? xs) (= (length xs) 0)) acc)
      (:else (scm-list-reverse-step (rest xs) (cons (first xs) acc))))))

(define
  scm-all-lists?
  (fn
    (xs)
    (cond
      ((or (nil? xs) (= (length xs) 0)) true)
      ((list? (first xs)) (scm-all-lists? (rest xs)))
      (:else false))))

(define
  scm-append-all
  (fn
    (lists)
    (cond
      ((or (nil? lists) (= (length lists) 0)) (list))
      ((= (length lists) 1) (first lists))
      (:else (scm-list-append (first lists) (scm-append-all (rest lists)))))))

;; ── Map / Filter / Fold ──────────────────────────────────────────
;; These call scheme-apply directly so closures and primitives both work.

(define
  scm-map-step
  (fn
    (proc xs)
    (cond
      ((or (nil? xs) (= (length xs) 0)) (list))
      (:else
        (cons
          (scheme-apply proc (list (first xs)))
          (scm-map-step proc (rest xs)))))))

(define
  scm-filter-step
  (fn
    (pred xs)
    (cond
      ((or (nil? xs) (= (length xs) 0)) (list))
      (:else
        (let
          ((keep? (scheme-apply pred (list (first xs)))))
          (cond
            ((not (= keep? false))
              (cons (first xs) (scm-filter-step pred (rest xs))))
            (:else (scm-filter-step pred (rest xs)))))))))

(define
  scm-fold-left-step
  (fn
    (proc acc xs)
    (cond
      ((or (nil? xs) (= (length xs) 0)) acc)
      (:else
        (scm-fold-left-step
          proc
          (scheme-apply proc (list acc (first xs)))
          (rest xs))))))

(define
  scm-fold-right-step
  (fn
    (proc init xs)
    (cond
      ((or (nil? xs) (= (length xs) 0)) init)
      (:else
        (scheme-apply
          proc
          (list (first xs) (scm-fold-right-step proc init (rest xs))))))))

(define
  scm-for-each-step
  (fn
    (proc xs)
    (cond
      ((or (nil? xs) (= (length xs) 0)) nil)
      (:else
        (begin
          (scheme-apply proc (list (first xs)))
          (scm-for-each-step proc (rest xs)))))))

;; ── Vector helpers ──────────────────────────────────────────────

(define
  scm-make-vector-step
  (fn
    (n fill acc)
    (cond
      ((<= n 0) acc)
      (:else (scm-make-vector-step (- n 1) fill (cons fill acc))))))

;; ── Standard env ─────────────────────────────────────────────────

(define
  scheme-standard-env
  (fn
    ()
    (let
      ((env (scheme-make-env)))
      (scheme-env-bind!
        env
        "+"
        (scm-fold "+" (fn (a b) (+ a b)) 0 (fn (x) x)))
      (scheme-env-bind!
        env
        "-"
        (scm-fold
          "-"
          (fn (a b) (- a b))
          0
          (fn (x) (- 0 x))))
      (scheme-env-bind!
        env
        "*"
        (scm-fold "*" (fn (a b) (* a b)) 1 (fn (x) x)))
      (scheme-env-bind!
        env
        "/"
        (scm-fold
          "/"
          (fn (a b) (/ a b))
          1
          (fn (x) (/ 1 x))))
      (scheme-env-bind!
        env
        "abs"
        (scm-unary
          "abs"
          (fn (n) (if (< n 0) (- 0 n) n))))
      (scheme-env-bind!
        env
        "min"
        (scm-fold "min" (fn (a b) (if (< a b) a b)) nil (fn (x) x)))
      (scheme-env-bind!
        env
        "max"
        (scm-fold "max" (fn (a b) (if (< a b) b a)) nil (fn (x) x)))
      (scheme-env-bind!
        env
        "modulo"
        (scm-binary "modulo" (fn (a b) (- a (* b (floor (/ a b)))))))
      (scheme-env-bind!
        env
        "quotient"
        (scm-binary "quotient" (fn (a b) (floor (/ a b)))))
      (scheme-env-bind!
        env
        "remainder"
        (scm-binary "remainder" (fn (a b) (- a (* b (floor (/ a b)))))))
      (scheme-env-bind!
        env
        "zero?"
        (scm-unary "zero?" (fn (n) (= n 0))))
      (scheme-env-bind!
        env
        "positive?"
        (scm-unary "positive?" (fn (n) (> n 0))))
      (scheme-env-bind!
        env
        "negative?"
        (scm-unary "negative?" (fn (n) (< n 0))))
      (scheme-env-bind! env "=" (scm-chain "=" (fn (a b) (= a b))))
      (scheme-env-bind! env "<" (scm-chain "<" (fn (a b) (< a b))))
      (scheme-env-bind! env ">" (scm-chain ">" (fn (a b) (> a b))))
      (scheme-env-bind! env "<=" (scm-chain "<=" (fn (a b) (<= a b))))
      (scheme-env-bind! env ">=" (scm-chain ">=" (fn (a b) (>= a b))))
      (scheme-env-bind!
        env
        "number?"
        (scm-unary "number?" (fn (v) (number? v))))
      (scheme-env-bind!
        env
        "boolean?"
        (scm-unary "boolean?" (fn (v) (boolean? v))))
      (scheme-env-bind!
        env
        "symbol?"
        (scm-unary "symbol?" (fn (v) (string? v))))
      (scheme-env-bind!
        env
        "string?"
        (scm-unary "string?" (fn (v) (scheme-string? v))))
      (scheme-env-bind!
        env
        "char?"
        (scm-unary "char?" (fn (v) (scheme-char? v))))
      (scheme-env-bind!
        env
        "vector?"
        (scm-unary "vector?" (fn (v) (scheme-vector? v))))
      (scheme-env-bind!
        env
        "null?"
        (scm-unary
          "null?"
          (fn
            (v)
            (or (nil? v) (and (list? v) (= (length v) 0))))))
      (scheme-env-bind!
        env
        "pair?"
        (scm-unary
          "pair?"
          (fn (v) (and (list? v) (> (length v) 0)))))
      (scheme-env-bind!
        env
        "procedure?"
        (scm-unary
          "procedure?"
          (fn
            (v)
            (or
              (callable? v)
              (and (dict? v) (= (get v :scm-tag) :closure))))))
      (scheme-env-bind! env "not" (scm-unary "not" (fn (v) (= v false))))
      (scheme-env-bind!
        env
        "cons"
        (scm-binary "cons" (fn (a b) (cons a b))))
      (scheme-env-bind!
        env
        "car"
        (scm-unary
          "car"
          (fn
            (xs)
            (cond
              ((or (nil? xs) (and (list? xs) (= (length xs) 0)))
                (error "car: empty list"))
              (:else (first xs))))))
      (scheme-env-bind!
        env
        "cdr"
        (scm-unary
          "cdr"
          (fn
            (xs)
            (cond
              ((or (nil? xs) (and (list? xs) (= (length xs) 0)))
                (error "cdr: empty list"))
              (:else (rest xs))))))
      (scheme-env-bind! env "list" (fn (args) args))
      (scheme-env-bind!
        env
        "length"
        (scm-unary "length" (fn (xs) (length xs))))
      (scheme-env-bind!
        env
        "reverse"
        (scm-unary "reverse" (fn (xs) (scm-list-reverse-step xs (list)))))
      (scheme-env-bind!
        env
        "append"
        (fn
          (args)
          (cond
            ((scm-all-lists? args) (scm-append-all args))
            (:else (error "append: all arguments must be lists")))))
      (scheme-env-bind!
        env
        "map"
        (fn
          (args)
          (cond
            ((not (= (length args) 2))
              (error "map: expects (proc list)"))
            (:else (scm-map-step (first args) (nth args 1))))))
      (scheme-env-bind!
        env
        "filter"
        (fn
          (args)
          (cond
            ((not (= (length args) 2))
              (error "filter: expects (pred list)"))
            (:else (scm-filter-step (first args) (nth args 1))))))
      (scheme-env-bind!
        env
        "fold-left"
        (fn
          (args)
          (cond
            ((not (= (length args) 3))
              (error "fold-left: expects (proc init list)"))
            (:else
              (scm-fold-left-step
                (first args)
                (nth args 1)
                (nth args 2))))))
      (scheme-env-bind!
        env
        "fold-right"
        (fn
          (args)
          (cond
            ((not (= (length args) 3))
              (error "fold-right: expects (proc init list)"))
            (:else
              (scm-fold-right-step
                (first args)
                (nth args 1)
                (nth args 2))))))
      (scheme-env-bind!
        env
        "for-each"
        (fn
          (args)
          (cond
            ((not (= (length args) 2))
              (error "for-each: expects (proc list)"))
            (:else (scm-for-each-step (first args) (nth args 1))))))
      (scheme-env-bind!
        env
        "apply"
        (fn
          (args)
          (cond
            ((not (= (length args) 2))
              (error "apply: expects (proc args-list)"))
            (:else (scheme-apply (first args) (nth args 1))))))
      (scheme-env-bind!
        env
        "string-length"
        (scm-unary
          "string-length"
          (fn (s) (string-length (scheme-string-value s)))))
      (scheme-env-bind!
        env
        "string=?"
        (scm-binary
          "string=?"
          (fn (a b) (= (scheme-string-value a) (scheme-string-value b)))))
      (scheme-env-bind!
        env
        "string-append"
        (fn
          (args)
          (scheme-string-make
            (scm-fold-step
              (fn (acc s) (str acc (scheme-string-value s)))
              ""
              args))))
      (scheme-env-bind!
        env
        "substring"
        (fn
          (args)
          (cond
            ((not (= (length args) 3))
              (error "substring: expects (str start end)"))
            (:else
              (scheme-string-make
                (substring
                  (scheme-string-value (first args))
                  (nth args 1)
                  (nth args 2)))))))
      (scheme-env-bind!
        env
        "char=?"
        (scm-binary
          "char=?"
          (fn (a b) (= (scheme-char-value a) (scheme-char-value b)))))
      (scheme-env-bind! env "vector" (fn (args) (scheme-vector-make args)))
      (scheme-env-bind!
        env
        "vector-length"
        (scm-unary
          "vector-length"
          (fn (v) (length (scheme-vector-elements v)))))
      (scheme-env-bind!
        env
        "vector-ref"
        (scm-binary
          "vector-ref"
          (fn (v i) (nth (scheme-vector-elements v) i))))
      (scheme-env-bind!
        env
        "vector->list"
        (scm-unary "vector->list" (fn (v) (scheme-vector-elements v))))
      (scheme-env-bind!
        env
        "list->vector"
        (scm-unary "list->vector" (fn (xs) (scheme-vector-make xs))))
      (scheme-env-bind!
        env
        "make-vector"
        (fn
          (args)
          (cond
            ((= (length args) 1)
              (scheme-vector-make
                (scm-make-vector-step (first args) nil (list))))
            ((= (length args) 2)
              (scheme-vector-make
                (scm-make-vector-step
                  (first args)
                  (nth args 1)
                  (list))))
            (:else (error "make-vector: expects (n [fill])")))))
      (scheme-env-bind! env "eqv?" (scm-binary "eqv?" (fn (a b) (= a b))))
      (scheme-env-bind!
        env
        "equal?"
        (scm-binary "equal?" (fn (a b) (= a b))))
      (scheme-env-bind! env "eq?" (scm-binary "eq?" (fn (a b) (= a b))))
      ;; ── call/cc (R7RS first-class continuations) ────────────
      ;; Captures the host SX continuation, wraps it as a Scheme
      ;; procedure (fn (vargs) ...) and passes it to the user proc.
      ;; Calling the captured k with one value re-enters the
      ;; continuation; with multiple values, passes them as a list.
      (scheme-env-bind! env "call/cc"
        (fn (args)
          (cond
            ((not (= (length args) 1))
              (error "call/cc: expects 1 argument"))
            (:else
              (call/cc
                (fn (k)
                  (let ((scheme-k
                          (fn (vargs)
                            (cond
                              ((= (length vargs) 1) (k (first vargs)))
                              (:else (k vargs))))))
                    (scheme-apply (first args) (list scheme-k)))))))))
      (scheme-env-bind! env "call-with-current-continuation"
        (refl-env-lookup env "call/cc"))
      ;; ── R7RS exception primitives ──────────────────────────
      ;; raise V — raises V as exception (host SX raise).
      (scheme-env-bind! env "raise"
        (fn (args)
          (cond
            ((not (= (length args) 1))
              (error "raise: expects 1 argument"))
            (:else (raise (first args))))))
      ;; error MSG IRRITANTS... — convention: raise an error-object
      ;; that's a dict {:scm-error MSG :irritants LIST}. The print
      ;; surface (error-object-message / error-object-irritants)
      ;; can pull these apart.
      (scheme-env-bind! env "error"
        (fn (args)
          (cond
            ((= (length args) 0) (error "error: expects (message [irritant...])"))
            (:else
              (raise {:scm-error (cond
                                   ((scheme-string? (first args))
                                     (scheme-string-value (first args)))
                                   (:else (first args)))
                      :irritants (rest args)})))))
      (scheme-env-bind! env "error-object?"
        (scm-unary "error-object?"
          (fn (v) (and (dict? v) (string? (get v :scm-error))))))
      (scheme-env-bind! env "error-object-message"
        (scm-unary "error-object-message"
          (fn (v) (scheme-string-make (get v :scm-error)))))
      (scheme-env-bind! env "error-object-irritants"
        (scm-unary "error-object-irritants"
          (fn (v) (get v :irritants))))
      ;; with-exception-handler HANDLER THUNK — runs THUNK; if it
      ;; raises, calls HANDLER with the raised value (handler can
      ;; itself raise or return a value). Implemented via host guard.
      ;; with-exception-handler — catch THUNK's raise; if caught,
      ;; call HANDLER. If HANDLER itself raises, propagate that to
      ;; the outer scope (don't re-catch in this same guard, which
      ;; would loop). The two-step outcome-sentinel pattern mirrors
      ;; the `guard` special form's escape.
      (scheme-env-bind! env "with-exception-handler"
        (fn (args)
          (cond
            ((not (= (length args) 2))
              (error "with-exception-handler: expects 2 arguments"))
            (:else
              (let ((handler (first args))
                    (thunk (nth args 1)))
                (let ((outcome
                        (guard
                          (e (true {:scm-weh-raised true :value e}))
                          (scheme-apply thunk (list)))))
                  (cond
                    ((and (dict? outcome) (get outcome :scm-weh-raised))
                      (scheme-apply handler (list (get outcome :value))))
                    (:else outcome))))))))
      ;; ── R7RS reflection: eval / environment accessors ───────
      ;; eval EXPR ENV — apply the evaluator to a user-supplied AST.
      (scheme-env-bind! env "eval"
        (fn (args)
          (cond
            ((not (= (length args) 2))
              (error "eval: expects (eval expr env)"))
            (:else (scheme-eval (first args) (nth args 1))))))
      ;; interaction-environment — the env we're currently building.
      ;; The closure captures `env`, so each invocation of
      ;; scheme-standard-env produces a distinct interaction env
      ;; whose interaction-environment fn returns itself.
      (scheme-env-bind! env "interaction-environment"
        (fn (args)
          (cond
            ((not (= (length args) 0))
              (error "interaction-environment: expects 0 args"))
            (:else env))))
      ;; null-environment — fresh empty env. R7RS ignores version arg.
      (scheme-env-bind! env "null-environment"
        (fn (args)
          (cond
            ((not (= (length args) 1))
              (error "null-environment: expects (version)"))
            (:else (scheme-make-env)))))
      ;; scheme-report-environment — fresh full standard env.
      (scheme-env-bind! env "scheme-report-environment"
        (fn (args)
          (cond
            ((not (= (length args) 1))
              (error "scheme-report-environment: expects (version)"))
            (:else (scheme-standard-env)))))
      (scheme-env-bind! env "environment?"
        (scm-unary "environment?" (fn (v) (scheme-env? v))))
      ;; dynamic-wind BEFORE THUNK AFTER — runs BEFORE, then THUNK,
      ;; then AFTER. If THUNK raises, AFTER still runs before the
      ;; raise propagates. This is the basic-correctness version;
      ;; proper call/cc-escape interaction would need dynamic-extent
      ;; tracking, deferred until needed.
      (scheme-env-bind! env "dynamic-wind"
        (fn (args)
          (cond
            ((not (= (length args) 3))
              (error "dynamic-wind: expects (before thunk after)"))
            (:else
              (let ((before-thunk (first args))
                    (mid-thunk (nth args 1))
                    (after-thunk (nth args 2)))
                (begin
                  (scheme-apply before-thunk (list))
                  (let ((outcome
                          (guard
                            (e (true {:scm-dw-raised true :value e}))
                            (scheme-apply mid-thunk (list)))))
                    (begin
                      (scheme-apply after-thunk (list))
                      (cond
                        ((and (dict? outcome) (get outcome :scm-dw-raised))
                          (raise (get outcome :value)))
                        (:else outcome))))))))))
      env)))