%!
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% 
% @(#)ps.ps
% PostScript meta-interpreter.
% Copyright (C) 1989.
% By Don Hopkins. (don@brillig.umd.edu)
% All rights reserved.
% 
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% 
%  This program is provided for UNRESTRICTED use provided that this
%  copyright message is preserved on all copies and derivative works.
%  This is provided without any warranty. No author or distributor
%  accepts any responsibility whatsoever to any person or any entity
%  with respect to any loss or damage caused or alleged to be caused
%  directly or indirectly by this program. If you have read this far, 
%  you obviously take this stuff far too seriously, and if you're a 
%  lawyer, you should give up your vile and evil ways, and go find
%  meaningful employment. So there. 
% 
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

% Problems:
%   How do we catch the execution of event Name and Action dict values,
%   executed by awaitevent?

systemdict begin

/iexec-types 100 dict def
/iexec-operators 100 dict def
/iexec-names 200 dict def
/iexec-exit-stoppers 20 dict def
/iexec-single-forall-types 20 dict def
/iexec-array-like-types 20 dict def

/iexec-continue-procs? true def
/iexec-continue-names? true def

/iexecing? false def

/signal-error { % name => -
  dbgbreak
} def

/iexec-stopped-pending? { % - => bool
  false
  ExecSP 1 sub -1 0 {
    ExecStack exch get % ob
    dup type /dicttype eq {
      dup /continuation known {
	dup /continuation get /stopped eq {
	  pop true exit
	} { pop } ifelse
      } { pop } ifelse
    } { pop } ifelse
  } for
} def

/olddbgerrorhandler /DbgErrorHandler load ?def

/iexec-handle-error {
  iexec-stopped-pending? 
  true { stoppedpending? } ifelse
  {
    /stop load PushExec
  } {
    $error /errorname get signal-error
  } ifelse
} def

/DbgErrorHandler {
  iexecing? {
    iexec-handle-error
  } //olddbgerrorhandler ifelse
} def

/isarray? { % obj => bool
  type iexec-array-like-types exch known
} ?def

%
% A procedure to allow programmer to know if there is a "stopped"
% pending somewhere within the scope of the call.  This is used
% to check if it's safe to rely on stopped to handle an error,
% rather than the errordict.  The debugger can use this to
% catch errors that have no stopped call pending.
%
/stoppedpending? {	% - => bool
    false currentprocess /ExecutionStack get		% result a
    dup length 1 sub -2 1 {				% result a i
        2 copy get					% result a i index
        exch 1 sub 2 index exch get			% result a index proc
        dup isarray? {
            exch 1 sub get				% result a caller
            /stopped load eq {pop true exch exit} if
        } {
            pop pop
        } ifelse
    } for
    pop
} ?def

/?iexec-handle-error { % - => -
  { iexec-handle-error } if
} def

% interpretivly execute an object

/iexec { % obj => ...
  100 dict begin
    % This functions "end"s the interpreter dict, executes an object in the
    % context of the interpreted process, and "begin"'s back onto the
    % interpreter dict. Note the circularity.
    /MumbleFrotz [ % obj => ...
      /end load /exec load currentdict /begin load
    ] cvx def

    /ExecStack 32 array def
    /ExecSP -1 def

    /PushExec [ % obj => -
      /ExecSP dup cvx 1 /add load /store load
      ExecStack /exch load /ExecSP cvx /exch load /put load
    ] cvx def

    /PopExec [ % obj => -
      ExecStack /ExecSP cvx /get load
      /ExecSP dup cvx 1 /sub load /store load
    ] cvx def

    /TraceStep {
      iexec-step
    } def

    PushExec

    { ExecSP 0 lt { nullproc exit } if % nothing left to execute? goodbye.

      ExecStack 0 ExecSP 1 add getinterval
      TraceStep pop

      % pop top of exec stack onto the operand stack
      PopExec

      % is it executable? (else just push literal)
      dup xcheck { % obj
	% do we know how to execute it?
	dup type
        //iexec-types 1 index known { % obj type
	  //iexec-types exch get exec % ...
	} { % obj type
	  % some random type. just push it.
	  pop % obj
	} ifelse
      } if % else: obj

    } loop % goodbye-proc

    currentdict /MumbleFrotz undef % Clean up circular reference
  end
  exec % whoever exited the above loop left a goodbye proc on the stack.
} def

% visually execute an object, dumping drawing of stacks to trace-file

