- extreme brevity (the most powerful one-liners)
- strict infix operators (even user "procs" could only be written as nil-, mon-, or dyadic operators)
- no operator hierarchy (evaluation goes from right to left, only parenthesized expressions have priority)
- a huge set of special characters, requiring special keyboards and print-heads or fonts (including a handful of Greek letters - variable names could e.g. be made of A-Z, underscored or not, and Delta)
- handling arrays of one or more dimensions like scalars in one operation
- dynamic typing (character or number arrays of varying rank and dimensions)
- comparison of numbers (maybe doubles) is done with a configurable threshold CT (cf. A real problem)
% 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 1which in APL would be:
N N⍴1,N⍴0 -- Unicoded: N N\u23741,N\u23740The 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
