; 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)))
    (ok
      "idiom-lmap"
      (get
        (run
          "set result {}\nforeach x {1 2 3} { lappend result [expr {$x * $x}] }\nset result")
        :result)
      "1 4 9")
    (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")
    (ok
      "idiom-string-builder"
      (get
        (run
          "set buf \"\"\nforeach w {Hello World Tcl} { append buf $w \" \" }\nstring trimright $buf")
        :result)
      "Hello World Tcl")
    (ok
      "idiom-default-param"
      (get (run "if {![info exists x]} { set x 42 }\nset x") :result)
      "42")
    (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")
    (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")
    (ok
      "idiom-dict-builder"
      (get
        (run
          "proc build-dict {args} { dict create {*}$args }\ndict get [build-dict name Alice age 30] name")
        :result)
      "Alice")
    (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")
    (ok
      "idiom-string-reverse"
      (get
        (run
          "set s hello\nset chars [split $s \"\"]\nset rev [lreverse $chars]\njoin $rev \"\"")
        :result)
      "olleh")
    (ok "idiom-number-format" (get (run "format \"%05d\" 42") :result) "00042")
    (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")
    (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")
    (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")
    (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")
    (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")
    (ok
      "idiom-recursive-eval"
      (get
        (run
          "proc calc {expr} { return [::tcl::mathop::+ 0 [expr $expr]] }\nexpr {3 + 4 * 2}")
        :result)
      "11")
    (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")
    (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")
    (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")
    (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")
    (ok
      "env-lookup-basic"
      (env-lookup (let ((x 42)) (current-env)) "x")
      42)
    (ok
      "env-lookup-missing"
      (env-lookup (let ((x 42)) (current-env)) "z")
      nil)
    (ok
      "env-extend-lookup"
      (let
        ((e (let ((x 5)) (current-env))))
        (env-lookup (env-extend e "y" 10) "y"))
      10)
    (ok
      "eval-in-env-parent"
      (let
        ((x 5))
        (eval-in-env (env-extend (current-env) "y" 10) (quote (+ x y))))
      15)
    (ok
      "eval-in-env-multi"
      (let
        ((base (current-env)))
        (eval-in-env
          (env-extend (env-extend base "a" 3) "b" 7)
          (quote (* a b))))
      21)

    ; 26-32. Phase 5 channels: write/read/seek/tell/eof/append/non-blocking
    (ok "channel-write-read"
      (get
        (run
          "set f /tmp/tcl-phase5-1.txt\nset c [open $f w]\nputs $c \"line one\"\nputs $c \"line two\"\nclose $c\nset c [open $f r]\nset out [read $c]\nclose $c\nfile delete $f\nreturn $out")
        :result)
      "line one\nline two\n")

    (ok "channel-gets-loop"
      (get
        (run
          "set f /tmp/tcl-phase5-2.txt\nset c [open $f w]\nputs $c apple\nputs $c banana\nputs $c cherry\nclose $c\nset c [open $f r]\nset out {}\nwhile {[gets $c line] >= 0} {lappend out $line}\nclose $c\nfile delete $f\nreturn $out")
        :result)
      "apple banana cherry")

    (ok "channel-seek-tell"
      (get
        (run
          "set f /tmp/tcl-phase5-3.txt\nset c [open $f w]\nputs -nonewline $c \"hello world\"\nclose $c\nset c [open $f r]\nseek $c 6\nset pos [tell $c]\nset rest [read $c]\nclose $c\nfile delete $f\nreturn \"$pos:$rest\"")
        :result)
      "6:world")

    (ok "channel-eof-after-read"
      (get
        (run
          "set f /tmp/tcl-phase5-4.txt\nset c [open $f w]\nputs -nonewline $c hi\nclose $c\nset c [open $f r]\nread $c\nset e [eof $c]\nclose $c\nfile delete $f\nreturn $e")
        :result)
      "1")

    (ok "channel-append-mode"
      (get
        (run
          "set f /tmp/tcl-phase5-5.txt\nset c [open $f w]\nputs -nonewline $c \"first\"\nclose $c\nset c [open $f a]\nputs -nonewline $c \"-second\"\nclose $c\nset c [open $f r]\nset out [read $c]\nclose $c\nfile delete $f\nreturn $out")
        :result)
      "first-second")

    (ok "channel-seek-end"
      (get
        (run
          "set f /tmp/tcl-phase5-6.txt\nset c [open $f w]\nputs -nonewline $c \"abcdefghij\"\nclose $c\nset c [open $f r]\nseek $c 0 end\nset pos [tell $c]\nclose $c\nfile delete $f\nreturn $pos")
        :result)
      "10")

    (ok "channel-fconfigure-blocking"
      (get
        (run
          "set f /tmp/tcl-phase5-7.txt\nset c [open $f w]\nputs -nonewline $c x\nclose $c\nset c [open $f r]\nfconfigure $c -blocking 0\nset b [fconfigure $c -blocking]\nclose $c\nfile delete $f\nreturn $b")
        :result)
      "0")

    ; 33-37. Phase 5b event loop: after / vwait / fileevent / update
    (ok "after-vwait-timer"
      (get
        (run
          "after 30 {set ::done fired}\nvwait ::done\nset ::done")
        :result)
      "fired")

    (ok "after-multiple-timers-update"
      (get
        (run
          "set ::n 0\nafter 0 {incr ::n}\nafter 0 {incr ::n}\nafter 0 {incr ::n}\nupdate\nset ::n")
        :result)
      "3")

    (ok "fileevent-readable-fires"
      (get
        (run
          "set f /tmp/tcl-phase5b-1.txt\nset c [open $f w]\nputs -nonewline $c hi\nclose $c\nset c [open $f r]\nfileevent $c readable {set ::ready 1; fileevent $::ch readable {}}\nset ::ch $c\nvwait ::ready\nclose $c\nfile delete $f\nset ::ready")
        :result)
      "1")

    (ok "fileevent-query-script"
      (get
        (run
          "set f /tmp/tcl-phase5b-2.txt\nset c [open $f w]\nputs -nonewline $c x\nclose $c\nset c [open $f r]\nfileevent $c readable {puts hello}\nset s [fileevent $c readable]\nclose $c\nfile delete $f\nreturn $s")
        :result)
      "puts hello")

    (ok "after-cancel-via-vwait-timing"
      (get
        (run
          "set ::counter 0\nafter 10 {incr ::counter}\nafter 50 {set ::done 1}\nvwait ::done\nset ::counter")
        :result)
      "1")

    ; 38-41. Phase 5c sockets: TCP client + server
    (ok "socket-server-fires-callback"
      (get
        (run
          "proc h {sock host port} { global got; set got hit; close $sock }\nset srv [socket -server h 18901]\nset cli [socket localhost 18901]\nvwait got\nclose $srv\nclose $cli\nset got")
        :result)
      "hit")

    (ok "socket-client-server-roundtrip"
      (get
        (run
          "proc h {sock host port} { global received; gets $sock line; set received $line; close $sock }\nset srv [socket -server h 18902]\nset cli [socket localhost 18902]\nputs $cli ping\nflush $cli\nvwait received\nclose $srv\nclose $cli\nset received")
        :result)
      "ping")

    (ok "socket-server-peer-host"
      (get
        (run
          "proc h {sock host port} { global peer; set peer $host; close $sock }\nset srv [socket -server h 18903]\nset cli [socket 127.0.0.1 18903]\nvwait peer\nclose $srv\nclose $cli\nset peer")
        :result)
      "127.0.0.1")

    (ok "socket-multiple-connections"
      (get
        (run
          "proc h {sock host port} { global count; incr count; close $sock }\nset count 0\nset srv [socket -server h 18904]\nset c1 [socket localhost 18904]\nset c2 [socket localhost 18904]\nset c3 [socket localhost 18904]\nwhile {$count < 3} { update; after 5 }\nclose $srv\nclose $c1\nclose $c2\nclose $c3\nset count")
        :result)
      "3")

    ; 42-49. Phase 5d file metadata + ops
    (ok "file-isfile-true"
      (get
        (run
          "set f /tmp/tcl-phase5d-1.txt\nset c [open $f w]\nputs -nonewline $c x\nclose $c\nset r [file isfile $f]\nfile delete $f\nreturn $r")
        :result)
      "1")

    (ok "file-isfile-false-on-dir"
      (get (run "file isfile /tmp") :result)
      "0")

    (ok "file-isdir-true"
      (get (run "file isdir /tmp") :result)
      "1")

    (ok "file-size"
      (get
        (run
          "set f /tmp/tcl-phase5d-2.txt\nset c [open $f w]\nputs -nonewline $c hello\nclose $c\nset s [file size $f]\nfile delete $f\nreturn $s")
        :result)
      "5")

    (ok "file-readable-true"
      (get (run "file readable /tmp") :result)
      "1")

    (ok "file-readable-missing"
      (get (run "file readable /no/such/path/here") :result)
      "0")

    (ok "file-mkdir-then-isdir"
      (get
        (run
          "set d /tmp/tcl-phase5d-mkdir/sub\nfile mkdir $d\nset r [file isdir $d]\nfile delete $d\nfile delete /tmp/tcl-phase5d-mkdir\nreturn $r")
        :result)
      "1")

    (ok "file-copy-roundtrip"
      (get
        (run
          "set s /tmp/tcl-phase5d-src.txt\nset d /tmp/tcl-phase5d-dst.txt\nset c [open $s w]\nputs -nonewline $c copydata\nclose $c\nfile copy $s $d\nset c [open $d r]\nset out [read $c]\nclose $c\nfile delete $s\nfile delete $d\nreturn $out")
        :result)
      "copydata")

    (ok "file-rename-then-exists"
      (get
        (run
          "set s /tmp/tcl-phase5d-r1.txt\nset d /tmp/tcl-phase5d-r2.txt\nset c [open $s w]\nputs -nonewline $c x\nclose $c\nfile rename $s $d\nset r [list [file exists $s] [file exists $d]]\nfile delete $d\nreturn $r")
        :result)
      "0 1")

    (ok "file-mtime-positive"
      (get
        (run
          "set f /tmp/tcl-phase5d-mt.txt\nset c [open $f w]\nputs -nonewline $c x\nclose $c\nset m [file mtime $f]\nfile delete $f\nexpr {$m > 0}")
        :result)
      "1")

    ; 52-56. Phase 5e clock format options + clock scan
    (ok "clock-format-utc"
      (get
        (run "clock format 0 -format {%Y-%m-%d %H:%M:%S} -gmt 1")
        :result)
      "1970-01-01 00:00:00")

    (ok "clock-format-fmt-default"
      (get
        (run "clock format 1710513000 -format {%Y-%m-%d} -gmt 1")
        :result)
      "2024-03-15")

    (ok "clock-scan-roundtrip"
      (get
        (run "set t [clock scan {2024-06-15 12:00:00} -format {%Y-%m-%d %H:%M:%S} -gmt 1]\nclock format $t -format {%Y-%m-%d %H:%M:%S} -gmt 1")
        :result)
      "2024-06-15 12:00:00")

    (ok "clock-scan-returns-int"
      (get
        (run "expr {[clock scan {1970-01-01 00:00:00} -format {%Y-%m-%d %H:%M:%S} -gmt 1] == 0}")
        :result)
      "1")

    (ok "clock-format-percent-pct"
      (get
        (run "clock format 0 -format {%Y%%%m} -gmt 1")
        :result)
      "1970%01")

    ; 57-59. Phase 5f socket -async (non-blocking connect)
    (ok "socket-async-completes-writable"
      (get
        (run
          "proc h {sock host port} { close $sock }\nset srv [socket -server h 18930]\nset c [socket -async localhost 18930]\nset ready 0\nfileevent $c writable {global ready; set ready 1}\nvwait ready\nclose $c\nclose $srv\nset ready")
        :result)
      "1")

    (ok "socket-async-then-write"
      (get
        (run
          "proc accept {sock host port} { global accepted_sock; set accepted_sock $sock; fileevent $sock readable [list reader $sock] }\nproc reader {sock} { global received; gets $sock line; set received $line; close $sock }\nset srv [socket -server accept 18931]\nset c [socket -async localhost 18931]\nfileevent $c writable {global wready; set wready 1; fileevent $::ch writable {}}\nset ::ch $c\nvwait wready\nputs $c async-data\nflush $c\nvwait received\nclose $c\nclose $srv\nset received")
        :result)
      "async-data")

    (ok "socket-async-no-error"
      (get
        (run
          "proc h {sock host port} { close $sock }\nset srv [socket -server h 18932]\nset c [socket -async localhost 18932]\nset r 0\nfileevent $c writable {global r; set r 1}\nvwait r\nset err [fconfigure $c -error]\nclose $c\nclose $srv\nreturn $err")
        :result)
      "")

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