------------------------->  GNU Sather - sourcefile  <-------------------------
-- Copyright (C) 1995 by International Computer Science Institute            --
-- This file is part of the GNU Sather library. It is free software; you may --
-- redistribute  and/or modify it under the terms of the GNU Library General --
-- Public  License (LGPL)  as published  by the  Free  Software  Foundation; --
-- either version 2 of the license, or (at your option) any later version.   --
-- This  library  is distributed  in the  hope that it will  be  useful, but --
-- WITHOUT ANY WARRANTY without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See Doc/LGPL for more details.       --
-- The license text is also available from:  Free Software Foundation, Inc., --
-- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA                     --
-------------->  Please email comments to <bug-sather@gnu.org>  <--------------

-- pog.sa: Module for displaying printed graphics
-- Author: Benedict A. Gomes <gomes@samosa.ICSI.Berkeley.EDU>

--  POG INTERFACE to C functions
-------------------------------------------------------------------
-- Each structure has a unique GID
-- It consists of a title, followed by each of the attributes (elements)
-- The title and elements each have the following fields
--      GID [30]
--      C1  (title/name)
--      C2  (value)
--      Type
--      Color
--      S1, S2, S3, S4, S5  (for additional information)
-- An element is specified as a string with null characters between
-- fields.
--      Proposed Type field values (not yet used)
--      (V - value |R - reference |VB value builtin|RB ref builtin |
--            A - abstract|B bound routine | E external)
-- 
-- For the element used to describe the title:
--    C2 (value) represents a requested window width (a string repn of an INT)
--    S1 represents a requested initial X location and 
--    S2 represents a requested initial Y location
--   with (0,0) being the upper left corner
--    Both locations are specified as strings which must be readable as FLTs

-- Arrays of INTs, CHARs,BOOL,FLT,FLTD may return multiple values per line.
------------------------------------------------------------------
-- The current program structure consists of:
-- POG shared class which  is basically the interface to the outside
--     world and to C_POG.
--     It maintains a single "controller" POG_CONTROL which holds all
--     the components of a single display. Multiple displays should
--     be possible, but have not been explored
-- POG_CONTROL holds all the subwidgets of the main widget.
--     A canvas for the graphical view
--     A text widget for the element view.
--     It has a list of POG_STRUCT_VIEWs which have pointers to POG_STRUCTs
--     and is responsible for creating, destroygin and
--     controlling the various POG_STRUCT_VIEWs
-- POG_STRUCT describes  a single "structure" and may be created from a
--     long string with null terminators between fields. It has the title
--     information as well as a list of attributes, all of which are
--     POG_STRUCT_ELT
-- POG_STRUCT_ELT holds the title and other information about elements
--     in the struct. It is interpreted specially in the case of the title
--     The value field is used to represent the width of the window
--     and s1 and s2 are used to represent a suggested x,y location
-- POG_STRUCT_VIEWs are text widget embedded in the canvas widget that
--     display the struct and their contained elements
-- POG_ELT_VIEW is a single text widget held by the POG_CONTRL that
--     displays the details of the currently selected POG_STRUCT_ELT
-- It's a very string based, weakly typed interface and works well
-- in practice.
------------------------------------------------------------------
external class C_POG is
   -- External interface to the debugger

   -- -------------- INTERFACE FROM C TO SATHER ------------
   -- The debugger must first call init to start up the gui
   init is POG::init end;

   -- Then call show to display a particular object id
   show(cid: EXT_OB) is 
      id:STR;
      SYS::inlined_C("#id=(STR)#cid;");
      POG::show(id); 
   end;
   
   -- Then call run to allow user input
   run is POG::run; end;
   
   -- -------------- INTERFACE FROM SATHER TO C -------------
   -- Interface to the debugger
   C_POG_cget(id:EXT_OB): EXT_OB;
   -- Return a string that describes the object with id "id"
end;
-------------------------------------------------------------------
class POG is
   -- Test out the interface
   shared control: POG_CONTROL;
   private shared run_gui: BOOL := true;
   
   -- Statement of interface to strings of fields
   const n_total_fields: INT := 10;
   const n_extra_fields: INT := 5;
   const GID_index: INT := 0;
   const name_index: INT := 1;
   const value_index: INT := 2;
   const object_type_index: INT := 3;
   const color_index: INT := 4;
   const name_color: STR := "firebrick1";
   const value_color: STR := "firebrick1";
   -- Colors of successive fields
   const field_colors: ARRAY{STR} := |"royalblue4","royalblue3","blue4",
				      "slateblue4","royalblue4"|;


   init is
      if void(control) then
	 GUI_APP_END::startup(true,false);
	 control := #POG_CONTROL("c");
      end;
   end;
   
   show(s: STR) is
      run_gui := true;
      if void(control) then 
	 #ERR+"POG was not properly initialized\n";
	 return;
      end;
      control.add_struct(s);
   end;
   
   hide(id: STR) is 
      if void(control) then 
	 #ERR+"POG was not properly initialized\n";
	 return;
      end;
      control.hide(id);
   end;

      
   run is
      bc ::= #TK_BUTTON_CFG;
      if ~void(control) then
	 #OUT+"Running Gui. Hit the Resume button to return to gdb\n";
	 bc.normal;
	 control.resume_button.configure(bc);
      end;
      loop 
	 while!(run_gui);
	 -- Run until a callback is called to terminate the run
	 GUI_APP_END::blocking_poll; 
	 while!(run_gui);	-- In case the last callback 
	 --  required termination
      end;      
      if ~void(control) then
	 bc.disable;
	 control.resume_button.configure(bc);
      end;
   end;

   stop_gui is run_gui := false; end;

