Richard Suchenwirth 2001-01-26 - APL, A Programming Language dating back from the 1960s, but still kicking, is characterized by
As yet another weekend fun project, here's some explorations of how to reimplement APL's features in Tcl. An initial attempt to use nested lists for arrays of higher dimensionality failed because of Tcl's ambiguity between a list element and a one-element list. So I modeled the array representation close to APL's printing behavior: an APLarray is a string, where elements at lowest level are separated by " ", one level up by \n, another level up by \n\n (etc. - the algorithms currently handle up to four dimensions...)
Using only various whitespaces as separators still allows to treat the data as a Tcl list, no matter how many dimensions. If you specify a constant array of rank>1 (which is not possible in APL), use quotes instead of braces so the newlines get parsed correctly. Two of the aspects of an APL array (dimensionality, e.g. "2 3 4" for a 2x3x4 matrix, and the data vector) are modulated together this way (see the rho1 and rho2 procs for the implementation). What's missing (yet) is the breaking up of strings into character vectors, and joining of character vectors back to strings on output. But you can use character vectors, as the test examples in the end show.
This is of course not a serious reimplementation, but knowing APL only from a book (dated 1978) and some web pages, I was thrilled to see the anticipated behavior reproduced by Tcl/APL commands, e.g. a N*N unit matrix by
% set N 5; rho "$N $N" [, 1 [rho $N 0]] 1 0 0 0 0 0 1 0 0 0 0 0 1 0 0 0 0 0 1 0 0 0 0 0 1
which in APL would be:
N N⍴1,N⍴0 -- Unicoded: N N\u23741,N\u23740
The Tcl example is 3.4 times as long as APL (and uses Polish instead of infix notation, of course), but still considerably shorter than if written in plain Tcl. See An APL playstation for getting even closer to APL, including infix syntax and the real APL characters.. This here is only a basic subset of the many APL operators, and not all functionality is covered (e.g. indx, which extracts array elements by position, currently works only on one-dimensional vectors) - but enjoy! If you know how to do it better, just edit this page!
namespace eval APL {
proc init {} {namespace eval :: {namespace import -force APL::*}}
variable IO 1 ;# index origin, may be set to 0
variable CT 1e-16 ;# Comparison tolerance
proc iota {n args} {
variable IO
set res [list]
if ![llength $args] {
for {set i $IO} {$i<($n+$IO)} {incr i} {
lappend res $i
}
return "$res " ;# force to an array
} else {
set args [lindex $args 0]
foreach i $args {
set ix [lsearch -exact $n $i]
if {$ix==-1} {set ix [llength $n]}
lappend res [incr ix $IO]
}
rho2 [rho1 "$args "] $res
}
}
proc rho {x args} {
switch [llength $args] {
0 {rho1 $x}
1 {rho2 $x [lindex $args 0]}
default {error "wrong # args: expected rho x ?y?"}
}
}
proc rho1 x {
if [set n [regsub -all \n\n\n $x \x81 x]] {
set x [lindex [split $x \x81] 0]
append res "[incr n] "
}
if [set n [regsub -all \n\n $x \x82 x]] {
set x [lindex [split $x \x82] 0]
append res "[incr n] "
}
set n [regsub -all \n $x \n x]
if {[info exists res]||$n} {
set x [lindex [split $x \n] 0]
append res "[incr n] "
}
if {[info exists res]||[regexp " " $x]} {
append res "[llength $x] "
} else {set res ""}
}
proc rho2 {dim data} {
set data [extend $data [mul/ $dim]]
foreach i $data j [getSepv $dim] {
if {$i==""} break
append res $i$j
}
set res
}
proc getSepv dim {
# make a separator vector, to be mingled with data in rho2
set n2 1; set n3 1; set n4 1; set res [list]
switch [llength $dim] {
0 {return ""}
1 {set n1 $dim}
2 {foreach {n2 n1} $dim break}
3 {foreach {n3 n2 n1} $dim break}
4 {foreach {n4 n3 n2 n1} $dim break}
default {error "can't handle dim>4 yet"}
}
for {set h 0} {$h<$n4} {incr h} {
for {set i 0} {$i<$n3} {incr i} {
for {set j 0} {$j<$n2} {incr j} {
for {set k 0} {$k<$n1-1} {incr k} {
lappend res " "
}
if {$j<$n2-1} {lappend res \n}
}
if {$i<$n3-1} {lappend res \n\n}
}
if {$h<$n4-1} {lappend res \n\n\n}
}
if {$res==""} {lappend res " "}
set res
}
proc extend {data n} {
#make a list of n elements from data, repeat and/or truncate
set data [join $data]
while {[llength $data]<$n} {eval lappend data $data}
lrange $data 0 [incr n -1]
}
# reducing from a list to a scalar
proc +/ data {expr [join $data +]+0}
proc mul/ data {
if ![llength $data] {return 1}
expr [join $data *]
}
interp alias {} \u00D7/ {} mul/
proc + {x args} {
if ![llength $args] {return $x}
op2 $x + [lindex $args 0]
}
proc - {x args} {
if ![llength $args] {
set res [list]
foreach i $x {lappend res [expr -$i]}
rho2 [rho1 $x] $res
} else {
op2 $x - [lindex $args 0]
}
}
proc max {x args} {
set res [list]
if ![llength $args] {
foreach i $x {
set t [expr {ceil($i)}]
regsub {\.0$} $t "" t
lappend res $t
}
set zrho [rho1 $x]
} else {
set y [lindex $args 0]
set zrho [targetrho $x $y]
set zn [mul/ $zrho]
foreach i [extend $x $zn] j [extend $y $zn] {
set t [expr $i>$j? $i:$j]
regsub {\.0$} $t "" t
lappend res $t
}
}
rho2 $zrho $res
}
# These procs do have funny names, but that's APL..
proc \u2308/ {x} {
set max -9.9e305
foreach i $x {if {$i>$max} {set max $i}}
set max
}
proc \u230A/ {x} {
set min 9.9e305
foreach i $x {if {$i<$min} {set min $i}}
set min
}
proc min {x args} {
set res [list]
if ![llength $args] {
foreach i $x {
set t [expr {floor($i)}]
regsub {\.0$} $t "" t
lappend res $t
}
set zrho [rho1 $x]
} else {
set y [lindex $args 0]
set zrho [targetrho $x $y]
set zn [mul/ $zrho]
foreach i [extend $x $zn] j [extend $y $zn] {
set t [expr $i<$j? $i:$j]
regsub {\.0$} $t "" t
lappend res $t
}
}
rho2 $zrho $res
}
proc mul {x args} {
if ![llength $args] {
set res [list]
foreach i $x {
if {$i} {
lappend res [expr {$i/abs($i)}]
} else {
lappend res 0
}
}
rho2 [rho1 $x] $res
} else {
op2 $x * [lindex $args 0]
}
}
proc div {x args} {
if ![llength $args] {
set res [list]
foreach i $x {
if {!$i} {error "domain error (divide by zero)"}
regsub {\.0$} [expr {1./$i}] "" t
lappend res $t
}
rho2 [rho1 $x] $res
} else {
op2 $x - [lindex $args 0]
}
}
proc | {x args} {
if ![llength $args] {
set res [list]
foreach i $x {
regsub {\.0$} [expr {abs($i)}] "" t
lappend res $t
}
rho2 [rho1 $x] $res
} else {
op2 [lindex $args 0] % $x
}
}
proc op2 {x op y} {
# template for binary arithmetic operators
set zrho [targetrho $x $y]
set zn [mul/ $zrho]
set res [list]
foreach i [extend $x $zn] j [extend $y $zn] {
if {$op=="%"} {
if !$j {
set t $i
} else {
set t1 [expr int(floor($i/$j))]
set t [expr {$i-$t1*$j}]
}
} else {set t [expr double($i) $op $j]}
regsub {\.0$} $t "" t
lappend res $t
}
rho2 $zrho $res
}
proc and {x y} {op2 $x && $y}
proc or {x y} {op2 $x || $y}
proc nand {x y} {~ [op2 $x && $y]}
proc nor {x y} {~ [op2 $x || $y]}
proc * {x args} {
if ![llength $args] {
set y $x
set x 2.7182818284590451
} else {set y [lindex $args 0]}
set zrho [targetrho $x $y]
set zn [mul/ $zrho]
set res [list]
foreach i [extend $x $zn] j [extend $y $zn] {
set t [expr pow($i,$j)]
regsub {\.0$} $t "" t
lappend res $t
}
rho2 $zrho $res
}
proc log {x args} {
if ![llength $args] {
set y $x
set x 2.7182818284590451
} else {set y [lindex $args 0]}
set zrho [targetrho $x $y]
set zn [mul/ $zrho]
set res [list]
foreach i [extend $x $zn] j [extend $y $zn] {
set t [expr log($j)/log($i)]
regsub {\.0$} $t "" t
lappend res $t
}
rho2 $zrho $res
}
proc circle {x args} {
if ![llength $args] {
op2 3.141592653589793 * $x
} else {
set y [lindex $args 0]
set res [list]
foreach i $y {
switch $x {
0 {lappend res [expr sqrt(1-$i*$i)]}
1 {lappend res [expr sin($i)]}
2 {lappend res [expr cos($i)]}
3 {lappend res [expr tan($i)]}
4 {lappend res [expr sqrt(1+$i*$i)]}
5 {lappend res [expr sinh($i)]}
6 {lappend res [expr cosh($i)]}
7 {lappend res [expr tanh($i)]}
-1 {lappend res [expr asin($i)]}
-2 {lappend res [expr acos($i)]}
-3 {lappend res [expr atan($i)]}
-4 {lappend res [expr sqrt(-1+$i*$i)]}
default {error "not yet implemented"}
}
}
rho2 [rho1 $x] $res
}
}
proc / {x y} {
# compress: delete elements of y where corresponding x is 0
set res [list]
if {1||[llength $x]==1} {set x [extend $x [llength $y]]}
foreach i $x j $y {
if {$i==""||$j==""} {error "length error"}
if $i {lappend res $j}
}
rho2 [+/ $x] $res
}
proc ? {x args} {
set res [list]
if [llength $args] {
if {$x>$args} {error "domain error"}
set v [iota $args]
foreach i [iota $x] {
set where [expr {int(rand()*[llength $v])}]
lappend res [lindex $v $where]
set v [lreplace $v $where $where]
}
} else {
foreach i $x {lappend res [? 1 $i]}
}
set res
}
proc targetrho {x y} {
set xrho [rho1 $x]
set yrho [rho1 $y]
set res $xrho
if {$xrho==""} {return $yrho}
if {$yrho!="" && $yrho!=$xrho} {error "length error"}
set res
}
proc = {x y} {cmp2 $x < $y}
proc /= {x y} {cmp2 $x >= $y}
proc cmp2 {x op y} {
variable CT
set zrho [targetrho $x $y]
set zn [mul/ $zrho]
set x [extend $x $zn]
set y [extend $y $zn]
set res [list]
foreach i $x j $y {
lappend res [expr abs($i-$j) $op $CT]
}
rho2 $zrho $res
}
proc epsilon {x y} {
set res [list] ;# element of
foreach i $x {
lappend res [expr {[lsearch -exact $y $i]>=0}]
}
rho2 [rho1 $x] $res
}
proc ~ x {
set res [list] ;# NOT
foreach i $x {
switch -- $i {
0 - 1 {lappend res [expr {1-$i}]}
default {error "domain error"}
}
}
rho2 [rho1 $x] $res
}
proc , {x args} {
switch [llength $args] {
0 {join $x}
1 {concat [join $x] [join [lindex $args 0]]}
default {error "wrong # args"}
}
}
proc indx {list ix} {
variable IO
set res [list]
set in [subst $ix]
foreach i $in {lappend res [lindex $list [expr $i-$IO]]}
rho2 [rho1 $in] $res
}
}
# That's it, now testing...
APL::init
set test {
iota 5 ;# 1 2 3 4 5
rho 1 ;# "" - scalars have no dimension
rho "1 " ;# 1 - force 1-element vector
rho [rho 1 1] ;# 1 - the APL way to force a vector
rho {1 2} ;# 2
rho "1 2\n3 4" ;# 2 2 - a small matrix
rho "1 2 0\n0 3 4\n\n0 5 6\n0 7 8" ;# 2 2 3
rho "2 3" [iota 6]
rho "2 3 3" [iota 6]
+ {1 2 3} {4 5 6} ;# 5 7 9 - sum element by element
- 10 [iota 7] ;# 9 8 7 6 5 4 3
+ [iota 6] 10 ;# 11 12 13 14 15 16
rho {4 4} [, 1 [rho 4 0]] ;# 4x4 unit matrix
eps "A B\nC D" {A P L T C L} ;# 1 0\n1 0
= 3 [iota 5] ;# 0 0 1 0 0
/= 3 [iota 5] ;# 1 1 0 1 1
~ [eps {A P L} {T C L}] ;# 1 1 0
set t [iota 6]; -: [+/ $t] [rho $t] ;# 3.5
/ [rho 8 {1 0}] [iota 8] ;# 1 3 5 7
lsort -integer [? 6 49] ;# six lotto numbers
? 5 5 ;# a permutation of {1 2 3 4 5}
}
foreach i [split $test \n] {puts "$i => [eval $i]"} Playing with APL is only half the fun if you can't at least sometimes see the real (are they?) APL symbols - see APLish.
The modern (ASCIIfied) heir to APL is J - see Tacit programming
"APL is a mistake, carried through to perfection. It is the language of the future for the programming techniques of the past: it creates a new generation of coding bums." —Edsger Dijkstra, 1968