An APL playstation
Richard Suchenwirth 2001-01-29 - 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
}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 SmithI 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.