%!
% Structured PostScript Data Item
% Don Hopkins

systemdict begin

/StructItem LabeledItem
dictbegin
  /LineGap 30 def
  /ItemFont /Times-Roman findfont def
  /Shrink .8 def
  /Pad 3 def
  /StartPoint 18 def
  /Point StartPoint def
  /x 0 def
  /y 0 def
  /Levels 0 def
  /DL null def
  /ItemFrame 2 def
  /ItemRadius 9 def
  /ItemBorder 9 def
  /ItemButton [PointButton MenuButton] def
dictend
classbegin
  /new { % Container Index notifyproc parentcanvas => instance
%    4 2 roll 2 copy get 1 index (%: %) sprintf % notify parent cont ind label
    4 2 roll dup (%:) sprintf % notify parent cont ind label
    5 1 roll 2 array astore % label notify parent object
    3 1 roll /Right % label object notify parent loc
    3 1 roll % label object loc notify parent
    /new super send begin
       ItemCanvas /Transparent false put
       ItemCanvas /Retained true put
    currentdict end
  } def

  /PaintItem {
    /PaintItem super send
    paint-struct
  } def

  /CalcObj&LabelXY {
    /ObjectX 0 store /ObjectY 0 store
    /LabelX 0 store /LabelY 0 store
    /CalcObj&LabelXY super send
  } def

  /ClientDown {
    CurrentEvent /Name get MenuButton eq {
      show-struct-menu
    } if
  } def

  /ClientUp {
    CurrentEvent /Name get PointButton eq {
      NotifyUser
    } if
    StopItem
  } def

  /StructMenu [ 
      (4) {{/StartPoint 4 def redo-layout} it send}
      (6) {{/StartPoint 6 def redo-layout} it send}
      (8) {{/StartPoint 8 def redo-layout} it send}
      (10) {{/StartPoint 10 def redo-layout} it send}
      (12) {{/StartPoint 12 def redo-layout} it send}
      (14) {{/StartPoint 14 def redo-layout} it send}
      (16) {{/StartPoint 16 def redo-layout} it send}
      (18) {{/StartPoint 18 def redo-layout} it send}
      (20) {{/StartPoint 20 def redo-layout} it send}
      (22) {{/StartPoint 22 def redo-layout} it send}
      (24) {{/StartPoint 24 def redo-layout} it send}
      (26) {{/StartPoint 24 def redo-layout} it send}
    ] /new DefaultMenu send
  def

  /SubStructMenu [
    (Clone) {{ob /Obj get copy-struct} it send}
%    (Open4) {{ob begin 4 grow-substruct end redo-layout} it send}
    (Copy) {{ob /Obj get set-selection} it send}
    (Exec) {{ob /Obj get exec-it ob begin replace-substruct end
	     redo-layout} it send}
    (Paste) {{ob begin C I get-selection replace-substruct end
              redo-layout} it send}
    ] /new DefaultMenu send
  def

  userdict /PState currentstate put
  userdict /PStack [] put
  userdict /Execee null put

  /exec-it { % obj => result
    {
     {userdict begin
        /Execee exch def
        PState setstate
	clear PStack aload pop
	/Execee load cvx exec
	/PState currentstate store
        count array astore /PStack exch store
%	PStack length 0 eq {/Empty} { PStack dup length 1 sub get } ifelse
	/Empty PStack aload pop
      } errored {$error} if
    } fork waitprocess
  } def

    /get-selection { % - => obj
	/PrimarySelection getselection 
	dup null ne {
	  dup /ContentsPostScript known {
	    /ContentsPostScript get
	  } {
	    dup /ContentsAscii known {
	      /ContentsAscii get
	    } if
	  } ifelse
	} if
    } def

    /set-selection { % obj => -
        20 dict begin
	  /ContentsPostScript 1 index def
	  /ContentsAscii exch cvstring def
	  /SelectionObjSize 1 def
	  /SelectionResponder null def
	  /Canvas can def
	  /SelectionHolder itemmgr def
	  currentdict
        end
	/PrimarySelection setselection
    } def

  /show-struct-menu {
    DL null ne {
      ItemBegin
	userdict /it self put
	userdict /ob null put
	ObjectX ObjectY translate
	{ userdict /ob currentdict put }
	CurrentEvent begin XLocation YLocation end
	DL search-struct
	pop pop pop
	userdict /ob get null eq {
	  CurrentEvent /showat StructMenu send
	} {
	  CurrentEvent /showat SubStructMenu send
	} ifelse
      ItemEnd
    } if
  } def

  /reshape { % x y w h
	/ItemHeight exch def /ItemWidth exch def

	ItemWidth 0 eq ItemHeight 0 eq and {
	  /DL null store
	} if
        ensure-DL

        adjust-geometry

	ItemWidth ItemHeight /reshape super send
	gsave ItemCanvas setcanvas ItemFillColor fillcanvas grestore
  } def

  /adjust-geometry {
        LabelSize /LabelHeight exch def /LabelWidth exch def

        AdjustItemSize
	CalcObj&LabelXY
  } def

  /Collection {
    ItemObject 0 get cvlit
  } def

  /Index {
    ItemObject 1 get cvlit
  } def

  /ensure-DL {
    DL null eq {
      Collection Index Levels grow-struct
      /DL exch store
      /ObjectWidth 0 store /ObjectHeight 0 store
    } if
    ObjectWidth 0 eq ObjectHeight 0 eq or { 
	/ItemLabel DL /Obj get type
        init-format
	DL layout-struct
	adjust-geometry
%(Layout W % H %\n)[ObjectWidth ObjectHeight]dbgprintf
    } if
  } def

  /paint-struct {
    gsave
      ensure-DL
      ItemTextColor setcolor
      ObjectX ObjectY translate
      DL draw-struct
    grestore
  } def

  /damage-view {
    gsave
      %ItemParent setcanvas bbox rectpath extenddamage
      paint
    grestore
  } def

  /search-struct { % proc x y dict => proc x y
    begin
      dup Y ge {
        dup Y H add lt {
%          Path setpath
	  newpath X Y W H rectpath
	  2 copy pointinpath {
	    2 index exec
          } {
            Branches null ne {
	      Branches {
		search-struct
	      } forall
	    } if
	  } ifelse
	} if
      } if
    end
  } def

  /click-popup {
    DL null ne {
     {
      gsave
        ItemCanvas setcanvas
 	ObjectX ObjectY translate
	{ gsave
	    framebuffer setcanvas
	    currentcursorlocation [Obj I C (%[%]: %) sprintf] popmsg pop
	  grestore }
        CurrentEvent begin XLocation YLocation end
        DL search-struct
        pop pop pop
      grestore
     } fork pop
    } if
  } def

  /replace-substruct { % obj => -
    C I 3 -1 roll put
    C I 0 grow-struct
    begin
      /Branches Branches
      /C C /I I /L L
      /Obj Obj /Str Str
      /X X /Y Y /W W /H H
    end
    def def def def  def def  def def def  def
  } def

  /grow-substruct { % l => -
    /L exch def
    /forbidden? {pop false} def
    /Branches
      C I L grow-struct
      1 index get def
    currentdict /forbidden? undef
  } def

  /click-open {
    DL null ne {
      gsave
        ItemCanvas setcanvas
 	ObjectX ObjectY translate
	{ L 0 eq {
	    1 grow-substruct
	  } {
	      /L 0 def
	      /Branches null def
	  } ifelse
	  /redo-layout self null pop send
	}
        CurrentEvent begin XLocation YLocation end
        DL search-struct
        pop pop pop
      grestore
    } if
  } def

  /clean-underneath {
    gsave
      ItemParent setcanvas
      bbox rectpath FillColor setcolor fill
    grestore
  } def

  /redo-layout {
    clean-underneath
    init-format DL layout-struct
    adjust-geometry 
    location 10 10 reshape
    damage-view
  } def

  /composite? { % obj => bool
    type {
      /arraytype /dicttype /canvastype
      /processtype /eventtype /fonttype
	{true}
      /Default
	{false}
    } case
  } def

  /forbidden-dict 50 dict def
  forbidden-dict begin
    /Interests null def
    /Process null def
    /BuildChar null def
    /Encoding null def
    /WidthArray null def
    /ParentDictArray null def
    /ParentDict null def
    /TopCanvas null def
    /BottomCanvas null def
    /TopChild null def
    /CanvasAbove null def
    /CanvasBelow null def
    /Parent null def
  end % forbidden-dict

  /forbidden? {
    forbidden-dict exch known
  } def

  /init-format {
    /Point StartPoint def
    /x 0 def
    /y 0 def
    /ObjectWidth 0 def
    /ObjectHeight 0 def
  } def

  /LineHeight {
    currentfont fontheight 1.3 mul
  } def

  /grow-struct { % Container Index Levels => dict
    pause
    20 dict begin
      /L exch def
      cvlit /I exch def cvlit /C exch def
      /Obj C I get cvlit def
      /Str Obj I (%: %) sprintf def
      /X 0 def
      /Y 0 def
      /W 0 def
      /H 0 def
      Obj composite?
      I forbidden? not and
      L 0 gt and {
	/Branches [
	  Obj dup type /arraytype eq {
	    { pop Obj counttomark 1 sub L 1 sub grow-struct }
	  } {
	    { pop Obj exch L 1 sub grow-struct }
	  } ifelse
	  forall
	] def
      } {
	/Branches null def
      } ifelse
    currentdict end
  } def

  /layout-struct { % dict => -
    pause
    begin
      /Font ItemFont Point scalefont def
      Font setfont
      /X x def
      /Y y def
      /W Str stringwidth pop LineGap add def
      Branches null eq {
	/H LineHeight def
      } {
	/x x W add store
	/Point Point Shrink mul store
	Branches {
	  layout-struct
	} forall
	/Point Point Shrink div store
	/x x W sub store
	0
	Branches {
	  /H get add
	} forall
	LineHeight max 1 max /H exch def
      } ifelse
      /y Y H add store
      /ObjectWidth ObjectWidth x W add LineGap sub max store
      /ObjectHeight ObjectHeight y max store
    end
  } def

  /draw-struct { % dict => -
    pause
    begin
      show-obj
      Branches null ne {
	currentpoint LineHeight 2 div add
	Branches {
	  begin
	    2 copy moveto
	    X Pad sub Y lineto
	    Pad 2 mul 0 rlineto
	    stroke
	  end
	} forall
	Branches length 0 ne {
	  Branches dup length 1 sub get begin
	    2 copy moveto
	    X Pad sub Y H add lineto
	    Pad 2 mul 0 rlineto
	    stroke
	  end
	} if
	pop pop
	Branches {
	  draw-struct
	} forall
      } if
    end
  } def

  /show-obj {
     Font dup setfont
     fontdescent
     X Y 
     2 index add
     H LineHeight sub 2 div add
     moveto
     Str show
     neg 0 exch rmoveto
  } def

