revision/simplification of apl.ps

apl2.ps

%apply unary proc to array. ie. proc implements a monadic operator
/mop{ % A proc 
    1 index type /arraytype eq {
        [ 3 1 roll % [ A proc
            exch % [ proc A
            { % [ ... proc A_i
                1 index op % [ ... proc A_i'
                exch % [ ... A_i' proc
            }forall
            pop
        ]
    }{
        exec
    } ifelse
}def

%apply a binary proc to (array|scalar,array|scalar). ie. proc implements a binary operator
% case "array1 array2": call recursively upon array1_i array2_i, appending zeros for compatability
% case "array scalar": apply proc to array_i scalar
% case "scalar array": apply proc to scalar array_i
% case "scalar scalar": apply proc, duh 
/bop{ % A B proc
    1 index type /arraytype eq { % ? B proc
        2 index type /arraytype eq { % A B proc
            3 copy pop length exch length exch lt { % A B proc  :nA<nB
                true 4 1 roll % swapped! A B proc
                3 2 roll exch % swapped! B A proc
            }{
                false 4 1 roll % not-swapped! A B proc
            }ifelse % swapped? A B proc   :nA>=nB
            3 copy pop length exch length exch sub % bool A B proc nA-nB
            exch 4 1 roll % bool proc A B nA-nB
            [ 3 2 roll % bool proc A dnAB [ B
                {} forall % bool proc A dnAB [ ... Bn
                counttomark 2 add -1 roll % bool proc A [ ... Bn dnAB
                {0} repeat % bool proc A [ ... Bn 0^dnAB
            ] % bool proc A B'
            4 3 roll {exch} if % proc A B  :un-swapped
            3 2 roll % A('?) B('?) proc
            [ 4 1 roll % [ A B proc
                0 1 4 index length 1 sub { % [ ... A B proc i
                    4 copy exch pop get % [ ... A B proc i A B_i
                    exch 2 index get % [ ... A B proc i B_i A_i
                    3 index bop % [ ... A B proc i [B_i{proc}A_i]
                    5 1 roll pop % [ ... [B_i{proc}A_i] A B proc
                } for % [ ... [B_i{proc}A_i] A B proc
                pop pop pop
            ]
        }{ % a B proc
            [ 4 1 roll % [ a B proc 
                exch { % % [ ... a proc  B_i
                    2 index exch % [ ... a proc  a B_i
                    2 index exec % [ ... a proc a{proc}B_i
                    3 1 roll % [ ... a{proc}B_i  a proc
                } forall
                pop pop % [ ... a{proc}B_i
            ]
        } ifelse
    }{ %b is not array, ie. scalar
        2 index type /arraytype eq { % A b proc
            [ 4 1 roll % [ A b proc
                3 2 roll { % [ ... b proc  A_i
                    2 index % [ ... b proc  A_i b
                    2 index exec % [ ... b proc  A_i{proc}b
                    3 1 roll % [ ... A_i{proc}b  b proc
                } forall
                pop pop % [ ... A_i{proc}b
            ]
        }{ % a b proc :a,b not array, ie. scalar
            exec % a{proc}b
        } ifelse
    } ifelse
}def

/IDENTITIES <<
>> def

% call mop or bop depending on available operands
/op{ % (A)? B proc
    count 3 ge { %count>=3
        2 index type % ... A B proc Atype
        dup /arraytype eq exch % ... A B proc Aarray? Atype
        dup /integertype eq exch % ... A B proc Aarray? Ainteger? Atype
        /realtype eq % ... A B proc Aarray? Ainteger? Areal?
        or or % ... A B proc Aoperable?
        %pstack()=
        {
            %(dyadic)=
            bop
        }{
            %(monadic)=
            mop
        } ifelse
    }{ % count<3
        count 2 eq { % ... A proc
            %(monadic)=
            mop
        }{
            count 1 eq { %  proc  
                %(identity)=
                IDENTITIES exch get  % operator-identity-element
            }{ % count=0
                %(no function)=
                0
            } ifelse
        }ifelse
    } ifelse
}def

%A B |
%select from B elements indicated by A
/|{ %compression  [] []
    1 index xcheck { % {} []  :A is a proc, execute it over B and collect results
        [ 3 1 roll % [ {A} B
            { % [ ... {A} B_i
                2 copy exch % [ ... {A} B_i B_i {A}
                exec
                dup type/realtype eq{cvi}if
                dup type/integertype eq{0 ne}if  % convert integer result from A to bool
                { % [ ... {A} B_i
                    exch % [ ... B_i {A}
                }{
                    pop % [ ... {A}
                } ifelse
            } forall
            pop
        ]
    }{ % A is an (logical) array of ints or bools
        [ 3 1 roll % [ A B
            exch % [ B A
            0 1 2 index length 1 sub % [ B A 0 1 nA-1
            { % [ ... B A i
                2 copy get                  % [ ... B A i A_i
                %pstack()=
                dup type/booleantype eq{{1}{0}ifelse}if
                0 ne { % [ ... B A i
                    2 index exch get % [ ... B A B_i
                    3 1 roll             % [ ... B_i B A
                }{
                    pop                  % [ ... B A
                } ifelse
            } for
            pop pop
        ]
    } ifelse
}def

/i{%n j
    exch % j n
    [ 3 1 roll % [ j n
        1 exch % [ j 1 n
        3 copy pop sub add % [ j 1 j+n-1
        {} for
    ]
} def
/i1{1 i}def
/i0{0 i}def

/@{ %order reversal
    [ exch
        dup length 1 sub -1 0 { % [ ... A i
            2 copy get % [ ... A i A_i
            3 1 roll pop % [ ... A_i A
        } for % [ ... A_i A
        pop
    ]
}def

/over{ % A proc
    [ 3 1 roll % [ A proc
        dup 0 get IDENTITIES exch get % [ A proc procID
        3 1 roll % [ procID A proc
        forall
    ]
}def

/+{{add}op}def IDENTITIES //+ 0 get 0 put
/*{{mul}op}def IDENTITIES //* 0 get 1 put
/^{{exp}op}def IDENTITIES //^ 0 get 3 5 63 div sqrt sub put
%http://mathworld.wolfram.com/eApproximations.html approx to 7 digits ~= 32bit float precision

/+|{//+ over}def
/*|{//* over}def
/^|{//* over}def

/P{ %polynomial  C x
    1 index length i0 ^ * +| 
}def

/#{ % to binary
    dup 0 exch { 2 copy lt {exch} if pop } forall % A maxA
    dup 0 eq { pop 1 } if
    ln 3 ln div ceiling cvi % A maxdigitA
    [ 3 1 roll  % [ A m
        exch % [ m A
        {   % [ ... m A_i
            [ exch % [ ... m [ A_i
            2 index -1 0 { % [ ... m [ ... A_i m'
                2 copy % [ ... m [ ... A_i m' A_i m'
                neg bitshift 1 and % [ ... m [ ... A_i m' A_i>>-m'
                exch pop exch % [ ... m [ ... A_i>>-m' A_i
            } for
            pop
            ] % [ ... m []
            exch % [ ... [] m
        }forall
        pop % [ ... []
    ]
}def

/"{ % transpose  A
    << /ind 2 index length 1 sub >> begin
        [ exch  % [ A
        0 1 2 index 0 get length 1 sub % [ A 0 1 nA-1
        { % [ ... A i
            [ 3 1 roll % [ ... [ A i
            0 1 ind { % [ ... [ ... A i j
                3 copy % [ ... [ ... A i j A i j
                exch % [ ... [ ... A i j A j i
                3 1 roll % [ ... [ ... A i j i A j
                get exch get % [ ... [ ... A i j A_j_i
                4 1 roll pop % [ ... [ ... A_j_i A i
            } for
            pop % [ ... [ ... A_j_i A
            counttomark 1 add 1 roll % [ ... A [ ... A_j_i
            ] exch % [ ... [] A
        } for
        pop % [ ... []
        ] % [ ... [] ]
    end
}def

/2|{ %remainder after dividing by two
    dup type /arraytype eq {
        [ exch
        {
            2|
        } forall
        ]
    }{
        cvi 2 mod
    }ifelse
}def


4 i0 ==
4 i1 ==
5 -7 i ==
5 i0 8 i1 {add} bop ==
4 i0 dup + ==
5 i1 10 i1 + ==
-1 16 i1 + ==
^ =
[0 1 0 1] 10 i1 | ==
{2 mod 0 eq} 10 i1 | ==
{2 mod 1 eq} 10 i1 | ==
10 i1 @ ==

10 i1 +| ==
0 1 10 { i1 +| == } for
10 i1 *| ==
0 1 10 { i1 *| == } for

[4 6 3 0 5] 2 P ==

-1 8 i1 + # ==
-1 16 i1 + # {==}forall

-1 16 i1 + # " {==}forall

-1 16 i1 + # " @{{==only}forall()=}forall
()=

-1 16 i1 +    % [0 .. 15]
2 -1 4 i1 + ^ % [0 .. 15] [ [2^0 2^1 2^2 2^3]
%[exch{1 exch div}forall] %dup ==  % [0 .. 15]  [1/2^0 1/2^1 1/2^2 1/2^3]
%IDENTITIES 1 1 put {1 exch dup 0 eq {pop 1} if pstack()= div}op dup ==
1 exch {div}op
(hi)=
[3 1 roll{1 index * exch}forall pop] dup ==
% [[0.0 1.0 2.0 3.0 4.0 5.0 6.0 7.0 8.0 9.0 10.0 11.0 12.0 13.0 14.0 15.0]
% [0.0 0.5 1.0 1.5 2.0 2.5 3.0 3.5 4.0 4.5 5.0 5.5 6.0 6.5 7.0 7.5]
% [0.0 0.25 0.5 0.75 1.0 1.25 1.5 1.75 2.0 2.25 2.5 2.75 3.0 3.25 3.5 3.75]
% [0.0 0.125 0.25 0.375 0.5 0.625 0.75 0.875 1.0 1.125 1.25 1.375 1.5 1.625 1.75 1.875]]

2|  % 2-reduce
{{==only}forall()=}forall %print without spaces