------------------------->  GNU Sather - sourcefile  <-------------------------
-- Copyright (C) 1995 by International Computer Science Institute            --
-- This file is part of the GNU Sather package. It is free software; you may --
-- redistribute  and/or modify it under the terms of the  GNU General Public --
-- License (GPL)  as  published  by the  Free  Software  Foundation;  either --
-- version 2 of the license, or (at your option) any later version.          --
-- This  program  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/GPL 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>  <--------------

-- TkWindow.sa:
-- Author: Matthias Ernst <mernst@desy.de>

abstract class $TK_WINDOW is
   app: TK_APP;			-- the application
   typus: STR;			-- the window type

   name:STR;
   pathname: STR;		-- widget name, full pathname

   show; show_all;		-- recursive versions too
   hide; hide_all;
   visible: BOOL;

   parent: $TK_WINDOW;
   children: FLIST{$TK_WINDOW};
   add_child(c: $TK_WINDOW);

   child(rel_name: STR): $TK_WINDOW; -- the child with pathname relative to self

   bind_command(event_spec, command: STR);
   bind_command(event_spec: STR, cb: $TKKIT_CB, args: ARRAY{STR});
   
   configure(option: STR, val: STR): $TK_WINDOW; -- configure this window
   configure(option: STR, val: STR);
   configuration(option: STR): STR; -- get configuration for option
    
   text(t: STR): $TK_WINDOW; text(t: STR); text: STR;
   width(w: INT): $TK_WINDOW; width(w: INT); width: INT;
   height(h: INT): $TK_WINDOW; height(h: INT); height: INT;
end; -- type $TK_WINDOW
   
-------------------------------------------------------------------

class TK_WINDOW < $TK_WINDOW is
   -- implementation of $TK_WINDOW, to be included
   readonly attr app: TK_APP;
   readonly shared typus: STR;
   
   readonly attr name, pathname: STR;

   private attr mapped: BOOL;
   
   readonly attr parent: $TK_WINDOW;
   readonly attr children: FLIST{$TK_WINDOW};


   visible: BOOL is
      return mapped and parent.visible
   end;

   show_all is
      loop
	 c ::= children.elt!;
	 typecase c
	 when $TK_TOPLEVEL then	-- toplevels must be mapped on their own
	 else c.show_all
	 end;
      end;
      show
   end;
   
   hide_all is
      loop
	 c ::= children.elt!;
	 typecase c
	 when $TK_TOPLEVEL then
	 else c.hide_all
	 end;
      end;
      hide
   end;

   hide is
      raise("Undefined function, hide");
   end;
   
   show is
      raise("Undefined function, show");
   end;
   
   add_child(c: $TK_WINDOW) is	-- will only be called by child's create
      children := children.push(c);
      app.add_window(c)
   end;

   child(rel_name: STR): $TK_WINDOW is -- e.g. print_dialog.child("printerbox.resolution");
      return app.get_window(pathname + '.' + rel_name);
   end;

   configure(option: STR, val: $STR) is
      app.tcl_tk.eval(pathname + " configure -" + option + " " + val.str.pretty);
   end;

   configure(option: STR, val: $STR): SAME is
      configure(option, val);
      return self;
   end;
   
   configuration(option: STR): STR is
      return app.tcl_tk.eval("lindex ["+pathname+" configure -" + option + "] 4");
   end;
      
   create(name: STR, parent: $TK_WINDOW): SAME is
      r ::= new;
      r.init(name, parent);
      return r;
   end;

   private init(name: STR, parent: $TK_WINDOW) is
      if ~void(parent.child(name)) then
	 raise #TKKIT_EX("Window exists :" + parent.pathname + "." + name);
      end;
      
      app := parent.app;
      name := name;
      pathname := parent.pathname + '.' + name;

      parent := parent;
      children := #;

      mapped := false;	-- in general
      
      parent.add_child(self);
      
      wish_command ::= typus + " " + pathname; -- what a clue
      app.tcl_tk.eval(wish_command);
   end;

   bind_command(event_spec, command: STR) is
      app.tcl_tk.eval("bind "+pathname+" "+event_spec+" {"+command+"}");
   end;
   
   bind_command(event_spec: STR, callback: $TKKIT_CB, args: ARRAY{STR}) is
      bind_command(event_spec, callback.call_str(args));
   end;

   relief_flat: SAME is
      return relief("flat");
   end;

   relief_sunken: SAME is
      return relief("sunken");
   end;

   relief_groove: SAME is
      return relief("groove");
   end;

   relief_ridge: SAME is
      return relief("ridge");
   end;

   relief_raised: SAME is
      return relief("raised");
   end;

   private relief(how: STR): SAME is
      return configure("relief", how);
   end;

   width(x: INT): SAME is
      return configure("width", x.str);
   end;

   width(x: INT) is
      configure("width", x.str);
   end;

   width: INT is
      return #INT(configuration("width"));
   end;

   height(y: INT): SAME is
      return configure("height", y.str);
   end;
   
   height(y: INT) is
      configure("height", y.str);
   end;
   
   height: INT is
      return #INT(configuration("height"));
   end;

   text(s: STR): SAME is
      return configure("text", s);
   end;

   text(s: STR) is
      configure("text", s);
   end;

   text: STR is
      return configuration("text");
   end;
end; -- class TK_WINDOW

-------------------------------------------------------------------

