[http://mini.net/files/aplkbd.gif]

[Richard Suchenwirth] - For all friends of ''A Programming Language'' (APL), here is a little Tk app
with (from bottom up)
   * a [keyboard widget] with APL specials, as well as ASCII characters
   * an entry widget where APL input goes
   * a text widget that logs input (blue), output (black) and errors (red)
In addition to the code below, the subset of APL operators from [Playing APL]
is also required. Paste it in, source it as separate file, as you like.
You'll also need a Unicoded APL font (e.g. SImPL.ttf, which can be downloaded from http://www.vector.org.uk/resource/simp2.htm ).

This is a fun project with no warranties, but I hope you enjoy it... To
start the thing, just call ''APL::aps''.
}
 source apl_ops.tcl ;# or however you want it inserted
 namespace eval APL {
    namespace export apl apl2t aps +/ indx mul/ + - | / = ~ , ?
    variable aplascii_ucs {
	    /=      0x2260
	    and     0x2227
	    circle  0x25CB
	    div     0x00F7
	    epsilon 0x220a
	    iota    0x2373
	    @       0x235D
	    log     0x235f
	    max     0x2308
	    min     0x230A
	    mul     0x00D7
	    nand    0x2372
	    neg     0x00AF
	    nor     0x2371
	    or      0x2228
	    rho     0x2374
        set     0x2190
    }
    variable not_yet_implemented {
	    ->      0x2192
	    <=      0x2264
	    >=      0x2265
	    delta   0x2206
	    drop    0x2193
	    rotate  0x233d
	    take    0x2191
	    transpose 0x2349
    }
    foreach {a u} $aplascii_ucs {
        namespace export $a
        interp alias {} [subst \\u[string range $u 2 end]] {} $a
    }
    proc aps {} {
        catch {destroy .aps}
        namespace eval :: {namespace import -force APL::*}
        playstation .aps
    }
    proc apl s {uplevel subst [list [apl2t $s]]}
    
#--------------------- partial parser, turns infix APL to prefix Tcl
    proc apl2t list {
	set res ""
    regsub {[\u235D@].*} $list "" list  ;# strip comment
	regsub -all {[{}]} $list " " list   ;# ignore braces for now
	regsub -all \u2190 $list "set" list ;# {<-}
	#---------- insert potential blanks everywhere, then reduce
	set list [join [split $list ""] \x81]
	foreach i {1 2} {
	    regsub -all "(\[_A-Z0-9\])\x81(\[_A-Z0-9\])" $list {\1\2} list
	    regsub -all "(\[a-z\])\x81(\[a-z\])" $list {\1\2} list
	} ;# ... two times each to cover neighboring instances
	regsub -all "(\[.\])\x81(\[0-9\])" $list {\1\2} list
	regsub -all "(\[0-9\])\x81(\[.\])" $list {\1\2} list
	regsub -all "(\uAF)\x81(\[0-9\])" $list {-\2} list
	regsub -all "(\[+*\u2308\u230a\u00d7])\x81(/)" $list {\1\2} list
	regsub -all \x81 $list " " list
	set op ""
	set last ""
	#---------- walk the list from back
	for {set n [llength $list]} {$n>0} {incr n -1} {
	    set it [lindex $list [expr $n-1]]
	    if [regexp {^[A-Z_]} $it] {
		  if {$last!="val"} {set it $it\"}
		  if {$op!="set"} {set it "\$$it"}
		  set res "$it $res"
		  set last val
	      } elseif {[regexp {^-?[0-9]} $it]} {
		    if {$last!="val"} {set it $it\"}
		    set res "$it $res"
		    set last val
	      } elseif {$it==")"} {
		    if {$last=="val"} {set res \"$res}
		    set last embed
		    set open [matchParen $list [expr $n-1] ( )]
		    set embed [lrange $list [incr open] [incr n -2]]
		    set res "[apl2t $embed] $res"
		    set n $open
	      } elseif {$it=="\]"} {
		    if {$last=="val"} {set res \"$res}
		    set last op
		    set op indx
		    set open [matchParen $list [expr $n-1] \[ \]]
		    set embed [lrange $list [incr open] [incr n -2]]
		    set res "{[apl2t $embed]} $res"
		    set n $open
	      } else {
		    if {$last=="val"} {set res \"$res}
		    set last op
		    if [llength $op] {
		      set res "\[$op $res\]"; set op ""
		    }
		    set op $it
	    }
	    #puts n=$n,it=$it,last=$last,res=$res
	  }
	  if {$last=="val"} {set res \"$res}
	  if [llength $op] {set res "\[$op $res\]"}
 	  set res
    }
    proc matchParen {list pos open close} {
        set nparens 0
        for {set i $pos} {$i>=0} {incr i -1} {
            if {[lindex $list $i]==$close} {incr nparens}
            if {[lindex $list $i]==$open} {incr nparens -1}
            if {$nparens==0} break
        }
        if $nparens {error "paren error"}
        set i
    }
    proc playstation {w args} {
        array set a {-font {SImPL 12}}
        array set a $args
        set keys [concat [specials] 0x28-0x5B 0x5D 0x7C%5