[Richard Suchenwirth] 2001-01-29 - For all friends of ''A Programming Language'' (APL), here is a little Tk app
with (from bottom up)

[WikiDbImage aplkbd.gif]

   * 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
 }
======

----
'''''[escargo] 17 Apr 2003 - There seems to be some code missing....''''' [RS] 2003-08-15 Fixed.

[CMcC] This is totally cool.  Question for RS, as implementor: does Tcl need a special Tcl_Obj for
multi-dimensional arrays to make this totally efficient as well as totally cool? [RS]: I have implemented them as strings with different separators, which is of course inefficient. But Tcl lists can't express the difference between a row and a column vector... [FF] Why not using ::math library?

[LV] FF, the above code was probably before ::math. I suspect someone might update the code to take advantage of the past 4-5 years of software development ;-).
----

[n0nsense] 12 Sep 2008 - why are lowercase letters not accepted?
[RS] 2008-09-22: APL is an ancient language, it was implemented in typewriter hardware (the print head, to be precise), and as they needed so many special characters for the operators, there wasn't room for lowercase letters. (Or so I think.)

[LV] Here's an article that talks about APL - http://www.dvorak.org/blog/?page_id=8219 . Notice that article claims that it wasn't just upper case, but upper case italic!

[Larry Smith]I used APL back in the day, when I was a liddle-bitty programmer.  And, yes, the typeball for the selectric teletype machine was upper-case italic only.  But it should be noted that you were allowed an underline "case" as well, so rather than upper and lower case you had instead upper and underlined case.  I see no reason why we can't map upper-and-underline to upper-and-lower - or maybe lower-and-upper since non-underlined was used most and underlined mostly for emphasis.

<<categories>> Example