[http:../../pub/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]
        wm title [toplevel $w] "APL PlayStation"
        text $w.t -font $a(-font) -width 40  -height 16 -wrap word
        entry $w.e -textvariable ::input -font $a(-font)
        keyboard $w.k -keys $keys -receiver $w.e -font $a(-font)
        pack $w.k $w.e -side bottom -fill x
        pack $w.t -side bottom -fill both -expand 1
        
        foreach i {red blue} {$w.t tag config $i -foreground $i}
        $w.t insert end "Welcome to TclAPL 0.1 - enjoy!\n" red
        update
        $w.t tag config i6 -lmargin2 [expr 6*[lindex [$w.t bbox 1.0] 2]]
        bind $w.e <Return> {APL::aps_go %W}
        focus $w.e 
    }
    proc aps_go w {
        set ::_txt [winfo parent $w].t
        uplevel #0 {
            $_txt insert end "      $::input\n" blue
            if [catch {apl $input} res] {
                $_txt insert end "error in [apl2t $input]:\n$res\n" red
            } else {$_txt insert end $res\n i6; set input ""}
        }
        $::_txt see end
    }
    proc specials {} {
        variable aplascii_ucs
        foreach {- i} $aplascii_ucs {lappend res $i}
        set res
    }
 }
 proc keyboard {w args} {
    array set a [concat {
        -keysperline 20 -keys {0x21-0x7E} -font Courier
        } $args]
    frame $w
    set keys [list]
    foreach i [clist2list $a(-keys)] {
    	set c [format %c $i]
    	set cmd [list $a(-receiver) insert insert $c]
	    button $w.k$i -text $c -command $cmd -font $a(-font) -padx 0 -pady 0
        lappend keys $w.k$i
        if {[llength $keys]==$a(-keysperline)} {
            eval grid $keys -sticky news
            set keys [list]
        }
    }
    button $w.cr -text "" -command "APL::aps_go $w" -padx 0 -pady 0
    lappend keys $w.cr
    if [llength $keys] {eval grid $keys -sticky news}
    set w
 }
 proc clist2list {clist} {
    #-- clist: compact integer list w.ranges, e.g. {1-5 7 9-11}
    set res {}
    foreach i $clist {
	    if [regexp {([^-]+)-([^-]+)} $i -> from to] {
	        for {set j [expr $from]} {$j<=$to} {incr j} {
		    lappend res $j
	        }
	    } else {lappend res [expr $i]}
    }
    set res
 }
----
[Arts and crafts of Tcl-Tk programming]