end;
-------------------------------------------------------------------
class POG_CONTROL is
   -- Top level controller of the datastructure visualization gadget.
   -- Holds the canvases as well as a list of POG_STRUCT_VIEWs
   -- which describe the elements currently visible
   include GUI_UTIL
	 main->, init->;	-- get rid of the defualt interface
    
   readonly attr canvas: TK_CANVAS; -- Canvas widget that displays the items

   readonly attr elt_view: POG_ELT_VIEW; -- Widget used to describe a
   -- single widget element
   
   readonly attr button_frame: TK_FRAME; -- Frame holding the buttons
   readonly attr quit_button: TK_BUTTON; -- Quit button
   readonly attr resume_button: TK_BUTTON; -- Restart gdb button
   readonly attr refresh_button: TK_BUTTON; -- Redisplay all visible structs
   readonly attr name: STR;
   readonly attr struct_views: FW_LIST{POG_STRUCT_VIEW};
   readonly attr arrow_tag:TK_CANVAS_TAG;
   readonly attr text_win_tag: TK_CANVAS_TAG;
   readonly attr text_title_tag: TK_CANVAS_TAG;
   private shared debug: BOOL := false;
    

   -- Test version
   --    get_object(id: STR): STR is   return TEST_POG::get(id);  end;
    
   -- Real version
   get_object(id:STR):STR is
      ret:STR;
      SYS::inlined_C("#ret=(STR)C_POG_cget((void *)#id);");
      return ret;
   end;

   create(nm: STR): SAME is return new.init(nm) end;
    
   describe_element(e: POG_STRUCT_ELT) is
      -- Describe the element given by "e" in an appropriate manner
      elt_view.show(e);
   end;
    
   init(nm: STR): SAME is
      name := nm;
      arrow_tag := #TK_CANVAS_TAG;
      text_win_tag := #TK_CANVAS_TAG;
      text_title_tag := #TK_CANVAS_TAG;
      struct_views := #;
      -- Canvas widget
      canvas := #TK_CANVAS(root_window,"canvas",
			   TK_CANVAS_CFG::std
			   .scroll_region(0.0,0.0,2000.0,2000.0)
			   .height(500.0).width(1000.0)
			   .background("wheat")
			   .confine(false),
			   TK_PACK::top_grow_horiz_n_vert);
	
      -- Buttons
      button_frame ::= #TK_FRAME(root_window,"buttonFrame", 
				 TK_FRAME_CFG::std,TK_PACK::left);
	
      quit_button := #TK_BUTTON(button_frame,"quit",
				TK_BUTTON_CFG::std.text("Quit").width(20.0),
				TK_PACK::bot);
      quit_button.command(bind(quit_button_cb));
      resume_button:=#TK_BUTTON(button_frame,"resume",
				TK_BUTTON_CFG::std.text("Resume gdb")
				.width(20.0),
				TK_PACK::bot);
      resume_button.command(bind(resume_button_cb));
	
      refresh_button:=#TK_BUTTON(button_frame,"refresh",
				 TK_BUTTON_CFG::std.text("Refresh")
				 .width(20.0),
				 TK_PACK::bot);
      refresh_button.command(bind(refresh_button_cb));
	
      -- Text element description widget
      td_config ::= TK_TEXT_CFG::std
	    .char_height(7).char_width(30).font("8x13bold")
	    .foreground("black").background("ivory")
	    .selectborderwidth(0.0).no_wrap;
      elt_descr_widget ::= #TK_TEXT(TK_TOPLEVEL::root_window,"eltView",
				    td_config, TK_PACK::bot_grow_horiz);
      elt_descr_widget.frame.configure(TK_FRAME_CFG::std.relief_flat);
      elt_view := #POG_ELT_VIEW(elt_descr_widget);
	
      return self;
   end;
    
   hide(id: STR) is
      -- Make the struct invisible
      loop s: POG_STRUCT_VIEW := struct_views.elt!;
	 if s.struct.id = id then
	    if s.struct.view.is_visible then
	       s.struct.view.is_visible := false;
	       s.make_invisible; 
	       make_arrows_invisible(s.struct); 
	    end;
	 end;
      end;
   end;
    
   user_hid(id: STR) is
      -- Called by a POG_STRUCT_VIEW whenever the user clicks to
      -- hide it. This function should callback into Claudio's
      -- code, at some point
      -- This currently calls TEST_POG, but will eventually call
      -- the appropriate function in POG, when a non-dummy
      -- #OUT+"User hid:"+id+"\n";
   end;
   
   add_struct(id: STR) is
      -- Add the structure specified by the string "s" to the current
      -- control. Get the structure specification from gdb
      s::=get_object(id);
      if void(s) then return; end;
      ps ::= #POG_STRUCT(s);
      xp ::= flt_if_poss(ps.title_info.fields[0],0.0);
      yp ::= flt_if_poss(ps.title_info.fields[1],0.0);
      add_struct(ps,true,xp,yp);
   end;

   view_attribute(el: POG_STRUCT_ELT,atx,aty: FLT) is
      -- Called by a POG_STRUCT_VIEW to make an attribute visible
      -- View the object identified by "id". May require the creation
      -- of a new struct
      if debug then deb("Viewing attribute:"+el.str); end;
      if el.id  = "ignore" then 
	 if debug then deb("Ignoring"); end;
	 return 
      end;
      if ~void(el.dest) then
	 if el.dest.view.is_visible then 
	    if debug then deb("Destination present and visible") end;
	    return 
	 else 
	    if debug then deb("Destination present. Making it visible") end;
	    -- s ::= get_struct_from_debug(id);
	    s ::= get_object(el.id);
	    if void(s) then return; end;
	    struct ::= #POG_STRUCT(s);
	    add_struct(struct,true,atx,aty);
	    -- make_visible(el.dest) 
	 end;
      else
	 -- Destination is void
	 id ::= el.id;
	 if debug then deb("Getting the destination:"+id); end;
	 -- s ::= get_struct_from_debug(id);
	 s ::= get_object(id);
	 if void(s) then return; end;
	 if debug then deb("got back struct"); end;
	 struct ::= #POG_STRUCT(s);
	 add_struct(struct,true,atx,aty);
      end;
   end;

   add_edges_concerning(d: POG_STRUCT) is
      -- Go through all the other structs and see if there are
      -- any outstanding pointers (ids) that can now be resolved
      -- Add all edges pointing to/from the new node "d"
      new_id: STR := d.id;
      loop sv ::= struct_views.elt!;
	 -- Loop over existing views as sources
	 src: POG_STRUCT := sv.struct;
	 -- Go through each element of the source and see if it points to "d"
	 add_outgoing_edges(src,d);
	 add_outgoing_edges(d,src);
      end;
   end;

   make_arrows_invisible(c: POG_STRUCT) is
      -- Called either by add_struct when replacing an old version
      -- or by POG_STRUCT_VIEW when making itself invisible
      -- Delete all edges going to "c" and mark "c" as invisible
      c.view.is_visible := false;
      delete_outgoing_arrows(c);
      delete_incoming_arrows(c);
      loop src : POG_STRUCT := c.sources.elt!;
	 delete_outgoing_arrows(src);
	 draw_outgoing_arrows(src);
      end;
   end;

   redraw_arrows_into_and_outof(s: POG_STRUCT) is
      -- Called internally and also by POG_STRUCT_VIEW after a move
      -- takes place
      -- Redraw arrows associated with "s", when visibility changes
      -- First redraw all parent to "o" arrows
      delete_outgoing_arrows(s);
      if debug then deb("Deleting outgoing arrows for:"+s.id); end;
      loop src: POG_STRUCT := s.sources.elt!;
	 delete_outgoing_arrows(src);
	 draw_outgoing_arrows(src);
      end;
      draw_outgoing_arrows(s);
   end;

   private flt_if_poss(s: STR,default: FLT): FLT is
      c ::= #STR_CURSOR(s);
      res ::= c.get_flt;
      if c.has_error then return default  else return res end;
   end;

   private add_struct(d: POG_STRUCT,use_loc_hint: BOOL,x,y:FLT) is
      -- All new structs come through here.
      -- Add the structure specified by "d" to the current
      -- control. Update all relevant pointers to the new struct and
      -- create a new POG_STRUCT_VIEW if necessary
      deb("struct:"+d.str);
      id ::= d.id;
      loop s:POG_STRUCT_VIEW := struct_views.elt!;
	 if s.struct.id = id then 
	    -- Just update the view of that struct
	    -- Reset all outgoing edges from this struct
	    d.set_view := s;
	    s.reset_struct(d);
	    -- Delete the old view of the struct
	    -- Reset the struct and then draw a new view
	    if s.is_visible then
	       s.make_invisible; 
	       make_arrows_invisible(s.struct); 
	    end;
	    add_edges_concerning(d);
	    s.draw;
	    redraw_arrows_into_and_outof(d);
	    return;		-- --------------------------->>>
	 end;
      end;
      -- Only execute this if no matching view was found
      dv: POG_STRUCT_VIEW := #(self,d);
      d.set_view(dv);
      if use_loc_hint then
	 dv.x := x; dv.y := y;
      end;
      struct_views.append(dv);
      dv.is_visible := true;
      dv.draw;
      add_edges_concerning(d);
      redraw_arrows_into_and_outof(d);
      canvas.raise_tag(text_title_tag,text_win_tag);
   end;

   
   private add_outgoing_edges(src: POG_STRUCT,dest: POG_STRUCT) is
      -- Add any relevant pointers from the fields of "src" to
      -- the "dest" structure
      src_attribs ::= src.attribs;
      loop j ::= src_attribs.size.times!;
	 src_attrib ::= src_attribs[j]; 
	 if src_attrib.id = dest.id then
	    -- If the id of some field of "src" is the same as the dest id 
	    -- we are looking at, then fix the new pointer
	    src.set_dest(j,dest);
	    dest.add_source(src);
	 end;
      end;
   end;
   
   private quit_button_cb is
      -- Callback to quit the gui
      #ERR+"Terminating gui\n";
      GUI_APP_END::terminate;
      UNIX::exit(0);
   end;
   
   private resume_button_cb is
      -- Resume the debugger, suspending gui interaction
      if debug then deb("Should resume debugging"); end;
      #OUT+"Resuming gdb operation\n";
      #OUT+"p PFG(&FF),p PTG(&FF)  or p POG(var) restarts the gui\n";
      POG::stop_gui;
   end;
   
   private refresh_button_cb is
      -- Refresh all visible structs
      #OUT+"Refreshing displayed objects\n";
      loop v ::= struct_views.elt!;
	 if v.is_visible then    refresh(v); end;
      end;
   end;
   
   private refresh(s: POG_STRUCT_VIEW) is
      -- Get the data afresh from the program
      add_struct(s.struct.id);
   end;
   
   private make_visible(el: POG_STRUCT) is
      -- Called by view_attribute
      -- The structure exists but is not visible; Find the appropriate
      -- POG_STRUCT_VIEW and redisplay it.
      el.view.is_visible := true;
      loop sv ::= struct_views.elt!;
	 if sv.struct.id = el.id then
	    sv.draw;
	    break!;
	 end;
      end;
      redraw_arrows_into_and_outof(el);
   end;
   

   describe: STR is
      res ::= "================================================\n";
      res := res+"Description:\n";
      loop  res := res+struct_views.elt!.struct.str+"\n";   end;
      res := res+"================================================\n";
      return res;
   end;

   private delete_outgoing_arrows(d: POG_STRUCT) is
      canvas.delete(d.view.outgoing_arrow_tag);
   end;
   
   private delete_incoming_arrows(d: POG_STRUCT) is
      canvas.delete(d.view.incoming_arrow_tag);
   end;
   
   private draw_outgoing_arrows(d: POG_STRUCT) is
      -- Redraw all the arrows coming out of a given pog_struct
      loop i ::= d.attribs.size.times!;
	 elt: POG_STRUCT_ELT := d.attribs[i];
	 draw_arrow(d,i,elt);
      end;
   end;
   
   private draw_arrow(s: POG_STRUCT,i: INT,elt: POG_STRUCT_ELT) is
      -- Draw the arrow from "i" elements down the view of "s", representing
      -- an arrow from element "elt" to its destination, if it is visible
      -- Note that "elt" may not be the "i"th attribute of "s"
      
      -- old: elt: POG_STRUCT_ELT := s.attribs[i];	-- Source element
      if ~s.view.is_visible then return end;
      dest: POG_STRUCT := elt.dest;
      lc ::= TK_LINE_CFG::std.fill(elt.color);
      at:ARRAY{TK_CANVAS_TAG} := |arrow_tag,s.view.outgoing_arrow_tag|;
      line_height ::= POG_STRUCT_VIEW::line_height;
      y_offset ::= POG_STRUCT_VIEW::y_offset;

      ysrc_top ::= s.view.y;  
      yloc ::= ysrc_top+y_offset+i.flt*line_height;
      if void(dest) or ~dest.view.is_visible then 
	 -- If destination is not visible draw a stub arrow if it could be
	 if ~(elt.id = "ignore") then
	    canvas.draw_line(s.view.x,yloc,s.view.x-10.0,yloc,at,lc);	 
	 end;
	 return;
      end;
      at :=
	    |arrow_tag,dest.view.incoming_arrow_tag,s.view.outgoing_arrow_tag|;
      src_width  ::= s.view.x_width+ 14.0;
      dest_width ::= dest.view.x_width + 14.0;
      
      xsrc_left ::= s.view.x;          
      xdest_left ::= dest.view.x;      
      xsrc_right ::= xsrc_left+src_width;
      xdest_right ::= xdest_left+dest_width;

      -- xf1,yf1 to xf2,yf2 (straight part of line)
      -- xf2,yf2 to xf3,yf3 (angled part of line)
      xf1, xf2,xf3,yf1,yf2,yf3: FLT;
      if xsrc_left < xdest_left then -- Left to right
	 xf1 := xsrc_right; xf2 := xf1+10.0;
	 if xsrc_right > xdest_left then   xf3 := xdest_right;
	 else  xf3 := xdest_left; end;
	 -- xf1 := xsrc_right;    xf2 := xf1+10.0;  xf3 := xdest_left;
      else			-- Right to left
	 xf1 := xsrc_left;    xf2 := xf1-10.0; 
	 if xsrc_left < xdest_right then xf3 := xdest_left;
	 else xf3 := xdest_right; end;
	 -- xf3 := xdest_right;
      end;
      ydest_title_top ::= dest.view.y;  
      yf1 := yloc;
      yf2 := yf1;
      ydest_boxtop ::= ydest_title_top+y_offset;
      ydest_bottom ::= ydest_boxtop+dest.attribs.size.flt*line_height;
      -- 0,0 is upper left
      if yf1 > ydest_bottom then -- Bottom to top arrow
	 yf3 := ydest_bottom;
      else			-- Top to bottom
	 yf3 := ydest_title_top;
      end;
      canvas.draw_line(xf1,yf1,xf2,yf2,at,lc);
      lc.arrow(false,true);
      canvas.draw_line(xf2,yf2,xf3,yf3,at,lc);
   end;
   
   private deb(msg: STR) is
      if debug then #ERR+"Control:"+msg+"\n"; end;
   end;
   
