rose-ash/lib/tcl/tests/idioms.sx

; Tcl-on-SX idiom corpus (Phase 6)
; Classic Tcl idioms covering lists, dicts, procs, patterns
(define tcl-idiom-pass 0)
(define tcl-idiom-fail 0)
(define tcl-idiom-failures (list))

(define
  tcl-idiom-assert
  (fn
    (label expected actual)
    (if
      (equal? expected actual)
      (set! tcl-idiom-pass (+ tcl-idiom-pass 1))
      (begin
        (set! tcl-idiom-fail (+ tcl-idiom-fail 1))
        (append!
          tcl-idiom-failures
          (str label ": expected=" (str expected) " got=" (str actual)))))))

(define
  tcl-run-idiom-tests
  (fn
    ()
    (set! tcl-idiom-pass 0)
    (set! tcl-idiom-fail 0)
    (set! tcl-idiom-failures (list))
    (define interp (fn () (make-default-tcl-interp)))
    (define run (fn (src) (tcl-eval-string (interp) src)))
    (define
      ok
      (fn (label actual expected) (tcl-idiom-assert label expected actual)))

    ; 1. lmap idiom: accumulate mapped values with foreach+lappend
    (ok "idiom-lmap"
      (get
        (run "set result {}\nforeach x {1 2 3} { lappend result [expr {$x * $x}] }\nset result")
        :result)
      "1 4 9")

    ; 2. Recursive list flatten
    (ok "idiom-flatten"
      (get
        (run
          "proc flatten {lst} { set out {}\n  foreach item $lst {\n    if {[llength $item] > 1} {\n      foreach sub [flatten $item] { lappend out $sub }\n    } else {\n      lappend out $item\n    }\n  }\n  return $out\n}\nflatten {1 {2 3} {4 {5 6}}}")
        :result)
      "1 2 3 4 5 6")

    ; 3. String builder accumulator
    (ok "idiom-string-builder"
      (get
        (run "set buf \"\"\nforeach w {Hello World Tcl} { append buf $w \" \" }\nstring trimright $buf")
        :result)
      "Hello World Tcl")

    ; 4. Default parameter via info exists
    (ok "idiom-default-param"
      (get
        (run "if {![info exists x]} { set x 42 }\nset x")
        :result)
      "42")

    ; 5. Association list lookup (parallel key/value lists)
    (ok "idiom-alist-lookup"
      (get
        (run
          "set keys {a b c}\nset vals {10 20 30}\nset idx [lsearch $keys b]\nlindex $vals $idx")
        :result)
      "20")

    ; 6. Proc with optional args via args
    (ok "idiom-optional-args"
      (get
        (run
          "proc greet {name args} {\n  set greeting \"Hello\"\n  if {[llength $args] > 0} { set greeting [lindex $args 0] }\n  return \"$greeting $name\"\n}\ngreet World Hi")
        :result)
      "Hi World")

    ; 7. Builder pattern: dict create from args
    (ok "idiom-dict-builder"
      (get
        (run
          "proc build-dict {args} { dict create {*}$args }\ndict get [build-dict name Alice age 30] name")
        :result)
      "Alice")

    ; 8. Loop with index using array
    (ok "idiom-loop-with-index"
      (get
        (run
          "set i 0\nforeach x {a b c} { set arr($i) $x; incr i }\nset arr(1)")
        :result)
      "b")

    ; 9. String reverse via split+lreverse+join
    (ok "idiom-string-reverse"
      (get
        (run
          "set s hello\nset chars [split $s \"\"]\nset rev [lreverse $chars]\njoin $rev \"\"")
        :result)
      "olleh")

    ; 10. Number to padded string
    (ok "idiom-number-format"
      (get (run "format \"%05d\" 42") :result)
      "00042")

    ; 11. Dict comprehension pattern
    (ok "idiom-dict-comprehension"
      (get
        (run
          "set squares {}\nforeach n {1 2 3 4} { dict set squares $n [expr {$n * $n}] }\ndict get $squares 3")
        :result)
      "9")

    ; 12. Stack ADT using list: push/pop
    (ok "idiom-stack"
      (get
        (run
          "proc stack-push {stackvar val} { upvar $stackvar s; lappend s $val }\nproc stack-pop {stackvar} { upvar $stackvar s; set val [lindex $s end]; set s [lrange $s 0 end-1]; return $val }\nset stk {}\nstack-push stk 10\nstack-push stk 20\nstack-push stk 30\nstack-pop stk")
        :result)
      "30")

    ; 13. Queue ADT using list: enqueue/dequeue
    (ok "idiom-queue"
      (get
        (run
          "proc q-enq {qvar val} { upvar $qvar q; lappend q $val }\nproc q-deq {qvar} { upvar $qvar q; set val [lindex $q 0]; set q [lrange $q 1 end]; return $val }\nset q {}\nq-enq q alpha\nq-enq q beta\nq-enq q gamma\nq-deq q")
        :result)
      "alpha")

    ; 14. Pipeline via proc chaining
    (ok "idiom-pipeline"
      (get
        (run
          "proc double {x} { expr {$x * 2} }\nproc add1 {x} { expr {$x + 1} }\nproc pipeline {val procs} { foreach p $procs { set val [$p $val] }; return $val }\npipeline 5 {double add1 double}")
        :result)
      "22")

    ; 15. Memoize pattern using dict (simple cache, not recursive)
    (ok "idiom-memoize"
      (get
        (run
          "set cache {}\nproc cached-square {n} { global cache\n  if {[dict exists $cache $n]} { return [dict get $cache $n] }\n  set r [expr {$n * $n}]\n  dict set cache $n $r\n  return $r\n}\nset a [cached-square 7]\nset b [cached-square 7]\nset c [cached-square 8]\nexpr {$a == $b && $c == 64}")
        :result)
      "1")

    ; 16. Simple expression evaluator in Tcl (recursive descent)
    (ok "idiom-recursive-eval"
      (get
        (run
          "proc calc {expr} { return [::tcl::mathop::+ 0 [expr $expr]] }\nexpr {3 + 4 * 2}")
        :result)
      "11")

    ; 17. Apply proc to each pair in a dict
    (ok "idiom-dict-for"
      (get
        (run
          "set d [dict create a 1 b 2 c 3]\nset total 0\ndict for {k v} $d { incr total $v }\nset total")
        :result)
      "6")

    ; 18. Find max in list
    (ok "idiom-find-max"
      (get
        (run
          "proc list-max {lst} {\n  set m [lindex $lst 0]\n  foreach x $lst { if {$x > $m} { set m $x } }\n  return $m\n}\nlist-max {3 1 4 1 5 9 2 6}")
        :result)
      "9")

    ; 19. Filter list by predicate
    (ok "idiom-filter-list"
      (get
        (run
          "proc list-filter {lst pred} {\n  set out {}\n  foreach x $lst { if {[$pred $x]} { lappend out $x } }\n  return $out\n}\nproc is-even {n} { expr {$n % 2 == 0} }\nlist-filter {1 2 3 4 5 6} is-even")
        :result)
      "2 4 6")

    ; 20. Zip two lists
    (ok "idiom-zip"
      (get
        (run
          "proc zip {a b} {\n  set out {}\n  set n [llength $a]\n  for {set i 0} {$i < $n} {incr i} {\n    lappend out [lindex $a $i]\n    lappend out [lindex $b $i]\n  }\n  return $out\n}\nzip {1 2 3} {a b c}")
        :result)
      "1 a 2 b 3 c")

    (dict
      "passed"
      tcl-idiom-pass
      "failed"
      tcl-idiom-fail
      "failures"
      tcl-idiom-failures)))