/vexec { % obj => ...
  { { 
      (
%!
/l { % gray x y lastx lasty
  moveto
  2 copy lineto
  0 setgray
  stroke

  2 copy .3 0 360 arc
  0 setgray
  fill

  .25 0 360 arc
  setgray
  fill

  pause
} def
/e { % x y => -
  gsave
    translate
    0 setlinewidth
    360 32 div rotate
    16 {
      0 0 moveto
      1 0 rlineto
      0 setgray
      stroke
      1 0 .1 0 360 arc
      random setgray
      fill
      360 16 div rotate
    } repeat
  grestore
} def
systemdict /pause known not {
  /pause {} def
} if
gsave
20 20 scale
1 1 translate
0 setgray
0 setlinewidth
erasepage
)
      trace-print
      /TraceX 0 def
      /TraceY count 1 sub def
      /TraceZ 0 def
      /TraceStep {
%          (\() print ExecSP iexec-printexec (\)print ) trace-print
	  TraceY TraceX % x y
	  /TraceX ExecSP def
	  /TraceY count 2 sub def
	  /TraceZ TraceZ 1 add 360 mod def
	  TraceZ 15 mul cos 1 add 3 div 1 exch sub trace-print#
	  TraceX trace-print# TraceY trace-print#
          trace-print# trace-print# % print x,y
	  (l\n) trace-print
	  random .2 le { flush pause pause pause } if
      } def
      /signal-error { % name => -
	/TraceX ExecSP def
	/TraceY count 3 sub def
	TraceX trace-print# TraceY trace-print#
	(e\n) trace-print
        (grestore showpage\n) trace-print trace-flush
        /stop load PushExec
      } def
    } meta-exec
    exec
    (grestore showpage\n) trace-print trace-flush
  } iexec
} def

/trace-file (%socketc2000) (w) file def

/trace-flush {
  trace-file dup null eq { pop currentfile } if
  flushfile
} def

/trace-print { % string => -
  trace-file dup null eq { pop currentfile } if
  exch writestring
} def

%/trace-print# {typedprint} def
%/trace-print# {=} def
/trace-print# {
  (%\n) sprintf trace-print
} def

/annealexec { % obj => ...
  { { 
      (
%!
/F /Times-Roman findfont
/s { % str point h s b x y
  moveto sethsbcolor
  F exch scalefont setfont
  show
} def
gsave
)
      trace-print
      /TracedObjects 2000 dict def
      /TracedTypes 20 dict def
      TracedTypes begin
	/nametype 0 def
	/array .2 def
	/packedarray .2 def
	/operatortype .4 def
	/dicttype .6 def
	/canvas .8 def
      end

      /!FieldWidth 100 def
      /!FieldHeight 100 def

      /!StartBrightness .5 def
      /!StartSaturation 1 def
      /!StartPoint 18 def

      /!StepBrightness .2 def
      /!StepSaturation .2 def

      /!DecayBrightness .95 def
      /!DecaySaturation .95 def

      /!TraceHistory 10 def

      /!DistNear 5 def
      /!DistFar 50 def
      /!DistGrav .1 def
      /!DecaySpeedNear .5 def

      /!MagDecay .9 def
      /!Friction .95 def

      /LastTraced [] def

      /TraceStep { % estack => popped
	  dup length 1 sub get % obj
	  dup type TracedTypes known {
	    TracedObjects 1 index known not {
	      30 dict begin
		TracedObjects 1 index currentdict put
		/Hue TracedTypes 2 index type get def
		/Saturation !StartSaturation def
		/Brightness !StartBrightness def
		/Point !StartPoint def
		/X !FieldWidth random mul def
		/Y !FieldHeight random mul def
		/DX 0 def
		/DY 0 def
		/String 1 index cvs def
	      end
	    } if
	    10 dict begin
	      /Other null def  /Dist 0 def  /Dir 0 def  /Mag 1 def
	      TracedObjects exch get begin 
		LastObjects {
		  TracedObjects exch get
		  dup currentdict eq { pop } {
		    /Other exch store
		    Other /X get X sub
		    Other /Y get Y sub
		    2 index dup mul 2 index dup mul sub sqrt
		    /Dist exch store
		    Dist !DistNear lt {
		      % Wow, they're close together:
		      % Let's slow the other one down!
		      pop pop
		      Other begin
			/DX DX !DecaySpeedNear mul def
			/DY DY !DecaySpeedNear mul def
		      end
		    } {
		      atan /Dir exch store
		      Dist DistFar min
		      DistFar div DistGrav mul
		      /DX 1 index Dir cos mul Mag mul DX add store
		      /DY 1 index Dir sin mul Mag mul DY add store
		    } ifelse
		    /Brightness Brightness !StepBrightness add 1 min def
		    /Mag Mag !DecayMag mul store
		  } ifelse
		} forall
		/LastObjects [
		  currentdict LastObjects {
	            counttomark !TraceHistory ge { exit } if
		  } forall
		] store
	      end
	    end
	    TracedObjects {
	      begin
	        /X X DX add !FieldWidth add !FieldWidth mod def
	        /Y Y DY add !FieldHeight add !FieldHeight mod def
	        /DX DX !Friction mul def
	        /DY DY !Friction mul def
	        /Brightness Brightness !DecayBrightness mul def
	        Y X Brightness Saturation Hue Point Str
		((%) % % % % % % F\n) sprintf trace-print
	      end
	    } forall
	    null % for pop
	  } ifelse
      } def
    } meta-exec
    exec
    (grestore showpage\n) trace-print trace-flush
  } iexec
} def