end;
-------------------------------------------------------------------
class POG_STRUCT_VIEW is
   -- Structure associated with the display of a single "struct".
   -- It consists of a text window displayed on a canvas widget
   -- in addition to a bit of text for the title.
   -- It has pointers to its "controller" from which it obtains
   -- the canvas and to which it sends callback commands.
    
   readonly attr struct: POG_STRUCT;
   attr is_visible: BOOL;	-- Is the structure currently visible?
   attr x,y: FLT;		-- x,y location of head of struct
   readonly attr incoming_arrow_tag,outgoing_arrow_tag: TK_CANVAS_TAG;
    
   shared y_offset: FLT := 13.0; -- Offset from x,y to actual window
   shared line_height: FLT := 13.0; -- Height of each line
   x_width: FLT is return config_width.flt*8.0 end;
    
   private attr config_width: INT; -- Total number of columns
   private canvas: TK_CANVAS is return controller.canvas; end;
   private attr controller: POG_CONTROL;
   private attr text: TK_TEXT;
   private attr text_win_tag: TK_CANVAS_TAG;
   -- Tag associated with both the title and
   -- the text window of this struct
   private attr text_title_tag: TK_CANVAS_TAG;
   -- Tag associated with the title of this particular struct

   
   create(controller: POG_CONTROL,d:POG_STRUCT): SAME is
      -- Display names and values. Associate ids with return values   
      res: SAME := new;
      res.controller := controller;
      res.struct := d;
      res.config_width := 20;
      res.is_visible := false;
      res.outgoing_arrow_tag := #TK_CANVAS_TAG("outA");
      res.incoming_arrow_tag := #TK_CANVAS_TAG("inA");
      return res;
   end;
    
   reset_struct(s: POG_STRUCT) is
      -- Reset the struct and redraw this struct view
      -- s.x := struct.x; s.y := struct.y;
      struct := s;
   end;
    
   draw pre ~void(self) and ~void(struct) is
      -- Create the actual display at location x,y with the 
      -- indicated attributes "attribs"
      res ::= #TK_TEXT_CFG;
      title : POG_STRUCT_ELT := struct.title_info;
      title_color ::= title.color;
      config_width := int_if_poss(title.val,config_width);
      is_visible := true;
      text_config ::=  TK_TEXT_CFG::std
	    .foreground(title_color).background("ivory")
	    .vscroll(false).hscroll(false)
	    .highlightcolor(title_color)
	    .char_height(struct.attribs.size).char_width(config_width)
	    .font("8x13bold").no_wrap
	    .relief_flat.borderwidth(1.0).selectborderwidth(0.0)
	    .selectbackground("ivory");
      text := #TK_TEXT(canvas.actual_widget,id,text_config,TK_PACK::none);
      text.frame.configure(TK_FRAME_CFG::std
			   .relief_ridge
			   .background(title.color)
			   .highlightcolor(title_color)
			   .borderwidth(2.0)
			   .highlightthickness(2.0));
      if void(text_win_tag) then 
	 text_win_tag := #TK_CANVAS_TAG; text_title_tag := #TK_CANVAS_TAG;
      end;
	
      -- Create the title, (acts like a handle for moving the window)
      rc ::= TK_CTEXT_CFG::std.fill(title.color).font("8x13bold");
      title_tags: ARRAY{TK_CANVAS_TAG} := |text_title_tag,text_win_tag
				     ,controller.text_title_tag|;
      drawx ::= x;
      drawy ::= y-y_offset;
      if drawy <= 1.0 then drawy := 1.0 end;
      canvas.draw_text(title.name,drawx,drawy,title_tags,rc);
	
      --      -- Create collapsing and destroying icons
      --      destroyrc ::= CTEXT_CONFIG::std.fill("green").font("8x13bold");
      --      destroy_tags: ARRAY{CTAG} := |text_title_tag,text_win_tag
      --				  ,controller.text_title_tag,destroy_tag|;
      --      destroyx ::= x+40;
      --      destroyy ::= y-y_offset;
      --      if destroyy <= 1.0 then destroyy := 1.0 end;
      --      canvas.draw_text("*",destroyx,destroyy,destroy_tags,destroyrc);
      
      -- Create the window itself
      win_tags: ARRAY{TK_CANVAS_TAG} := |text_win_tag,controller.text_win_tag|;
      canvas.embed_window(text,drawx,drawy+y_offset,win_tags,
			  TK_CWIND_CFG::std);
      -- Create the elements of the text window
      -- Tag lines with an elt_tag and attach bindings to this elt_tag
      sabs: FW_LIST{POG_STRUCT_ELT} := struct.attribs; -- array of Elements
      elt_config ::= #TK_TEXT_TAG_CFG; 
      loop 
	 i ::= sabs.size.times!;
	 elt_tag ::= #TK_TEXT_TAG;
	 se: POG_STRUCT_ELT := sabs[i];
	 name ::= se.name;
	 -- Insert the name
	 text.insert_tagged(TK_INDEX::at(i+1,0),name,|elt_tag|);
	 -- Insert the value
	 val: STR;
	 if i = (sabs.size - 1) then
	    val:=se.val;
	 else
	    val:=se.val+"\n";
	 end;
	 val := "\t"+val;
	 text.insert_tagged(TK_INDEX::at(i+1,name.size+1),val,|elt_tag|);
	 -- Configure the line
	 elt_config.foreground(se.color);
	 text.configure_tag(elt_tag,elt_config);
	 -- Bind button1 to selecting (opening) the line
	 -- Bind button3 to displaying info about the line
	 text.bind_event(elt_tag,TK_BUTTON_EVENT::B1,
			 bind(button1_on_attr_cb(se,_)));
	 text.bind_event(elt_tag,TK_BUTTON_EVENT::B3,
			 bind(button3_on_attr_cb(se,_)));
      end;
      -- Disable the text window after writing into it
      text_config.disable;
      text.configure(text_config);
      -- Add a handle to the text widget to use for moving around
      canvas.bind_motion(text_title_tag, -- Trigger for movement
			 text_win_tag, -- Objects to move
			 bind(button2_motion_end_cb(_)),"motion");
      canvas.bind_event(TK_BUTTON_EVENT::B3,text_win_tag,
			bind(button3_on_title_cb(_)));
      canvas.bind_event(TK_BUTTON_EVENT::B1.Double,
			text_win_tag,
			bind(double_button1_on_title_cb(_)));
   end;
    
    
   make_invisible is
      is_visible := false;
      canvas.delete(text_win_tag);
      text.destroy;
   end;
    
   private id: STR is return struct.id end;
    
   -- Callback routines 
   private button3_on_title_cb(cb: TK_EVENT_INFO) is
      -- Describe the whole structure of the current struct
   end;
    
   private button3_on_attr_cb(e: POG_STRUCT_ELT,cb: TK_EVENT_INFO) is
      -- Describe the element "e" of the structure
      controller.describe_element(e);
   end;
    
   private button1_on_attr_cb(item_id: POG_STRUCT_ELT,cb: TK_EVENT_INFO) is
      -- Select a particular attribute from the text canvas
      controller.view_attribute(item_id,x,y+y_offset+14.0+box_height);
   end;
    
   box_height: FLT is
      return struct.attribs.size.flt*line_height;
   end;
    
   private double_button1_on_title_cb(c: TK_EVENT_INFO) is
      -- Hide the current item
      controller.user_hid(struct.id);
      if is_visible then
	 make_invisible;
	 controller.make_arrows_invisible(struct);
      end;
   end;
    
   private button2_motion_end_cb(cb: TK_EVENT_INFO) is
      if cb.has_coordinates then
	 xtemp,ytemp:INT;
	 cb.mouse_coordinates(out xtemp, out ytemp);
	 -- These will usually be the coordinates of the text tag, not
	 -- of the text window. Adjust for the offset of the text window
	 x := xtemp.flt;
	 y := ytemp.flt + y_offset;
      else
	 #ERR+"*******************************************************\n";
	 #ERR+"Could not set the new coordinates. Arrows may be wrong.\n";
	 #ERR+"*******************************************************\n";
      end;
      controller.redraw_arrows_into_and_outof(struct);
   end;
    
   private max_name_value_length: TUP{INT,INT} is
      mn ::= 0; mv ::= 0;
      loop s ::= struct.attribs.elt!;
	 if s.name.size > mn then mn := s.name.size; end;
	 if s.val.size > mv then mv := s.val.size; end;
      end;
      return #TUP{INT,INT}(mn,mv);
   end;
    
   private int_if_poss(s: STR,default: INT): INT is
      c ::= #STR_CURSOR(s);
      res ::= c.int;
      if c.has_error then return default  else return res end;
   end;
    
