;; lib/tcl/runtime.sx — Tcl primitives on SX
;;
;; Provides Tcl-idiomatic wrappers over SX built-ins.
;; Primitives used:
;;   make-regexp/regexp-match/regexp-match-all/...    (Phase 19)
;;   make-set/set-add!/set-member?/set-remove!/set->list (Phase 18)
;;   call/cc                                          (core evaluator)
;;   quotient/remainder                               (Phase 15 / builtin)
;;   string->list/list->string/char->integer          (Phase 13)

;; ---------------------------------------------------------------------------
;; 1. String buffer — Tcl append / string accumulation
;; ---------------------------------------------------------------------------

(define
  (tcl-sb-new)
  (let
    ((sb (dict)))
    (dict-set! sb "_tcl_sb" true)
    (dict-set! sb "_buf" "")
    sb))

(define (tcl-sb? v) (and (dict? v) (dict-has? v "_tcl_sb")))

(define
  (tcl-sb-append! sb s)
  (dict-set! sb "_buf" (str (get sb "_buf") s))
  sb)

(define (tcl-sb-value sb) (get sb "_buf"))

(define (tcl-sb-clear! sb) (dict-set! sb "_buf" "") sb)

(define (tcl-sb-length sb) (len (get sb "_buf")))

;; ---------------------------------------------------------------------------
;; 2. String port (channel) — Tcl channel abstraction
;;    Read channel: created from a string, supports gets/read.
;;    Write channel: accumulates puts output, queryable via tcl-chan-string.
;; ---------------------------------------------------------------------------

(define
  (tcl-chan-in-new str)
  (let
    ((c (dict)))
    (dict-set! c "_tcl_chan" true)
    (dict-set! c "_mode" "read")
    (dict-set! c "_chars" (string->list str))
    (dict-set! c "_pos" 0)
    c))

(define
  (tcl-chan-out-new)
  (let
    ((c (dict)))
    (dict-set! c "_tcl_chan" true)
    (dict-set! c "_mode" "write")
    (dict-set! c "_buf" "")
    c))

(define (tcl-chan? v) (and (dict? v) (dict-has? v "_tcl_chan")))

(define
  (tcl-chan-eof? c)
  (and
    (= (get c "_mode") "read")
    (>= (get c "_pos") (len (get c "_chars")))))

(define
  (tcl-chan-read-char c)
  (if
    (tcl-chan-eof? c)
    nil
    (let
      ((ch (nth (get c "_chars") (get c "_pos"))))
      (dict-set! c "_pos" (+ (get c "_pos") 1))
      ch)))

;; gets — read one line (up to newline or EOF), return without trailing newline
(define
  (tcl-chan-gets c)
  (letrec
    ((go (fn (acc) (let ((ch (tcl-chan-read-char c))) (cond ((= ch nil) (list->string (reverse acc))) ((= (char->integer ch) 10) (list->string (reverse acc))) (else (go (cons ch acc))))))))
    (go (list))))

;; read — read all remaining chars
(define
  (tcl-chan-read c)
  (letrec
    ((go (fn (acc) (let ((ch (tcl-chan-read-char c))) (if (= ch nil) (list->string (reverse acc)) (go (cons ch acc)))))))
    (go (list))))

;; puts — write string to write channel (no newline)
(define
  (tcl-chan-puts! c s)
  (when
    (= (get c "_mode") "write")
    (dict-set! c "_buf" (str (get c "_buf") s)))
  c)

;; puts-line — write string + newline (Tcl default puts behaviour)
(define (tcl-chan-puts-line! c s) (tcl-chan-puts! c (str s "\n")))

;; string — get accumulated content of write channel
(define (tcl-chan-string c) (get c "_buf"))

;; tell — current read position
(define (tcl-chan-tell c) (get c "_pos"))

;; ---------------------------------------------------------------------------
;; 3. Regexp — Tcl regexp / regsub wrappers
;; ---------------------------------------------------------------------------

(define (tcl-re-new pattern) (make-regexp pattern ""))

(define (tcl-re-new-flags pattern flags) (make-regexp pattern flags))

(define (tcl-re? v) (regexp? v))

(define (tcl-re-match? rx str) (not (= (regexp-match rx str) nil)))

(define (tcl-re-match rx str) (regexp-match rx str))

(define (tcl-re-match-all rx str) (regexp-match-all rx str))

(define (tcl-re-sub rx str replacement) (regexp-replace rx str replacement))

(define
  (tcl-re-sub-all rx str replacement)
  (regexp-replace-all rx str replacement))

