#!/usr/bin/env jimsh
# Luxferre's Truly Tiny BASIC (Jim Tcl implementation)
# Based upon the original Tiny BASIC Design Notes by Dennis Allison
# Created in 2026 by Luxferre, released into the public domain

set lttb_keywords {EN GO IF IN LE PR RE}
lassign {{} {} {} 0} progmem callstack vars ip
loop i 65 91 {set vars([format {%c} $i]) 0}

# Input line parser (single-pass)
proc lttb_proginput {rawline} {
  set rawline [string trim $rawline]
  if {[string length $rawline] > 0} {
    lassign {0 0} lno i
    set l [string length $rawline]
    loop i $l {
      set c [string index $rawline $i]
      if {[string is space $c] || [string is digit $c]} {
        if {[string is digit $c]} {set lno $($lno * 10 + int($c))}
      } else {break}
    }
    set linebody [string toupper [string range $rawline $i end]]
    # populate program memory or execute directly
    if {$lno > 0} {
      global progmem
      dict set progmem $lno $linebody
    } else {lttb_exec $linebody}
  }
}

# Main line interpreter
proc lttb_exec {pline} {
  global lttb_keywords
  set kw [string range [lttb_stripspace $pline] 0 1]
  if {[string index $kw 1] eq {=}} {
    set kw LE
    set pline [string cat {LE } $pline] 
  }
  set bi [string first { } $pline]
  set body [string trim [string range $pline $bi end]]
  if {$kw in $lttb_keywords} {
    if {$kw eq {GO} && [string index $pline 2] eq {S}} {
      lttb_GOS $body
    } else {lttb_$kw $body}
  }
}

# Integer number normalizer (for TB-valid signed 16-bit range)
proc lttb_norm {num} {
  set num $(int($num))
  if {($num > 32767) || ($num < -32768)} {
    set num $($num % 65536)
    if {$num > 32767} {incr num -65536}    
  }
  return $num
}

# Whitespace remover
proc lttb_stripspace {s} {return [regsub -all -- {\s} $s ""]}

# List pop helper
proc _lpop {list_var} {
  upvar $list_var l
  if {[llength $l] == 0} {return 0}
  set val [lindex $l end]
  set l [lreplace $l end end]
  return $val
}