end;
-------------------------------------------------------------------
class POG_ELT_VIEW is
   -- Widget used to describe a single element of a struct in greater
   -- detail There is only a single textwidget used to view all elts 
   -- i.e. only one instance of this class, though it would be
   -- possible to have more.
   -- This class has no pointer to the element it is viewing.  and the
   -- element has no pointer to it.  The show routine is passed in the
   -- current element, which is used to create the element view.
    
   private attr name_tag: TK_TEXT_TAG;
   private attr value_tag: TK_TEXT_TAG;
   private attr field_tag: ARRAY{TK_TEXT_TAG};
   private attr name_config,value_config:TK_TEXT_TAG_CFG;
   private attr field_config:ARRAY{TK_TEXT_TAG_CFG};
   private attr div_tag: TK_TEXT_TAG; -- Used to mark dividers
   private attr div_config: TK_TEXT_TAG_CFG; -- Used to mark dividers
    
   private attr text_widget: TK_TEXT;
    
   create(tw: TK_TEXT): SAME is
      res ::= new;
      res.text_widget := tw;
      res.init;
      return res;
   end;
    
   private init is
      field_tag := #ARRAY{TK_TEXT_TAG}(n_fields);
      field_config := #ARRAY{TK_TEXT_TAG_CFG}(n_fields);
      name_tag := #TK_TEXT_TAG;
      name_config := #TK_TEXT_TAG_CFG;
      name_config.foreground(POG::name_color);
      name_config.background("ghostwhite");
      value_tag := #TK_TEXT_TAG;
      value_config := #TK_TEXT_TAG_CFG;
      value_config.foreground(POG::value_color);
      value_config.background("ghostwhite");
      div_tag := #TK_TEXT_TAG;
      div_config := #TK_TEXT_TAG_CFG;
      div_config.background("white"); 
      div_config.foreground("black"); 
      loop 
	 i ::= n_fields.times!;
	 field_tag[i] := #TK_TEXT_TAG;
	 field_config[i] := #TK_TEXT_TAG_CFG;
	 field_config[i].foreground(POG::field_colors[i]);
      end;
   end;
    
   show(e: POG_STRUCT_ELT) pre ~void(self) is
      tw ::= text_widget;
      tw.insert_tagged(TK_INDEX::at(1,0),e.name+"\n",|name_tag|);
      tw.insert_tagged(TK_INDEX::at(2,0),e.val+"\n",|value_tag|);
      i ::= 0;
      loop until!(i = n_fields);
	 tw.insert_tagged(TK_INDEX::at(3+i,0),
			  e.fields[i]+"\n",|field_tag[i]|);
	 i := i + 1;
      end;
      -- tw.insert_tagged(TINDEX::at(3+i,0),"\n\n", |div_tag|);
      re_configure;
   end;
    
   private n_fields: INT is return POG::n_extra_fields end;
    
   private re_configure is
      tw ::= text_widget;
      tw.configure_tag(name_tag,name_config);
      tw.configure_tag(value_tag,value_config);
      loop i ::= n_fields.times!;
	 tw.configure_tag(field_tag[i],field_config[i]);
      end;
      tw.configure_tag(div_tag,div_config);
   end;
    