classend def


% NeWS error handler using the object browser (NeWS1.1)
%
% Jeremy Huxtable
%
% Mon Jul 25 17:36:06 BST 1988

/MyErrorDict dictbegin
    StandardErrorNames { {MyErrorHandler} def } forall
dictend def

/MyErrorHandler {
    % Must be careful with manipulating the stacks here, as otherwise
    % our private stuff will appear in the browser!
    /errordict OldErrorDict store
    pop % Get rid of the "offending command" from stack
    % create a dictionary of useful info. Note that we must get the
    % process' stacks now as otherwise they disappear when the "killprocess"
    % is done.
    currentprocess /DictionaryStack get
    7 dict begin
	/DictionaryStack exch def
	currentprocess /OperandStack get /OperandStack exch def
	/ExecutionStack
	    currentprocess /ExecutionStack get
	    0 1 index length 4 sub getinterval
	def % Remove this error handler from exec stack
	/Interests currentprocess /Interests get def
	/Error $error /errorname get def
	/Executing $error /command get def
	/Process currentprocess def
	currentdict
    end
    /errordict MyErrorDict store
} def

systemdict /Stack known not {
  /Stack 256 array def
  /SP 0 def
  Stack 0 10 dict put
  Stack 0 get begin
    /foo {1{2{3 4 5}6}7} def
    /bar {{{{baz}}}} def
    /yow framebuffer def
    /rm rootmenu def
  end
} if

