------------------------->  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>  <--------------

-- text.sa: Text widget
-- Author: Benedict A. Gomes <gomes@samosa.ICSI.Berkeley.EDU>

--Classes
-- TK_TEXT  Text widget that consists of an outer frame + optional
--          scrollbars + an actual text widget
-- TK_TEXT_TAG  Tag used for annotating sections of text
-- TK_TEXT_TAG_CFG Specification of text characterists that are
--          associated with a particular text tag.
-- TK_INDEX     Text index used to denote a particular location in the text
-------------------------------------------------------------------
class TK_TEXT_CFG is
   include TK_WIDGET_CFG_INCL
	 background->background,
	 foreground->foreground,
	 char_height->char_height,
	 char_width->char_width,
   -- cursor->cursor,
	 font->font,
	 borderwidth->borderwidth,
	 padx->padx,
	 pady->pady,
	 justify_left->justify_left,justify_right->justify_right,
	 justify_center->justify_center,
	 relief_none->relief_none,relief_raised->relief_raised,
	 relief_sunken->relief_sunken,
	 relief_flat->relief_flat,relief_ridge->relief_ridge,
	 relief_groove->relief_groove,
	 normal->normal,disable->disable,
	 insertwidth->insertwidth,
	 insertborderwidth->insertborderwidth,
	 highlightbackground->highlightbackground,
	 highlightcolor->highlightcolor,
	 highlightthickness->highlightthickness,
	 selectborderwidth->selectborderwidth,
	 selectforeground->selectforeground,
	 selectbackground->selectbackground;
    
   attr hscroll,vscroll: BOOL;	-- Treated differently
   hscroll(v: BOOL): SAME is hscroll := v; return self end;
   vscroll(v: BOOL): SAME is vscroll := v; return self end;
    
   no_wrap is config("wrap","none") end;
   char_wrap is config("wrap","char") end;
   word_wrap is config("wrap","word") end;
    
   no_wrap:SAME is no_wrap; return self; end;
   char_wrap: SAME is char_wrap; return self; end;
   word_wrap:SAME is word_wrap; return self; end;
    
   std: SAME is return new.hscroll(true).vscroll(true) end;   