end;
-------------------------------------------------------------------
class POG_STRUCT is
   -- Holds information pertaining to the description of a single 
   -- structure (class object)
   
   readonly attr attribs: FW_LIST{POG_STRUCT_ELT}; -- Do not modify
   readonly attr sources: FW_LIST{POG_STRUCT}; -- Pointers to this node
   readonly attr view: POG_STRUCT_VIEW; -- Pointer to the view and gui info
   attr title_info: POG_STRUCT_ELT; -- Information regarding this particular
   -- object. This is not a full struct element and does not contain
   -- the sather attribute, c attribute and gdb command fields
   private shared debug: BOOL := false;
    
   create(id: STR, title: STR, names,vals,ids: ARRAY{STR}): SAME is
      as ::= #FW_LIST{POG_STRUCT_ELT};
      assert names.size = vals.size and vals.size = ids.size;
      n_names: INT := names.size;
      loop i ::= n_names.times!;
	 as.append(#POG_STRUCT_ELT(names[i],vals[i],ids[i]));
      end;
      title_el ::= #POG_STRUCT_ELT(title,"",id);
      return new.init(title_el,as);
   end;
    
   create(s: STR): SAME is
      -- Break down the string "s" into its constitutents based on
      -- the specified structure
	
      -- First break down the full strings into a list of arrays,
      -- each of which specifies a POG_STRUCT_ELT
      f: FW_LIST{ARRAY{STR}} := convert_str_to_arr(s,POG::n_total_fields);
      sz ::= f.size;
      if f.size < 1 then  err("No title even!");    end;
      title: POG_STRUCT_ELT := #POG_STRUCT_ELT(f[0]);
      attribs: FW_LIST{POG_STRUCT_ELT} := #;
      i ::= 1;  loop until!(i=sz);
	 ds ::= #POG_STRUCT_ELT(f[i]);
	 if debug then deb("Converted to elt:"+ds.str) end;
	 attribs.append(#POG_STRUCT_ELT(f[i]));	 
	 i := i +1;
      end;
      return new.init(title,attribs);
   end;
    
   set_view(v: POG_STRUCT_VIEW) is view := v end;
    
   id: STR is return title_info.id end;
    
   title: STR is return title_info.name end;
    
   private init(title: POG_STRUCT_ELT, a: FW_LIST{POG_STRUCT_ELT}): SAME is
      if debug then deb("Creating struct for title id:"+title.id); end;
      title_info := title;
      attribs := a;
      sources := #;
      return self;
   end;
    
   add_source(s: POG_STRUCT) is
      loop src ::= sources.elt!;
	 if SYS::ob_eq(src,s) then return end;
      end;
      sources.append(s);
   end;
    
   attrib(i: INT): POG_STRUCT_ELT is return attribs[i] end;
    
   set_dest(i: INT,dest: POG_STRUCT) is
      -- Set one of the attributes to point to a particular destination
      -- element
      attribs[i] := attribs[i].set_dest(dest);
   end;
    
   str: STR is 
      res ::= "{"+id+":"+title+" ";
      loop res := res+attribs.elt!.str + "\n"; end;
      res := res + "Sources:\n";
      loop res := res+sources.elt!.id +" "; end;
      res := res + "\n}";
      return res;
   end;
    
   private deb(s: STR) is
      if debug then #ERR+"Debug POG_STRUCT:"+s+"\n";  end;
   end;
    
   private err(s: STR) is
      #ERR+"*************************************************\n";
      #ERR+"POG_STRUCT:"+s+"\n";
      #ERR+"*************************************************\n";
   end;
    
   private convert_str_to_arr(s: STR,n: INT): FW_LIST{ARRAY{STR}} is
      -- Break down the string "s" into a list of arrays of strings.
      -- Each array will contain "n" elements
      res ::= #FW_LIST{ARRAY{STR}};
      deb("STR:"+s.pretty);
      current_fstr ::= #FSTR("");
      current_arr: ARRAY{STR} := #ARRAY{STR}(n);
      current_arr_index: INT := 0;
      sz: INT := s.size;
      i ::= 0;
      loop until!(i = sz);
	 c ::= s[i];
	 if c='\0' then 
	    current_arr[current_arr_index] := current_fstr.str;
	    current_arr_index := current_arr_index+1;
	    if current_arr_index = n then
	       current_arr_index := 0;
	       res.append(current_arr);
	       if debug then deb("Next array:"+parr(current_arr)); end;
	       current_arr := #ARRAY{STR}(n);
	    end;
	    current_fstr := #FSTR("");
	 else  current_fstr := current_fstr+c; end;
	 i := i + 1;
      end;
      return res;
   end;
    
   private parr(a:ARRAY{STR}):STR is
      s:STR:="[";
      loop 
	 s:=s+",".separate!(a.elt!);
      end;
      s:=s+"]";
      return s;
   end;
    
end;
-------------------------------------------------------------------
class POG_STRUCT_ELT is
   -- Info about one element of a struct
    
   -- The main fields that must be set at creation time
   readonly attr name: STR;	-- Sather attribute name
   readonly attr id: STR;	-- GID
   readonly attr val: STR;	-- C pointer or the actual value [max len=100]
    
   -- Other fields that are normally set by the incoming string
   readonly attr object_type: STR; -- Type of the object (ref, value etc)
   readonly attr color: STR;	-- Color of the object
   readonly attr fields: ARRAY{STR};
    
   readonly attr dest: POG_STRUCT; -- May be void if no known destination
   -- or if this is a title elt
    
   create(nm,val,id: STR): SAME is
      res: SAME := new;
      res.name := nm;
      res.val := val;
      res.id := id;
      return res;
   end;
    
   create(s: ARRAY{STR}): SAME pre s.size = POG::n_total_fields is
      -- Crucial interface routine that makes all the assumptions about
      -- order of values
      res: SAME := new;
      if s[0].size = 0 then res.id := "ignore" 
      else     res.id       := s[POG::GID_index]; end;
      res.val         := s[POG::value_index];
      res.name        := s[POG::name_index];
      res.color       := s[POG::color_index];
      if res.color.size = 0 then res.color := "white" end;
      nadd: INT := POG::n_extra_fields;
      res.fields := #ARRAY{STR}(nadd);
      i ::= 5; loop dest ::= nadd.times!;
	 res.fields[dest] := s[i];
	 i := i + 1;
      end;
      return res;
   end;
    
   set_dest(d: POG_STRUCT): SAME is
      -- Indicate that this struct element points to a POG_STRUCT "d"
      -- which may or may not be currently visible
      dest := d; return self;
   end;
    
   str: STR is 
      if void(dest) then return "{"+name+","+val+","+id+"}"; 
      else return "{"+name+","+val+","+id+","+dest.id+"}";  end;
   end;
    
    
   describe: STR is 
      res ::= "\n "+name +" "+val;
      loop res := res+"\n  "+fields.elt!; end;
      return res;
   end;
   
end;
-------------------------------------------------------------------
-- Wrapper classes that "fake" parametrization - trade off less
-- speed for faster, smaller compiles, by avoiding specialization of
-- different parametrizations
-- Note that these class interfaces are perfectly type-safe. They may
-- just be somewhat slower than the specialized versions
class FW_LIST{T} < $ELT{T} is
   -- A slower version of A_LIST that uses an indirection to reduce
   -- the parametrization and hence the amount of generated code.
   -- It should be possible to trivially replace this class with an
   -- A_LIST with no change in functionality
   
   private attr a: FLIST{$OB};
   
   create: SAME is 
      res ::= new;
      res.a := #;
      return res;
   end;
   
   elt!: T is loop yield cast(a.elt!); end; end;

   size: INT is return a.size end;
   
   aget(i: INT): T is return CAST{T}::from(a.aget(i)) end;

   aset(i: INT,val:T) is a[i] := val end;
   
   append(e: T) is a := a.push(e); end;

   str: STR is return a.str end;
   
   private cast(el: $OB): T is return CAST{T}::from(el) end;

end;
------------------------------------------------------------------- 