end % systemdict

/createitems { /items [
  Stack 0 {click-open} can
    /new StructItem send
  20 20 0 0 /reshape 5 index send
] def
} def

/slideitem { % items fillcolor item => -
gsave
    dup 4 1 roll		% item items fillcolor item
    /moveinteractive exch send	% item
grestore
} def

/copy-struct { % obj => -
  /SP items length 1 add store
  Stack SP 3 -1 roll put
  /items [
    items aload pop
    Stack SP {click-open} can
      /new StructItem send
  ] store
  gsave /ClientCanvas win send setcanvas currentcursorlocation grestore
  0 0 /reshape items dup length 1 sub get send
  start-event-mgrs
  items FillColor items dup length 1 sub get slideitem
} def

/layout-all {
  gsave
    items {
	{ /DL null put
	  location 20 20 reshape
	} exch send
    } forall
    /ClientCanvas win send setcanvas
    clippath extenddamage
  grestore
} def

/slidemgr null def
/itemmgr null def

/start-event-mgrs {
% Create event manager to slide around the items.
% Create a bunch of interests to move the items.
% Note we actually create toe call-back proc to have the arguments we need.
% The proc looks like: {items color "thisitem" slideitem}.
% We could also have used the interest's clientdata dict.
    slidemgr null ne {slidemgr killprocess} if
    /slidemgr [
	items { % key item
	    dup /ItemCanvas get	% item can
	    MiddleMouseButton [items FillColor	% item can name [ dict color
	    6 -1 roll /slideitem cvx] cvx	% can name proc
	    DownTransition 			% can name proc action
	    4 -1 roll eventmgrinterest		% interest
	} forall
    ] forkeventmgr store
    itemmgr null ne {itemmgr killprocess} if
    /itemmgr items forkitems store
} def

/main {

% Create and size a window.  The size is chosen to accommodate the
% items we are creating.  Right before we map the window, we ask the
% user to reshape the window.  This is atypical, but gets the items
% positioned the way we want them.

    /FillColor 1 1 1 rgbcolor def

    /win framebuffer /new DefaultWindow send def	% Create a window
    {	/PaintClient {FillColor fillcanvas items paintitems} def
	/FrameLabel (Cyberspace: Structure Plane) def
	/IconImage /galaxy def
        /ClientMenu [
	  (Layout all) { layout-all }
        ] /new DefaultMenu send def
    } win send						% Install my stuff.
    200 200 700 350 /reshape win send			% Shape it.
    /can win /ClientCanvas get def			% Get the window canvas
    can /Transparent false put
    can /Retained true put
    
% Create all the items.
    createitems
    
    
% Now let the user specify the window's size and position.  Then map
% the window.  (See above)  Then activate the items.
%    /ptr /ptr_m framebuffer setstandardcursor

%    /reshapefromuser win send	% Reshape from user.
    /map win send		% Map the window & install window event manager.
    				% (Damage causes PaintClient to be called)
  start-event-mgrs

} def

main