end;
-------------------------------------------------------------------
class TK_TEXT < $TK_WIDGET is
   -- A text widget that corresponds to a TK text widget
   -- The widget must first be created, either using the default create
   -- routine, or the full creation routine that supplies a
   -- parent widget, text configuration options and packing information 
   -- 
   -- Eg: t ::= #TK_TEXT(#TK_ROOT_WINDOW,"mytext",#TK_TEXT_CFG,#TK_PACK);
   -- 
   -- Once created, text may be inserted into the widget at locations
   -- that are specified using TINDEX es. 
   -- A TINDEX indicates a location in the text widget in a number
   -- of ways - see the interface to TINDEX.
   -- 
   -- Eg. t.insert_at(TINDEX::at(1,0,"text");
   -- 
   -- Ranges of text may also be tagged using a TEXT_TAG, either
   -- at insertion or later on by specifying positions
   -- 
   -- Callbacks, basically bound routines, may then be associated
   -- with a particular text tag
   -- 
   -- mytag ::= #TK_TEXT_TAG("mytag");
   -- t.bind(mytag,EVENT_INCLUDE::enter,bind(myput(_)));
   -- 
   -- The callback routine myput is of the form
   -- myput(arg: TEXT_CB) is
   --    -- do something with arg
   --
   -- end;
   -- It is best to use TK_TEXT widgets by first including GUI_UTIL
   -- which makes many commonly used functions conveniently accessible.
    
   -- Implementation
   -- Creates a text widget called <text name> 
   -- embedded in a frame with the name "frame"+<text name>
   -- There may be auxilliary scrollbars as well.
   include TK_SCROLL_WIDGET_INCL{TK_TEXT_CFG};
    
   private const tk_widget_type: STR := "text";
    
   private default_init(c: TK_TEXT_CFG) is   
      -- By default, use scrollbars
      if c.vscroll then vscroll end;
      if c.hscroll  then hscroll end;
   end;
    
    
   plus(text: $STR) is 
      insert_at(TK_INDEX::end_pos,text.str); 
      see(TK_INDEX::end_pos) 
   end;
    
   plus(text: $STR):SAME is plus(text); return self; end;
    
   configure_tag(t: TK_TEXT_TAG,c: TK_TEXT_TAG_CFG) is
      -- Configure the text associated with the tag "t" to have the
      -- properties specified by the configuration "c".
      eval(actual_widget_name," tag configure ",t.str,c.str);
   end;
    
   insert_tagged(position: TK_INDEX,text: STR, tags: ARRAY{TK_TEXT_TAG}) is
      -- Insert text "text" with the tags "tags" at the location indicated
      -- by "position"
      eval(actual_widget_name,"insert",
	   position.str,quote(text),tag_str(tags))
   end;
    
   insert_at(position: TK_INDEX,text:STR) is
      -- Insert untagged text at "position"
      eval("textInsert",actual_widget_name,position.str,quote(text));
   end;
    
   delete(from,to: TK_INDEX)  is
      eval(actual_widget_name,"delete",from.str,to.str);
   end;
    
   get(from,to: TK_INDEX): STR is
      return GUI_APP_END::eval(actual_widget_name+" get "+from.str+" "+to.str);
   end;
    
   see(index: TK_INDEX) is
      -- Make index visible
      eval(actual_widget_name,"see",index.str);
   end;
    
   add_tag(t: TK_TEXT_TAG,from,to: TK_INDEX) is
      -- Add a tag "t" to the text from "from" to "to"
      eval(actual_widget_name,"tag add",t.str,from.str,to.str);
   end;
    
   bind_event(t:TK_TEXT_TAG,event: $TK_EVENT, action: ROUT{TK_EVENT_INFO}) is
      -- From the Tk man pages:
      -- The only events for which bindings may be specified are those
      -- related to the mouse and keyboard, such as Enter, Leave,
      -- ButtonPress, Motion, and KeyPress. Event bindings for a text
      -- widget use the current mark described under MARKS. An
      -- Enter event triggers for a tag when the tag first becomes
      -- present on the current character, and a Leave event triggers
      -- for a tag when it ceases to be present on the current
      -- character. Enter and Leave events can happen either because the
      -- current mark moved or because the character at that position
      -- changed. Note that these events are different than Enter and
      -- Leave events for windows.  Mouse and keyboard events are
      -- directed to the current character.
      action_index: INT := add_to_bindings(action);
      eval(actual_widget_name,
	   " tag bind ",
	   t.str,
	   quote(event.str),
	   quote("sather "+actual_widget_name+" "
		 +action_index+" "+event.cb_str));
   end;
    
    
   -- ------------------- INTERNAL DETAILS --------------------------
   private tag_str(tags: ARRAY{TK_TEXT_TAG}): STR is
      tag_list ::= " { ";
      loop tag_list := tag_list+" "+tags.elt!.str; end;
      tag_list := tag_list+" }";
      return tag_list
   end;
    
end; -- class TK_TEXT
-------------------------------------------------------------------
immutable class TK_TEXT_TAG is
   -- A tag used to indicate a region of characters in a TK_TEXT widget
   -- Text tags are used in binding callbacks
   include TK_TAG_INCL;
end;
-------------------------------------------------------------------   
class TK_TEXT_TAG_CFG is
   -- Specify configuration options for the text associated with a particular
   -- text tag
    
   private attr relief,justify,font: STR;
   private attr overstrike_str,underline_str: STR;
    
   -- The following attributes may be set directly
   attr background,foreground: STR;
   attr borderwidth: FLT;
   -- The following may be used, but don't yet have "function" versions
   -- that return self...
   attr lmargin,lmargin2,rmargin,rmargin2,spacing1,spacing2,spacing3: FLT;
   attr offset: FLT;
    
   -- No interface as yet
   private attr bgstipple,fgstipple,tabs: STR;
    
   create: SAME is
      -- Give all options either uninitialized (nil) or default values. 
      res ::= new;
      fnil ::= FLT::nil;
      res.borderwidth := fnil;
      res.lmargin := fnil; res.lmargin2 := fnil; 
      res.rmargin := fnil; res.rmargin2 := fnil; 
      res.spacing1 := fnil; res.spacing2 := fnil; res.spacing3 := fnil;
      res.offset := fnil; res.borderwidth := fnil;
      return res;
   end;
    
    
   foreground(s: STR): SAME is foreground := s; return self end;
   background(s: STR): SAME is background := s; return self end;
   borderwidth(i: FLT): SAME is borderwidth(i); return self end;
   font(f: STR): SAME is font(f); return self end;
   justify_right is justify := "right" end;
   justify_left is justify := "left" end; -- Default
   justify_center is justify := "center" end;
   justify_right: SAME is justify_right; return self; end;
   justify_left: SAME is justify_left; return self end;
   justify_center: SAME is justify_center;  return self; end;
   private relief_none is relief := " none" end;
   private relief_raised is relief := " raised" end;
   private relief_sunken is relief := " sunken" end;
   private relief_flat is relief := " flat" end;
   private relief_ridge is relief := " ridge" end;
   private relief_groove is relief := " groove" end;
   private relief_none:SAME is relief_none;  return self; end;
   private relief_raised:SAME is relief_raised;  return self; end;
   private relief_sunken:SAME is relief_sunken;  return self; end;
   private relief_flat:SAME is relief_flat;  return self; end;
   private relief_ridge:SAME is relief_ridge;  return self; end;
   private relief_groove:SAME is relief_groove;  return self; end;
   overstrike(b:BOOL) is 
      if b then overstrike_str:="true" else overstrike_str:="false" end;
   end;
   underline(b:BOOL) is 
      if b then underline_str:="true" else underline_str:="false" end;
   end;
   overstrike(b:BOOL):SAME is overstrike(b); return self end;
   underline(b:BOOL):SAME is underline(b); return self end;
    
    
   str: STR is
      return ""
	    +pair("background",background) 
	    +pair("foreground",foreground)
	    +pair("borderwidth",borderwidth)
	    +pair("relief",relief)
	    +pair("justify",justify)
	    +pair("overstrike",overstrike_str)    
	    +pair("underline",underline_str)
	    +pair("offset",offset)
	    +pair("rmargin",rmargin)  	    +pair("rmargin2",rmargin2)
	    +pair("spacing1",spacing1)     +pair("spacing2",spacing2)
	    +pair("spacing3",spacing3)
	    +pair("lmargin1",lmargin)   +pair("lmargin2",lmargin2)
      --+pair("-bgstipple",bgstipple)  +pair("-fgstipple ",fgstipple)
      --+pair("-tabs",tabs)
   end;
    
   pair(nm:STR,val: STR): STR is
      if ~void(val) then return (#FSTR(" ")+"-"+nm+" "+val.str+" ").str; 
      else return " "; end;
   end;
    
   pair(nm:STR,val: FLT): STR is
      if ~val.is_nil then return (#FSTR(" ")+"-"+nm+" "+val.str+" ").str; 
      else return " "; end;
   end;
    
end;
-------------------------------------------------------------------   
class TK_INDEX is 
   -- A text index indicates a particular position in a text widget
    
   readonly attr internal_str: STR;
    
   str: STR is return "\""+internal_str+"\""; end;
    
   private create(s: STR): SAME is
      res ::= new; res.internal_str := s; return res; 
   end;
    
   -- Index associated with position on line "line" and character "ch"
   first(tag: TK_TEXT_TAG): SAME is  return #(tag.str+".first"); end;
   last(tag: TK_TEXT_TAG): SAME is return #(tag.str+".last") end;
   -- Error if no characters currently have this "tag"
   at_location(x,y: INT): SAME is return #("@"+x+","+y); end;
   -- The character that covers the pixel with coods (x,y) in the text 
   mark: SAME is return #(" mark") end;
   end_pos: SAME is return #("end") end;
   at(line,ch: INT): SAME is return #(line.str+"."+ch); end;
   -- Line counting starts at "1" and character counting starts at "0"
   -- I dislike this, but I think it is better to remain consistent with
   -- the Tk documentation
    
   forward_chars(n: INT): SAME pre n >= 0 is return m(" + "+n+" chars");  end;
   backward_chars(n: INT): SAME pre n >= 0 is return m(" - "+n+" chars"); end;
   forward_lines(n: INT): SAME pre n>=0 is return m(" + "+n+" lines");   end;
   backward_lines(n: INT): SAME pre n>=0 is  return m(" - "+n+" lines"); end;
   line_start: SAME is return m(" linestart") end;
   line_end: SAME is return m(" lineend") end;
   word_start: SAME is return m(" wordstart") end;
   word_end: SAME is return m(" wordend") end;

   private m(modifier_str: STR): SAME is
      return #(internal_str+" "+modifier_str);
   end;

end; -- class TK_INDEX
-------------------------------------------------------------------


