Concatenative PostScript library

Question

As a part of picking up concatenative programming, I decided to implement the common concatenative operations in PostScript. Here is my attempt at implementing some of the words in other concatenative languages in PostScript. Would any one who is familiar with PostScript and functional/concatenative programming comment on my code?

%!PS
% conventions: parameter names with let begins with .

% basic definition, makes the definitions less verbose.
/. {bind def} bind def
/' {load} bind def
/reverse {{} exch {exch [3 1 roll aload pop]} forall}.
/let {dup length dict begin reverse {exch def} forall}.
/let* {reverse {exch def} forall}.

% some predicates.
/eq? {eq}.
/list? {dup type /arraytype eq?}.
/leaf? {list? not}.
/empty? {dup length 0 eq?}.
/zero? {dup 0 eq?}.

% stacky functions
/rup {3 1 roll}.
/rdown {3 -1 roll}.
/# {exch dup rdown .makeoperator bind def} bind def

/getname {dup 0 get exch}.
/getbody {dup length 1 sub 1 exch getinterval}.

% convenience arithmetic
/+ {add}.
/- {sub}.
/* {mul}.
/\ {div}.

% lispy functions
/first {0 get}.
/car {first}.
/!first {dup first}.
/rest {dup length 1 sub 1 exch getinterval}.
/cdr {rest}.
/!rest {dup rest}.
/head  {dup length 1 sub 0 exch getinterval}.
/!head {dup head}.
/tail  {dup length 1 sub get}.
/!tail {dup tail}.
/cons  {[rup aload pop]}.
/tadd  {[rup aload length 1 add -1 roll] }.
/uncons {getname getbody}.
/concat {exch [ rup aload pop counttomark -1 roll aload pop ] }.
% make a unit list.
/unit {1 array astore cvx}.
/succ {1 add}.
/pred {1 sub}.
/range {[rup exch aload pop rup exch rdown {} for]}.

% higher order thingies.
/map { [ rup forall ] }.
% [1 2 3 4] {1 add} map
/fold {rup exch rdown forall}.
%/reverse {{} {exch cons} fold}.
% {} [1 2 3 4 5] {exch cons} forall

% [1 2 3 4] 0 {+} fold
% name - filter is taken so we are left with..
/find {
4 dict begin
    /aif {0 /get /if}.
    /atox { [ exch cvx {cvx} forall ] cvx}.
    [ rup [ /dup rdown /exec /not [{pop}] aif ] atox forall ]
end}.

/transpose {
    [ exch {
        { {empty? exch pop} map all?} {pop exit} ift
        [ exch {} {uncons {exch cons} dip exch} fold counttomark 1 roll] uncons
    } loop ] {reverse} map
}.

/zip {[rup] transpose}.

/all? {
    {
        {empty?} ? {pop true exit} if
        uncons {?} dip exch not {pop false exit} if
    } loop
}.

/any? {
    {
        {empty?} ? {pop false exit} if
        uncons {?} dip exch {pop true exit} if
    } loop
}.
/pipe {
    {
        {empty?} ? {pop exit} if
        uncons {i} dip
    } loop
}.
%  1 {{2 *} {3 *} {5 *}} pipe
/collect {
    {
        {empty?} ? {pop exit} if
        uncons {?} dip
    } loop
}.
%  1 {{2 *} {3 *} {5 *}} collect

/? {
4 dict begin
    [/.pred] let*
    count array astore /.stack exch def
    /_restore {clear .stack aload pop}.
    .stack aload pop .pred /.top exch def
    _restore .top
end}.

% control structures
/ift {
[/.if /.then] let
    /.if ' ?  /.then ' if
end}.

/ifte {
[/.if /.then /.else] let
    /.if ' ?  /.then ' /.else ' ifelse
end}.
% switch statement.
/is? {{exit} concat cvx ift}.
/cond {{exit} concat cvx loop}.

% combinators
/dip {
[/.v /.q] let
    .q /.v '
end}.
/apply {exec}.
/i {cvx exec}.

/linrec {
[/.if /.then /.rec1 /.rec2] let
    /.if ' /.then '
        {.rec1
            {/.if ' /.then ' /.rec1 ' /.rec2 ' linrec} i
        .rec2}
    ifte
end}.

/binrec {
[/.if /.then /.rec1 /.rec2] let
    /.if ' /.then '
        { .rec1
            {/.if ' /.then ' /.rec1 ' /.rec2 ' binrec} dip
            {/.if ' /.then ' /.rec1 ' /.rec2 ' binrec} i
          .rec2 }
    ifte
end}.

/genrec {
[/.if /.then /.rec1 /.rec2] let
    /.if ' /.then '
        {.rec1
            {/.if ' /.then ' /.rec1 ' /.rec2 ' genrec}
         .rec2}
    ifte
end}.

/tailrec {{} linrec}.

/primrec {
5 dict begin
    /lzero? {
        {list?} {empty?}
                {zero?}
        ifte}.
    /lnext {
        {list?} {rest}
                {pred}
        ifte}.
[/.param /.then /.rec] let*
    {/.param ' lzero?} /.then '
        {.param
            {/.param ' lnext /.then ' /.rec ' primrec} i
        .rec}
    ifte
end}.

/treemap {
[/.tree /.rec] let
    /.tree '
    {leaf?} /.rec '
        {{empty?} {}
            {dup
                {first /.rec ' treemap} dip
                {rest /.rec ' treemap} i cons}
        ifte}
    ifte
end}.

% debug
/puts {= flush}.
/cvstr {
    4 dict begin
        /elements exch def
        /len elements length def
        /str len string def
        /i 0 def
        {
        i len ge { exit } if
        str i
        %The element of the array, as a hexadecimal string.
        %If it exceeds 16#FF, this will fail with a rangecheck.
        elements i get cvi
        put
        /i i 1 add def
    } loop
    str
end
} def


/, {(=============\n)
    print pstack
    (=============\n) print}.

localdefs.ps includes any definitions that needs to be included locally.

% set the prompt to something else so that we know initlib is loaded.
/prompt {(>| ) print flush} bind def
/:x {(localdefs.ps) run}.

Here is how to load the library and get a working REPL.

rlwrap ghostscript -q -dNOSAFER -dNODISPLAY -c '(init.ps) run' $*

Answer 1

There is an improvement that can be made to the map function. Your version:

/. {bind def} bind def

%...

/rup {3 1 roll}.

%...

/map { [ rup forall ] }.
% [1 2 3 4] {1 add} map

The problem here is building the new array on the stack. While normally this is a perfectly sound technique in postscript, it places severe restrictions on how the procedure must behave. Using debug.ps to produce a trace (caveat: I had to remove all the bind calls because the debugger has a bug with binding, apparently) illustrates how the execution proceeds through the example [1 2 3 4] {1 add} map. (I know you know how it executes, this is for the audience. ;)

[  %|- -mark- 
1  %|- -mark- 1 
2  %|- -mark- 1 2 
3  %|- -mark- 1 2 3 
4  %|- -mark- 1 2 3 4 
]  %|- [1 2 3 4] 
{1 add}  %|- [1 2 3 4] {1 add} 
map  %|- [1 2 3 4] {1 add} 
[  %|- [1 2 3 4] {1 add} -mark- 
rup  %|- [1 2 3 4] {1 add} -mark- 
3  %|- [1 2 3 4] {1 add} -mark- 3 
1  %|- [1 2 3 4] {1 add} -mark- 3 1 
roll  %|- -mark- [1 2 3 4] {1 add} 
forall  %|- -mark- 1 
1  %|- -mark- 1 1 
add  %|- -mark- 2 
[2 3 4]  %|- -mark- 2 [2 3 4] 
{1 add}  %|- -mark- 2 [2 3 4] {1 add} 
forall  %|- -mark- 2 2 
1  %|- -mark- 2 2 1 
add  %|- -mark- 2 3 
[3 4]  %|- -mark- 2 3 [3 4] 
{1 add}  %|- -mark- 2 3 [3 4] {1 add} 
forall  %|- -mark- 2 3 3 
1  %|- -mark- 2 3 3 1 
add  %|- -mark- 2 3 4 
[4]  %|- -mark- 2 3 4 [4] 
{1 add}  %|- -mark- 2 3 4 [4] {1 add} 
forall  %|- -mark- 2 3 4 4 
1  %|- -mark- 2 3 4 4 1 
add  %|- -mark- 2 3 4 5 
[]  %|- -mark- 2 3 4 5 [] 
{1 add}  %|- -mark- 2 3 4 5 [] {1 add} 
forall  %|- -mark- 2 3 4 5

So whenever the procedure (the loop body) executes, the rest of the array is on the stack.

1  %|- -mark- 1 1 
add  %|- -mark- 2 
% ...
1  %|- -mark- 2 2 1 
add  %|- -mark- 2 3 
% ...
1  %|- -mark- 2 3 3 1 
add  %|- -mark- 2 3 4 
% ...
1  %|- -mark- 2 3 4 4 1 
add  %|- -mark- 2 3 4 5 

So you can't do something like this to add a constant to each element. Because the array-building gets in the way.

5 [1 2 3 4] {1 index add} map

A good attempt at removing this difficulty came from Carlos in a comp.lang.postscript thread. Instead of using a forall loop directly, he uses a for loop running through the indices of the array and calls the user proc by name, managing the extraction and re-insertion of the the values in the array in the loop body.

The problem there is that we've simply passed-off the interference to a different stack. The operand stack is now clear and usable, but the dictionary stack now has our bookkeeping dictionary on top (or worse: everything is global in userdict). So we're very prone to name-collision and unintended scoping issues when trying to use the function in an application.

A couple of little-known features of the postscript language combine to offer a solution: dynamic code-generation. So we want a map that roughly does this:

/map { % arr proc  map  arr'
    10 dict begin           % arr proc
    /proc exch def          % arr
    /arr exch def           % <empty>
    0 1 arr length 1 sub {  % i
        /i exch def         % <empty>
        arr i get           % arr_i
        proc                % proc(arr_i)
        arr exch i exch put % <empty>
    } for                   % <empty>
    arr                     % arr'
    end                     % arr'
} def

But without having this local dictionary on the stack while proc is executing.

What we can do to accomplish this is to generate a loop-body with these names hard-bound to their values. Postscript provides its scanner as the token operator which can produce a complete procedure-body from a string template.

({1 1 add =} remainder) token  %  ( remainder) {1 1 add =} true
pop                            %  ( remainder) {1 1 add =}
exch                           %  {1 1 add =} ( remainder)
pop                            %  {1 1 add =}

And the scanner will also substitute names prefixed with a double-slash // when they are encountered. So we can do this, too:

/val 5 def
({//val =}) token pop exch pop %  {5 =}

Now the name doesn't need to be defined for the procedure to execute.

/val 5 def
({//val =}) token pop exch pop %  {5 =}
currentdict /val undef
exec  % prints: 5

So finally we get something like this:

/map { % arr proc  map  arr'
    10 dict begin           % arr proc
    /mydict currentdict def % arr proc
    /proc exch def          % arr
    /arr exch def           % <empty>
    0 1 arr length 1 sub    % 0 1 n-1
    ({
    {  % i
        //mydict exch /i exch put  % <empty>
        //arr                      % arr
        //mydict /i get            % arr i
        get                        % arr_i
        //mydict /proc get         % arr_i proc
        exec                       % proc(arr_i)
        //arr exch                 % arr proc(arr_i)
        //mydict /i get exch       % arr i proc(arr_i)
        put                        % <empty>
    } for                          % <empty>
    //arr                          % arr'
    }) token pop exch pop   % 0 1 n-1 {{...}for...}
    end                     %   <-- remove dictionary
    exec                    %   <-- execute dynamic proc
} def

You can also bind the procedure just before execing, to factor-out name lookups for the operators.

This version changes the existing array and returns that as the result. Carlos' final version creates a new array for the result, which is closer to the behavior of your original function.

---

It was not Carlos' final version. After I discovered possible problems with applying bind to the user-procedure, Carlos realized that the whole technique of calling token on a string containing a procedure (my big gimmick) was inherently prone to goofs with bind, and he produced this final final version. The string trick is gone. Instead all library functions (including the dynamic loop body) have bind applied at "library load time". The behavior is thus independent of the user redefining any operator names.

The string-token trick has been replaced by two procedures, deepcopy which makes a modifiable copy of the loop-body (bind makes the original loop-body -- as it does to all subarrays of the function -- readonly, so we need a copy in order to patch the variables), and replaceall which takes an array and a dictionary and maps the array (recursively) through the dictionary (it patches the variables). So this is now a much more robust function.

% <array/string> <proc> map <new array/string> 
/map { 
    4 dict begin 

        /,proc exch def 
        /,arr exch def 
        /,res ,arr length 
             ,arr type /stringtype eq { string } { array } ifelse 
        def 
        /,i 1 array def 
        { 
            0 1 /,arr length 1 sub { % for 
                dup /,i 0  3 -1 roll  put 
                /,arr exch get 
                /,proc exec 
                /,res /,i 0 get  3 -1 roll  put 
            } for 
            /,res 
        } deepcopy dup currentdict replaceall 
    end exec 
} bind def 

% copies array recursively 
% <array> deepcopy <new array> 
/deepcopy { 
    dup xcheck exch 
    dup length array copy 
    dup length 1 sub 0 exch 1 exch { % for       % a i 
        2 copy 2 copy get dup type /arraytype eq % a i a i e ? 
        { % ifelse 
            deepcopy put 
        } 
        { 
            pop pop pop 
        } ifelse 
        pop 
    } for 
    exch { cvx } if 
} bind def 

% recursively replaces elements in <array> found in <dict> 
% <array> <dict> replaceall - 
/replaceall { 
    1 index length 1 sub  0 1  3 -1 roll { % for 0 1 length-1 
        3 copy  3 -1 roll  exch    % a d i d a i 
        get                        % a d i d e 
        2 copy known               % a d i d e ? 
        % ifelse 
        {                          % a d i d e 
            get                    % a d i v 
            3 index  3 1 roll      % a d a i v 
            put 
        } % else 
        {                          % a d i d e 
            dup type /arraytype eq % a d i d e ? 
            { exch replaceall } 
            { pop pop } ifelse 
            pop 
        } ifelse                   % a d 
    } for 
    pop pop 
} bind def 

Answer 2

Here's a solution that doesn't use as many deep features of PostScript, although it might be considered twisted in its own way. It stores temporary variables at the bottom of the stack instead of at the top, and does this by rotating the entire stack repeatedly. Even so, it seems efficient enough.

First, a version that modifies the array in place.

% Very general map that operates on an existing array.                                              
% Does not pollute dictionary. Allows natural access to stack.                                      
% Efficiency may vary since it rotates the entire stack a lot.                                      

/map {          % array f map --                                                                    
                                        % ... array f                                               
    count count 1 add roll              % array f ...                                               
    count 1 sub index                   % array f ... array                                         
    length 1 sub 0 exch 1 exch          % array f ... 0 1 (n-1)                                     
    {                                   % array f ... i                                             
        count count roll                % i array f ...                                             
        count 2 sub index               % i array f ... array                                       
        count 1 sub index               % i array f ... array i                                     
        get                             % i array f ... array[i]                                    
        count 3 sub index               % i array f ... array[i] f                                  
        exec                            % i array f ... f(array[i])                                 
        count 2 sub index               % i array f ... f(array[i]) array                           
        exch                            % i array f ... array f(array[i])                           
        count 1 count sub roll          % array f ... array f(array[i]) i                           
        exch put                        % array f ...                                               
    } for
    count 0 count sub roll              % ... array f                                               
    pop pop                             % ...                                                       
} bind def

Second, a version that leaves the array unmodified and returns a new array:

% Very general map that returns a new array.                                                        
% Does not pollute dictionary. Allows natural access to stack.                                      
% Efficiency may vary since it rotates the entire stack a lot.                                      

/mapc {         % array f map -- array                                                              
                                        % ... array f                                               
    exch dup length array               % ... f array newarr                                        
    count count 2 add roll              % f array newarr ...                                        
    count 2 sub index                   % f array newarr ... array                                  
    length 1 sub 0 exch 1 exch          % f array newarr ... 0 1 (n-1)                              
    {                                   % f array newarr ... i                                      
        count count roll                % i f array newarr ...                                      
        count 3 sub index               % i f array newarr ... array                                
        count 1 sub index               % i f array newarr ... array i                              
        get                             % i f array newarr ... array[i]                             
        count 2 sub index               % i f array newarr ... array[i] f                           
        exec                            % i f array newarr ... f(array[i])                          
        count 4 sub index               % i f array newarr ... f(array[i]) newarr                   
        exch                            % i f array newarr ... newarr f(array[i])                   
        count 1 count sub roll          % f array newarr ... array f(array[i]) i                    
        exch put                        % f array newarr ...                                        
    } for
    count 0 count sub roll              % newarr ... f array                                        
    pop pop                             % newarr ...                                                
    count 1 count sub roll              % ... newarr                                                
} bind def