/iexec-printexec { % index => -
  ExecStack 1 index get
  dup type /dicttype eq {
    dup /namestring known {
      begin namestring end
    } if
  } if
  exch (% %\n) printf
} def

/iexec-where {
  0 1 ExecSP {
    iexec-printexec
  } for
} def

% execute step by step on the cyberspace deck stack display.
% To step, execute 'exit'. (make an 'exit' button to step with the mouse).

/cexec {
  { { /TraceStep {
	ExecSP
	iexec-printexec
	select-object
	/ThisStep ThisStep 1 add def
	ThisStep Steps ge {
          /ThisStep 0 def
  	  _SendUpdateStack
	  eventloop
	} if
	null
      } def
      /Steps 1 def
      /ThisStep 0 def
    } meta-exec
    exec
  } iexec
} def

/iexec-step { % operand stack ... execee
} def

/iexec-sends { % - => context0 context1 ... contextn
  ExecSP 1 sub -1 0 {
    ExecStack exch get % ob
    dup type /dicttype eq {
      dup /continuation known {
	dup /continuation get /send eq {
	  /context get
	  dup null eq { pop } if
	} { pop } ifelse
      } { pop } ifelse
    } { pop } ifelse
  } for
} def

% Re-enter the NeWS PS interpreter, execute object, and return.
% We need to construct the currentprocess's /SendStack from the interpreter's
% send stack, so ThisWindow and other functions that look at the SendStack
% will work.
/iexec-reenter { % obj => ...
  mark
  /ParentDictArray where pop
  iexec-sends % obj mark context0 context1 ... contextn
  { { % obj mark context0 context1 ... contextn {func}
      1 index mark eq { % obj mark {func}
        pop pop % obj
	{exec} stopped % ... bool
      } { % obj mark context0 context1 ... contextn {func}
        dup 3 -1 roll send % ...
      } ifelse
    } dup exec
  } MumbleFrotz
  ?iexec-handle-error
} def

iexec-array-like-types begin
  /arraytype true def
  /packedarraytype true def
end % iexec-array-like-types

/iexec-token { % token => ...
  dup xcheck {
    % This is the "weird" thing about PostScript:
    % If object is isn't an executable array, execute it, else push it.
    //iexec-array-like-types 1 index type known not { PushExec } if
  } if
} def