# Tiny BASIC expression evaluator (two-pass)
proc lttb_eval {lttb_ex} {
  # pre-checks
  set lttb_ex [string trim $lttb_ex]
  if {$lttb_ex eq {}} {return 0}
  if {[string is digit $lttb_ex]} {return [lttb_norm $(int($lttb_ex))]}
  # pass 1: variable and parentheses substitution
  global vars
  lassign {{(((} {}} pre_ex prevc
  foreach c [split $lttb_ex {}] {
    set outc {}
    if {[string is digit $c]} {set outc $c}
    if {[string is upper $c]} {set outc $vars($c)}
    if {$c eq "$"} {set outc [rand 0 10000]}
    if {$c eq "("} {set outc {(((}}
    if {$c eq ")"} {set outc {)))}}
    if {$c eq "*" || $c eq "/"} {set outc [string cat {)} $c {(}]}
    if {$c eq "+" || $c eq "-"} {
      if {$prevc in {{} ( + -}} {
        set outc [string cat 0 $c]
      } else {set outc [string cat {))} $c {((}] }
    }
    append pre_ex $outc
    set prevc $c
  }
  append pre_ex {)))}
  # pass 2: two-stack LTR evaluator
  local proc eval_helper {vsvar osvar} {
    upvar $vsvar valstack
    upvar $osvar opstack
    set res 0
    set op [_lpop opstack]
    set v2 [_lpop valstack]
    set v1 [_lpop valstack]
    switch -exact -- $op {
      "+" { set res $($v1 + $v2) }
      "-" { set res $($v1 - $v2) }
      "*" { set res $($v1 * $v2) }
      "/" { if {$v2 != 0} {set res $(int($v1 / $v2))} }
      default { error "Unknown operator: $op" }
    }
    lappend valstack [lttb_norm $res]
  }
  lassign {{} {} {}} valbuf valstack opstack
  set precmap {+ 1 - 1 * 2 / 2}
  foreach c [split $pre_ex {}] {
    if {[string is space $c]} {continue}
    if {[string is digit $c]} {
      append valbuf $c
    } else {
      if {[string length $valbuf] > 0} {
        lappend valstack $(int($valbuf))
        set valbuf {}
      }
      if {$c eq {(}} {
        lappend opstack $c
      } elseif {$c eq {)}} {
        while {[llength $opstack] > 0 && [lindex $opstack end] ne "("} {
          eval_helper valstack opstack
        }
        if {[lindex $opstack end] eq "("} {_lpop opstack}
      } elseif {$c in {+ - * /}} {
        set prec $precmap($c)
        while {[llength $opstack] > 0} {
          set top_op [lindex $opstack end]
          if {$top_op eq "("} { break }
          if {$precmap($top_op) >= $prec} {
            eval_helper valstack opstack
          } else { break }
        }
        lappend opstack $c
      }
    }
  }
  while {[llength $opstack] > 0} {eval_helper valstack opstack}
  set res [lindex $valstack 0]
  if {$res eq {}} {set res 0}
  return $res
}

# Tiny BASIC routines implementing various commands

proc lttb_LE {stmt} {
  global vars
  lassign [split $stmt =] vname ex
  set vname [string index [string trim $vname] 0]
  set vars($vname) [lttb_eval $ex]
}

proc lttb_IF {stmt} {
  lassign {-1 -1 {} 0} thenpos restpos relop istrue
  regexp -indices -- {[>=<][>=<]*} $stmt rores
  lassign $rores ropos roend
  set relop [string range $stmt $ropos $roend]
  set expr1 [string range $stmt 0 $($ropos-1)]
  set rest [string range $stmt $($roend + 1) end]
  foreach kw {THEN LET {=} RETURN GOSUB INPUT PRINT GOTO END IF} {
    set thenpos [string first $kw $rest]
    if {$thenpos > -1} {
      if {$kw eq {=}} {incr thenpos -1}
      set restpos $thenpos
      if {$kw eq {THEN}} {incr restpos 4}
      break
    }
  }
  set expr2 [string range $rest 0 $($thenpos - 1)]
  set exdif $([lttb_eval $expr1] - [lttb_eval $expr2])
  switch -exact -- $relop {
    {=} {set istrue $($exdif == 0)}
    {><} - {<>} {set istrue $($exdif != 0)}
    {>}  {set istrue $($exdif > 0)}
    {<}  {set istrue $($exdif < 0)}
    {>=} {set istrue $($exdif >= 0)}
    {<=} {set istrue $($exdif <= 0)}
  }
  if {$istrue} {lttb_proginput [string range $rest $restpos end]}
}

proc lttb_GO {stmt} {
  global ip
  set ip $([lttb_eval $stmt] - 1)
}

proc lttb_GOS {stmt} {
  global ip callstack
  lappend callstack $ip
  set ip $([lttb_eval $stmt] - 1)
}

proc lttb_RE {stmt} {
  global ip callstack
  set ip [_lpop callstack]
}

proc lttb_IN {stmt} {
  global vars
  set varlist [split [lttb_stripspace $stmt] ,]
  set vlen [llength $varlist]
  puts -nonewline {? }
  stdout flush
  set inputbuf [string toupper [string trim [stdin gets]]]
  set inputlist [lmap s [split [lttb_stripspace $inputbuf] ,] {
    lttb_eval $s
  }]
  loop i 0 $vlen {
    set vname [string index [lindex $varlist $i] 0]
    set vars($vname) [lindex $inputlist $i]
  }
}

proc lttb_PR {stmt} {
  lassign {0 {} {}} quoting printlist item
  # Build the printlist
  foreach c [split $stmt {}] {
    if {$c eq {"}} {
      set quoting $(1 - $quoting)
      append item $c
    } elseif {$quoting} {
      append item $c
    } elseif {$c in {; ,}} {
      if {[string length $item] > 0} {
        lappend printlist $item
        set item {}
      }
      lappend printlist $c
    } elseif {[string is graph $c]} {
      append item $c
    }
  }
  if {[string length $item] > 0} {lappend printlist $item}
  # Iterate over the printlist
  foreach item $printlist {
    if {[string index $item 0] eq {"}} {
      puts -nonewline [string trim $item {"}]
    } elseif {$item eq {,}} {
      puts -nonewline "\t"
    } elseif {$item ne {;}} {
      puts -nonewline [lttb_eval $item]
    }
  }
  if {$item ni {; ,}} {puts {}}
  stdout flush
}

proc lttb_EN {stmt} {
  global ip callstack
  lassign {-1 {}} ip callstack
}

# Interactive-only routines start here

proc ext_LIST {} {
  global progmem
  loop i 1 32768 {
    if {[dict exists $progmem $i]} {
      puts [format "%d\t%s" $i $progmem($i)]
    }
  }
}

proc ext_RUN {} {
  global progmem ip
  set ip 1
  while {$ip > 0 && $ip < 32768} {
    if {[dict exists $progmem $ip]} {lttb_exec $progmem($ip)}
    incr ip
  }
}

proc ext_CLEAR {} {
  global progmem callstack vars ip
  lassign {{} {} {} 0} progmem callstack vars ip
  loop i 65 91 {set vars([format {%c} $i]) 0}
}

proc ext_LOAD {fname} {
  if {$fname eq {}} {
    puts -nonewline "File name? "
    stdout flush
    stdin gets fname
  }
  if {[file exists $fname]} {
    ext_CLEAR
    set fh [open $fname r]
    while {![eof $fh]} {
      $fh gets progline
      set progline [string trim $progline]
      if {$progline ne {}} {lttb_proginput $progline}
    }
    $fh close
    puts [format {Loaded %s} $fname]
  } else {puts {Given file doesn't exist, skipping!}}
}

proc ext_SAVE {} {
  global progmem
  puts -nonewline "File name? "
  stdout flush
  stdin gets fname
  set fh [open $fname w]
  loop i 1 32768 {
    if {[dict exists $progmem $i]} {
      $fh puts [format {%d %s} $i $progmem($i)]
    }
  }
  $fh flush
  $fh close
  puts [format {Saved %s} $fname]
}

# Interpreter entry point

puts {----------------------------
 Luxferre's Truly Tiny BASIC
      Jim Tcl Edition
       @Copyleft 2026
    All wrongs reserved
----------------------------}

if {$argc > 0} {ext_LOAD [lindex $argv 0]} else {ext_CLEAR}

while {1} {
  puts -nonewline {> }
  stdout flush  
  set cmd [string toupper [string trim [stdin gets]]]
  switch -exact -- $cmd {
    BYE {puts "Bye!"; break}
    RUN {ext_RUN; continue}
    LIST {ext_LIST; continue}
    NEW - CLEAR {ext_CLEAR; continue}
    LOAD {ext_LOAD {}; continue}
    SAVE {ext_SAVE; continue}
    default {lttb_proginput $cmd}
  }
}