Tcl Curses Menu

VI 2004-10-11: This is a menu display using the minimalist curses package. You might have to change the first line to load wherever your shared lib is.
load [file join $::tcl_platform(os) curses[info sharedlibextension]]

# Order is nswe

array set ldc [list nw j ne m se l sw k nswe n we  q nse t nsw u nwe v swe w ns x bullet ~ diamond `]

proc box {row1 col1 row2 col2} {
    global ldc

    curses attr on alt
    curses move $row1 $col1
    curses puts $ldc(se)
    curses move $row2 $col1
    curses puts $ldc(ne)
    for {set i [expr $row1 + 1] } {$i < $row2} {incr i} {
       curses move $i $col1
       curses puts $ldc(ns)
       curses move $i $col2
       curses puts $ldc(ns)
    }
    for {set i [expr $col1 + 1] } {$i < $col2} {incr i} {
       curses move $row1 $i
       curses puts $ldc(we)
       curses move $row2 $i
       curses puts $ldc(we)
    }
    curses move $row1 $col2
    curses puts $ldc(sw)
    curses move $row2 $col2
    curses puts $ldc(nw)
    curses attr off alt
}


proc menu {row col items} {
    set maxlength 0
    foreach item $items {
       if {[string length $item] > $maxlength} {
           set maxlength [string length $item]
       }
    }
    box $row $col [expr $row + [llength $items] + 1] [expr $col + $maxlength + 2]
    set selected 0
    while {1} {
       if {$selected < 0} {
           set selected 0
       } elseif {$selected > [llength $items] - 1} {
           set selected [expr [llength $items] - 1]
       }
       set i 0
       foreach item $items {
           if {$i == $selected} {
               curses attr on reverse
               set prefix ">"
           } else {
               curses attr off reverse
               set prefix " "
           }
           curses move [expr $row + $i + 1] [expr $col + 1]
           curses puts [format "$prefix%-${maxlength}s" $item]
           incr i
       }
       curses refresh
       binary scan [read stdin 1] c k
       switch $k {
           16 {incr selected -1}
           14 {incr selected 1}
           13 - 10 {return $selected}
           default {
               if {$k >= 0x30 && $k < 0x3A} {
                   set selected [expr $k - 0x30]
               }
           }
       }
    }
}

fconfigure stdin -buffering none
menu 10 10 {alpha beta gamma delta epsilon "A really long string"  "some more junk" "..."}
Category Text Screen
Curses