iexec-types begin

  /nametype { % name => ...
    pause
    iexec-continue-names? {
      % We push a dummy name continuation on the exec stack here to
      % help with debugging, by making stack dumps more informative...
      10 dict begin
	/continuation /name def
	/continue { % dict
	  pop
	} def
	/name 1 index def
	/namestring { 
	  /name load cvlit (name: % *done*) sprintf 
	} def
	currentdict cvx PushExec
      end
    } if
    //iexec-names 1 index known { % name
      //iexec-names exch get % func
      exec %
    } {
      % name
      {{load}stopped} MumbleFrotz {
        true ?iexec-handle-error
      } {
        PushExec
      } ifelse
    } ifelse
  } def

  /arraytype { % array => ...
    iexec-continue-procs? {
      10 dict begin
        /continuation /procedure def
	/proc exch def
	/i 0 def
	/len /proc load length def
	/continue { % dict => -
	  begin
	    i len lt {
	      currentdict cvx PushExec
	      /proc load i get iexec-token
	      /i i 1 add def
	    } if
          end
	} def
	/namestring {
	  (procedure % @ %: %)
	  [ /proc load i 
	    1 index length 1 index gt { 2 copy get } (*done*) ifelse
	  ] sprintf
	} def
	currentdict cvx PushExec
      end
    } {
      dup length dup 0 eq { % array length
	pop pop %
      } { % array length
	1 eq { % array
	  0 get %
	  iexec-token %
	} { % array
	  dup 0 get % array head
	  % push rest of array to execute later
	  exch 1 1 index length 1 sub getinterval % head tail
	  PushExec % head
	  iexec-token %
	} ifelse
      } ifelse
    } ifelse
  } def

  /packedarraytype /arraytype load def

  /stringtype { % string => ...
    dup token { % string rest token
      exch dup length 0 eq { pop } { PushExec } ifelse % string token
      exch pop % token
      iexec-token % ...
    } { % str
      dup length 0 eq {
        pop %
      } { % str
        /syntax signal-error
      } ifelse
    } ifelse
  } def

  /filetype { % file => -
    dup token { % file token
      exch dup % token file file
      status { PushExec } { pop } ifelse % token
      iexec-token % ...
    } { % file
      dup status {
        /syntax signal-error
      } {
	pop
      } ifelse
    } ifelse
  } def

  /operatortype { % operator => -
    //iexec-operators 1 index known {
      //iexec-operators exch get exec
    } {
      {{exec}stopped}
      MumbleFrotz
      ?iexec-handle-error
    } ifelse
  } def

  /dicttype { % dict => -
    dup /continuation known {
      dup /continue get exec
    } if
  } def

end % iexec-types

iexec-operators begin

  /exec load { % obj => -
    PushExec
  } def
  
  /if load { % bool proc => -
    exch {
      PushExec
    } {
      pop
    } ifelse
  } def

  /ifelse load { % bool trueproc falseproc
    3 -1 roll { exch } if % wrongproc rightproc
    PushExec pop
  } def

  iexec-single-forall-types begin
    {/arraytype /packedarraytype /stringtype}
    {true def} forall
  end % iexec-single-forall-types

  /forall load { % obj proc => -
    10 dict begin
      /continuation /forall def
      /proc exch def
      /obj exch cvlit def
      /i 0 def
      //iexec-single-forall-types obj type known {
	/continue { % dict => -
	  begin
	    i obj length lt {
	      currentdict cvx PushExec
	      obj i get
	      /proc load PushExec
	      /i i 1 add def
	    } if
	  end
	} def
	/namestring {
	  (forall: proc=% obj=% @ %: %)
	  [ /proc load  /obj load  i 
	    1 index length 1 index gt { 2 copy get } (*done*) ifelse
          ] sprintf
	} def
      } {
	/keys [
	  obj {pop} forall
	] def
	/continue { % dict => -
	  begin
	    i obj length lt {
	      currentdict cvx PushExec
	      keys i get % key
	      obj 1 index get % key val
	      /proc load PushExec
	      /i i 1 add def
	    } if
	  end
	} def
	/namestring {
	  (forall: proc=% obj=% @ %: %)
	  [ /proc load  /obj load  
	    keys i
	    1 index length 1 index gt { 
	      get 2 copy get
	    } {
	      pop null (*done*)
	    } ifelse
	  ] sprintf
	} def
      } ifelse
      currentdict cvx PushExec
    end
  } def

  /for load { % first step last proc
    10 dict begin
      /continuation /for def
      /proc exch def
      /last exch def
      /step exch def
      /first exch def
      /i first def
      /continue { % dict => -
        begin
	  i last step 0 gt {le} {ge} ifelse {
	    currentdict cvx PushExec
	    i
	    /proc load PushExec
	    /i i step add def
	  } if
	end
      } def
      /namestring {
	(for: proc=% first=% step=% last=% i=%)
	[/proc load  first step last i] sprintf
      } def
      currentdict cvx PushExec
    end
  } def

  /repeat load {
    10 dict begin
      /continuation /repeat def
      /proc exch def
      /times exch def
      /i 0 def
      /continue { % dict => -
        begin
	  i times lt {
	    currentdict cvx PushExec
	    /proc load PushExec
	    /i i 1 add def
	  } if
	end
      } def
      /namestring {
	(repeat: proc=% times=% i=%)
	[/proc load times i] sprintf
      } def
      currentdict cvx PushExec
    end
  } def

  /loop load {
    10 dict begin
      /continuation /loop def
      /proc exch def
      /continue { % dict => -
        begin
	  currentdict cvx PushExec
	  /proc load PushExec
	end
      } def
      /namestring {
        /proc load (loop: proc=%) sprintf
      } def
      currentdict cvx PushExec
    end
  } def

  /pathforallvec load {
%...
  } def

  iexec-exit-stoppers begin
    {/forall /for /repeat /loop /pathforallvec}
    {true def} forall
  end % iexec-exit-stoppers

  /exit load {
    { ExecSP 0 lt { % exit out of interpreter?
	true exit
      } {
        PopExec % obj
	dup dup xcheck exch type /dicttype eq and { % obj
	  dup /continuation known {
	    dup /continuation get iexec-exit-stoppers exch known {
		pop false exit
	      } {
	        pop
	      } ifelse
	  } {
	    pop
	  } ifelse
	} { % obj
	  pop
	} ifelse
      } ifelse
    } loop

    { {exit} exit } if
  } def

  /stop load {
    { ExecSP 0 lt { % stop out of interpreter?
	true exit
      } {
        PopExec % obj
	dup dup xcheck exch type /dicttype eq and { % obj
	  dup /continuation known {
	    dup /continuation get /stopped eq {
	      pop true false exit
	    } {
	      pop
	    } ifelse
	  } {
	    pop
	  } ifelse
	} { % obj
	  pop
	} ifelse
      } ifelse
    } loop

    { {stop} exit } if
  } def

  /stopped load { % proc
    10 dict begin
      /continuation /stopped def
      /continue { % dict => -
	pop false
      } def
      /proc 1 index def % debugging
      /namestring {
	/proc load (stopped: proc=%) sprintf
      } def
      currentdict cvx PushExec
      PushExec
    end
  } def

  /send load { % <args> message object => <results>
    { currentdict } MumbleFrotz % message object context
    2 copy eq { % message object context
      pop pop cvx PushExec
    } { % message object context
      10 dict begin
	/continuation /send def
	/context
	  exch dup /ParentDictArray known not { pop null } if
	def % message object
        /object exch def % message
	/message 1 index def % message
	/continue { % cdict => -
          { % cdict
	    ParentDictArray dup type /arraytype ne { % X11/NeWS
	      /ParentDictArray get length 1 add
	    } {
	      length
	    } ifelse
            1 add {end} repeat
	    /context get % context
	    dup null eq { % context
	      pop %
	    } { % idict context
	      dup /ParentDictArray get {begin} forall begin %
	    } ifelse %
	  } MumbleFrotz
	} def
	/unwind /continue load def
        /namestring {
	  (send: message=% object=% context=%)
	  [/message load object context] sprintf
        } def
	currentdict cvx PushExec
        object context % message object context
      end % of cdict
      { null ne {
	  ParentDictArray length 1 add {end} repeat
	} if
        dup /ParentDictArray get
        dup type /arraytype ne { % X11/NeWS
          dup /ParentDictArray get
	  {begin} forall begin begin % message
        } {
	  {begin} forall begin % message
        } ifelse
      } MumbleFrotz % message
      cvx PushExec %
    } ifelse
  } def
  