(define (tcl-re-split rx str) (regexp-split rx str))

;; ---------------------------------------------------------------------------
;; 4. Format — Tcl format command (%s %d %f %x %o %%)
;;    tcl-format takes a format string and a list of arguments.
;;    Example: (tcl-format "%s is %d" (list "Alice" 30)) → "Alice is 30"
;; ---------------------------------------------------------------------------

;; Digit characters for base conversion
(define tcl-hex-chars (string->list "0123456789abcdef"))

(define
  (tcl-digits-for-base n base digit-chars)
  (let
    ((abs-n (if (< n 0) (- 0 n) n)))
    (letrec
      ((go (fn (n acc) (if (= n 0) (if (= (len acc) 0) "0" (list->string acc)) (go (quotient n base) (cons (nth digit-chars (remainder n base)) acc))))))
      (let
        ((unsigned (go abs-n (list))))
        (if (< n 0) (str "-" unsigned) unsigned)))))

(define
  (tcl-format-hex n)
  (tcl-digits-for-base (truncate n) 16 tcl-hex-chars))

(define
  (tcl-format-oct n)
  (tcl-digits-for-base (truncate n) 8 (string->list "01234567")))

(define
  (tcl-format fmt args)
  (letrec
    ((chars (string->list fmt))
      (go
        (fn
          (cs arg-list result)
          (if
            (= (len cs) 0)
            result
            (let
              ((c-int (char->integer (first cs))))
              (if
                (= c-int 37)
                (if
                  (= (len (rest cs)) 0)
                  result
                  (let
                    ((spec-int (char->integer (first (rest cs)))))
                    (cond
                      ((= spec-int 37)
                        (go (rest (rest cs)) arg-list (str result "%")))
                      ((= spec-int 115)
                        (go
                          (rest (rest cs))
                          (rest arg-list)
                          (str result (str (first arg-list)))))
                      ((= spec-int 100)
                        (go
                          (rest (rest cs))
                          (rest arg-list)
                          (str result (str (truncate (first arg-list))))))
                      ((= spec-int 102)
                        (go
                          (rest (rest cs))
                          (rest arg-list)
                          (str result (str (+ 0 (first arg-list))))))
                      ((= spec-int 120)
                        (go
                          (rest (rest cs))
                          (rest arg-list)
                          (str result (tcl-format-hex (first arg-list)))))
                      ((= spec-int 111)
                        (go
                          (rest (rest cs))
                          (rest arg-list)
                          (str result (tcl-format-oct (first arg-list)))))
                      (else
                        (go
                          (rest (rest cs))
                          arg-list
                          (str
                            result
                            "%"
                            (list->string (list (first (rest cs))))))))))
                (go
                  (rest cs)
                  arg-list
                  (str result (list->string (list (first cs)))))))))))
    (go chars args "")))

;; ---------------------------------------------------------------------------
;; 5. Coroutine — Tcl-style coroutine using call/cc
;;    tcl-co-yield works reliably when called from top-level fns.
;;    Avoid calling tcl-co-yield from letrec-bound lambdas (JIT limitation).
;; ---------------------------------------------------------------------------

(define tcl-current-co nil)

(define
  (tcl-co-new body)
  (let
    ((co (dict)))
    (dict-set! co "_tcl_co" true)
    (dict-set! co "_state" "new")
    (dict-set! co "_cont" nil)
    (dict-set! co "_resumer" nil)
    (dict-set! co "_parent" nil)
    (dict-set!
      co
      "_body"
      (fn
        ()
        (let
          ((result (body)))
          (dict-set! co "_state" "dead")
          (set! tcl-current-co (get co "_parent"))
          ((get co "_resumer") result))))
    co))

(define (tcl-co? v) (and (dict? v) (dict-has? v "_tcl_co")))

(define (tcl-co-alive? co) (not (= (get co "_state") "dead")))

(define
  (tcl-co-yield val)
  (call/cc
    (fn
      (resume-k)
      (let
        ((cur tcl-current-co))
        (dict-set! cur "_cont" resume-k)
        (dict-set! cur "_state" "suspended")
        (set! tcl-current-co (get cur "_parent"))
        ((get cur "_resumer") val)))))

(define
  (tcl-co-resume co)
  (call/cc
    (fn
      (return-k)
      (dict-set! co "_parent" tcl-current-co)
      (dict-set! co "_resumer" return-k)
      (set! tcl-current-co co)
      (dict-set! co "_state" "running")
      (if
        (= (get co "_cont") nil)
        ((get co "_body"))
        ((get co "_cont") nil)))))