% supersend (operator in X11/NeWS, proc in 1.1?)

  /currentfile load { % => file
    null
    ExecStack length 1 sub -1 0 {
      ExecStack exch get % obj
      dup type /filetype eq {
	exit
      } {
        pop
      } ifelse
    } for
    dup null eq {
      pop currentfile
    } {
      exch pop
    } ifelse
  } def

  % We have to have the send contexts set up right when we do a fork, since
  % the child process inherits them. (i.e. so ThisWindow works)
  /fork load {
    {fork} iexec-reenter
  } def

  /countexecstack load {
    /countexecstack dbgbreak
  } def

  /quit load {
    /quit dbgbreak
  } def

end % iexec-operators

iexec-names begin

  /sendstack {
    [ iexec-sends
      currentprocess /SendContexts get aload pop
    ]
  } def

  /iexecing? true def

  % meta-exec is a hook back up to the interpreter context.
  /meta-exec {
    exec
  } def

  /append {
    {{append} stopped} MumbleFrotz
    ?iexec-handle-error
  } def

  /sprintf {
    {{sprintf} stopped} MumbleFrotz
    ?iexec-handle-error
  } def

% execstack

end % iexec-names

/iexec-trace-changes {
  iexec-operators begin
    /def load {(/% % def\n) [3 index 3 index] dbgprintf def } def
    /store load {(/% % store\n) [3 index 3 index]dbgprintf store} def
    /put load {(% /% % put\n) [4 index 4 index 4 index]dbgprintf put} def
  end
} def

end % systemdict