-------------------------------------------------------------------
--           RAPID - RAPID ADA PORTABLE INTERFACE DESIGNER         
--           TCL PEER FOR THE MCC GUI PACKAGE LIBRARY 
--           Copyright (C) 1999 Martin C. Carlisle.                
--                                                                 
-- RAPID is free software;  you can  redistribute it  and/or modify
-- it under terms of the  GNU General Public License as published  
-- by the Free Software  Foundation;  either version 2,  or (at your
-- option) any later version.  RAPID 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 the GNU General Public License for more details.  
-- You should have  received  a copy of the GNU General Public License
-- distributed with RAPID; see file COPYING.  If not, write to the 
-- Free Software Foundation,  59 Temple Place - Suite 330,  Boston, 
-- MA 02111-1307, USA.                                                 
--                                                                     
-- As a special exception, if other files instantiate generics from
-- this unit, or you link this unit with other files to produce an 
-- executable, this unit does not by itself cause the resulting 
-- executable to be covered by the GNU General Public License.  
-- This exception does not however invalidate any other reasons 
-- why the executable file might be covered by the GNU Public 
-- License.  This exception does not apply to executables which
-- are GUI design tools, or that could act as a replacement
-- for RAPID.
------------------------------------------------------------------------------
with Ada.Unchecked_Conversion;
with Lexer;
with Mcc.Common_Dialogs;
with options;
package body Mcc.Gui.Widget.Text_Window is
   Max_Text_Length : constant                               := 4096;
      
   Text            :          String (1 .. Max_Text_Length);  
   ----------------------------------------------------------------------
   -----------
   -- Clear --
   -----------
   procedure Clear (
         Obj : in out Text_Window ) is 
   begin
      Peer.Eval(Obj.My_Peer.Name.all & ".text delete 1.0 end");
   end Clear;

   ----------------------------------------------------------------------
   ------------
   -- Create --
   ------------

   procedure Create (
         Obj                  : in out Text_Window;                       
         Parent               : in     Mcc.Gui.Container.Container'Class; 
         X                    : in     Integer;                           
         Y                    : in     Integer;                           
         Width                : in     Natural;                           
         Height               : in     Natural;                           
         Horizontal_Scrollbar : in     Boolean;                           
         Vertical_Scrollbar   : in     Boolean                            ) is 
      type Parent_Access is access constant Mcc.Gui.Container.Container'Class; 
      function Convert is 
      new Ada.Unchecked_Conversion(
      Parent_Access,  
      Mcc.Gui.Container.Container_Pointer);  
      begin
         Obj.My_Peer := Peer.Create_Peer(Parent.My_Peer);
         Peer.Eval("frame " & Obj.My_Peer.Name.all);
         Peer.Eval("text " & Obj.My_Peer.Name.all & ".text " &
            " -width" & Integer'Image(Width) &
            " -height" & Integer'Image(Height) &
            " -wrap none");

         if Vertical_Scrollbar then
            Peer.Eval(
               "scrollbar " & Obj.My_Peer.Name.all & ".vscrl" &
               " -orient vertical -command """ & Obj.My_Peer.Name.
               all &
               ".text yview""");
            Peer.Eval(Obj.My_Peer.Name.all & ".text configure" &
               " -yscrollcommand """ &
               Obj.My_Peer.Name.all & ".vscrl set""");
            --Pack options for vertical scrollbar
            Peer.Eval("pack " & Obj.My_Peer.Name.all &
               ".vscrl -side right -fill y");
         end if;

         if Horizontal_Scrollbar then
            Peer.Eval(
               "scrollbar " & Obj.My_Peer.Name.all & ".hscrl" &
               " -orient horizontal -command """ & Obj.My_Peer.Name
               .all &
               ".text xview""");
            Peer.Eval(Obj.My_Peer.Name.all & ".text configure" &
               " -xscrollcommand """ &
               Obj.My_Peer.Name.all & ".hscrl set""");
            --Pack options for vertical scrollbar
            Peer.Eval("pack " & Obj.My_Peer.Name.all &
               ".hscrl -side bottom -fill x");
         end if;

         --Create Listbox with no scrollbars
         if (not Horizontal_Scrollbar) and (not Vertical_Scrollbar
               ) then
            --Pack options for listbox
            Peer.Eval("pack " & Obj.My_Peer.Name.all & ".text ");
         else
            --Pack options for listbox
            Peer.Eval("pack " & Obj.My_Peer.Name.all & ".text" &
               " -side left");
         end if;

         Peer.Eval("place " & Obj.My_Peer.Name.all &
            " -anchor nw" &
            " -x " & Integer'Image(X) &
            " -y " & Integer'Image(Y) &
            " -width" & Integer'Image(Width) &
            " -height" & Integer'Image(Height));

         -- Since most of window is subwidget, set its bindings to
         -- that of parent.  This greatly simplifies the implementation
         -- of mouse and key bindings in mcc.gui
         Peer.Eval("bindtags " & Obj.My_Peer.Name.all &
            ".text ""[bindtags " & Obj.My_Peer.Name.all & ".text] "
            &
            Obj.My_Peer.Name.all & """");
         Obj.Parent := Convert(Parent'Unchecked_Access);
      end Create;

      ----------------------------------------------------------------------
   procedure init_screen(Obj: in out Text_Window) is 
   begin
      peer.eval("set tmpscn [" & Obj.My_Peer.Name.all & ".text get 1.0 end ]");  
   end init_screen;   
      
   procedure get_screen (Obj : in out Text_Window) is
   begin
      peer.eval("set tmpsct $tmpscn");
      peer.eval("set tmpscn [" & Obj.My_Peer.Name.all & ".text get 1.0 end ]");  
   end get_screen;

   procedure put_screen (Obj : in out Text_Window) is
   begin 
      peer.eval(Obj.My_Peer.Name.all & ".text delete 1.0 end" & Ascii.Lf &
                Obj.My_Peer.Name.all & ".text insert end $tmpsct");
   end put_screen;

   procedure remove_next(Obj: in out Text_Window) is
   begin
      peer.eval(Obj.My_Peer.Name.all & ".text delete insert");
   end remove_next;


   procedure Select_All (
         Obj : in out Text_Window ) is 
      begin
         Peer.Eval(Obj.My_Peer.Name.all & ".text tag add sel 1.0 end"
            );
      end Select_All;

   procedure Find (
         Obj    : in out Text_Window; 
         Tofind : in     String       ) is 
      Temp : String := "set indx [ " & Obj.My_Peer.Name.
         all & ".text search -nocase -- "
         & Tofind &
         " insert end ] " & Ascii.Lf & "if { $indx != """" } {"& Ascii
         .Lf &
         Obj.My_Peer.Name.all& ".text tag add sel $indx ""$indx +"
         & Integer'Image(Tofind'Length)&" chars""" & Ascii.Lf&
         Obj.My_Peer.Name.all &".text mark set insert ""$indx + "&
         Integer'Image(Tofind'Length)&" chars""" & Ascii
         .Lf &
         "} else {" & Ascii.Lf &
         "set indx insert}";
      begin
         Peer.Eval(Temp);
      end Find;

   procedure Replace (
         Obj        : in out Text_Window; 
         Tofind     : in     String;      
         Toreplace  : in     String;      
         Replaceall : in     Boolean      ) is 
      Temp : String := "set indx [ " & Obj.My_Peer.Name.
         all & ".text search -nocase -- "
         & Tofind &
         " insert end ] " & Ascii.Lf & "if { $indx != """" } {"& Ascii
         .Lf & Ascii.Lf&
         Obj.My_Peer.Name.all &".text mark set insert $indx" & Ascii
         .Lf & Obj.My_Peer.Name.all& ".text delete $indx ""$indx +"
         & Integer'Image(Tofind'Length)&" chars""" & Ascii.Lf&
         Obj.My_Peer.Name.all& ".text insert $indx " & Toreplace
         & Ascii.Lf & Obj.My_Peer.Name.all& ".text tag add sel $indx ""$indx +"
         & Integer'Image(Toreplace'Length)&" chars""" & Ascii.Lf &
         "set indx 1" & Ascii.Lf &
         "} else {" & Ascii.Lf &
         "set indx -1}";
      Num  : Integer;  
      Indx : Integer := 1;  
      begin
         if Replaceall then
            while Indx/=-1 loop
               Peer.Eval(Temp);
               Peer.Get_Value("indx",Indx);
               Num:=Line_Number(Obj);
               Update_Line(Get_Line(Obj,Num),Obj,Num);
            end loop;
         else
            Peer.Eval(Temp);
            Num:=Line_Number(Obj);
            Update_Line(Get_Line(Obj,Num),Obj,Num);
         end if;
      end Replace;
      --------------
      -- Get_Text --
      --------------

   function Get_Text (
         Obj : in     Text_Window ) 
     return String is 
      Last : Natural;  
      begin
         Peer.Eval(
            "set entry_text [ " & Obj.My_Peer.Name.all &
            " get ]");
         Peer.Get_Value(
        Name   => "entry_text", 
        Result => Text,         
        Last   => Last);
         return Text(Text'First..Last);
      end Get_Text;

      ----------------------------------------------------------------------
      --------------
      -- Get_Text --
      --------------

   function Get_Text (
         Obj : in     Text_Window ) 
     return Integer is 
      begin
         return Integer'Value(Get_Text(Obj));
      end Get_Text;

      ----------------------------------------------------------------------
      --------------
      -- Get_Text --
      --------------

   function Get_Text (
         Obj : in     Text_Window ) 
     return Float is 
      begin
         return Float'Value(Get_Text(Obj));
      end Get_Text;

      ----------------------------------------------------------------------
      ---------------------
      -- Get_Text_Length --
      ---------------------

   function Get_Text_Length (
         Obj : in     Text_Window ) 
     return Natural is 
      Result : String := Get_Text (Obj);  
      begin
         return Result'Length;
      end Get_Text_Length;

      ----------------------------------------------------------------------
      ---------------
      -- Highlight --
      ---------------

   procedure Highlight (
         Obj   : in out Text_Window; 
         Start : in     Natural;     
         Stop  : in     Natural      ) is 
      begin
         Peer.Eval(Obj.My_Peer.Name.all & " selection range " &
            Integer'Image(Start) & Integer'Image(Stop));
         Peer.Eval("focus " & Obj.My_Peer.Name.all);
      end Highlight;

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

   procedure Highlight (
         Obj : in out Text_Window ) is 
      begin
         Peer.Eval(Obj.My_Peer.Name.all & " selection range 0 end"
            );
         Peer.Eval("focus " & Obj.My_Peer.Name.all);
      end Highlight;

      ----------------------------------------------------------------------
      --------------
      -- Set_Text --
      --------------

   procedure Set_Text (
         Obj  : in out Text_Window; 
         Text : in     String       ) is 
      begin
         Clear(Obj);
         Peer.Eval(Obj.My_Peer.Name.all &
            " insert end """ & Peer.Fix_Quotes(Text) & """");
      end Set_Text;

      ----------------------------------------------------------------------
      ------------------------------------------------
      -- procedure Set_Text
      --
      -- Set text for a text entry using
      -- image of integer (w/o leading spaces)
      ------------------------------------------------
   procedure Set_Text (
         Obj  : in out Text_Window; 
         Text : in     Integer      ) is 
         -- return image of integer w/o leading space

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

      function Integer_Image (
            X : in     Integer ) 
        return String is 
         Result : String := Integer'Image (X);  
         begin
            if Result(Result'First) = ' ' then
               return Result(Result'First+1..Result'Last);
            else
               return Result;
            end if;
         end Integer_Image;
      begin
         Set_Text(Obj,Integer_Image(Text));
      end Set_Text;


      ----------------------------------------------------------------------
      ------------------------------------------------
      -- prcedure(s) import_Text 
      --
      -- Imports text from file into edit 
      -- window. Needs opened file_type.
      ------------------------------------------------

   procedure Import_Text (
         Obj  : in out Text_Window; 
         File : in     String       ) is 
         --;                           
         --         Parent : IN     Mcc.Gui.Container.Container'Class ) IS 
      begin
         Peer.Eval("set data """"" & Ascii.Lf &
            "if { [file readable " & File &  "] } {" & Ascii.Lf &
            "set fileid [open " & File & " ""r""]" & Ascii.Lf &
            "set data [read $fileid]" & Ascii.Lf &
            "close $fileid" & Ascii.Lf &
            "}" & Ascii.Lf &
            Obj.My_Peer.Name.all & ".text insert end $data");
      end Import_Text;

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

   procedure Export_Text (
         Obj  : in out Text_Window; 
         File : in     String       ) is 
         --;                           
      begin
         Peer.Eval("set data [" & Obj.My_Peer.Name.all &
            ".text get 1.0 {end -1c} ]" & Ascii.Lf &
            "set fileid [open " & File & " ""w""]" & Ascii.Lf &
            "puts -nonewline $fileid $data" & Ascii.Lf &
            "close $fileid");
      end Export_Text;


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

   procedure Paste (
         Obj : in out Text_Window ) is 
      begin
         Peer.Eval("catch { set clip [selection get -selection CLIPBOARD] }"
            & Ascii.Lf & 
            "set idx [" & Obj.My_Peer.Name.all & ".text index insert]"
            &
            Ascii.Lf &
            "set owner [selection own]" & Ascii.Lf &
            --         "if {$owner == " & Obj.My_Peer.Name.all & ".text } {" & Ascii.Lf &
            "catch {" & Ascii.Lf &
            "set idx [$owner index sel.first]" & Ascii.Lf &
            Obj.My_Peer.Name.all & ".text delete sel.first sel.last"
            & Ascii.
            Lf &
            " }" & Ascii.Lf &
            "catch {" & Obj.My_Peer.Name.all & ".text insert $idx $clip }" & Ascii.Lf &
            obj.My_Peer.Name.all & ".text tag add sel $idx insert"
            );
      end Paste;

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

   procedure Copy_Cut (
         Cut : in     Boolean := False ) is 
      begin
         if Cut then
            Peer.Eval("set owner [selection own]" --& Ascii.Lf &
               & Ascii.Lf &
               "clipboard clear" & Ascii.Lf &
               "catch {" & Ascii.Lf &
               "clipboard append [selection get]" & Ascii.Lf &
               "$owner delete sel.first sel.last" & Ascii.Lf & "} "
               );
         else
            Peer.Eval("set owner [selection own]" --& Ascii.Lf &
               & Ascii.Lf &
               "clipboard clear" & Ascii.Lf &
               "catch {" & Ascii.Lf &
               "clipboard append [selection get]" & Ascii.Lf &
               " }");
         end if;
      end Copy_Cut;

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

   procedure Put_Line (
         Obj  : in out Text_Window; 
         Line : in     Integer;     
         Str  : in     String       ) is 
      begin
         Peer.Eval(Obj.My_Peer.Name.all &
            ".text insert " & Integer'Image(Line) & ".0 """ & Str &
            """" );
      end Put_Line;

   procedure Put_Line (
         Obj : in out Text_Window; 
         Str : in     String       ) is 
      begin
         Peer.Eval(Obj.My_Peer.Name.all &
            ".text insert ""insert linestart"" """ & Str(1..Str'Length
               ) &
            """");
      end Put_Line;

      ----------------------------------------------------------------------
      --Deletes the text on the line given by the insertion marker
   procedure Del_Line (
         Obj : in out Text_Window ) is 
      begin
         Peer.Eval(Obj.My_Peer.Name.all &
            ".text delete ""insert linestart"" ""insert lineend"""
            );
      end Del_Line;

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

   function Get_Line (
         Obj  : in     Text_Window; 
         Line :        Integer      ) 
     return String is 
      Str : String (1 .. 1000);  
      Num : Integer;  
      begin
         Peer.Eval(
            "set pos [" & Obj.My_Peer.Name.all & ".text index "& Integer
            '
            Image(Line) & ".0]"&
            Ascii.Lf &

            "set temp1 [" & Obj.My_Peer.Name.all &
            ".text get ""$pos linestart"" ""$pos lineend""]" );
         Peer.Get_Value("temp1",Str,Num);
         return Str(1..Num);
      end Get_Line;

      -----------------------------------------------
      --Get's the current line

   function Get_Line (
         Obj : in     Text_Window ) 
     return String is 
      Str : String (1 .. 1000);  
      Num : Integer;  
      begin
         Peer.Eval(
            "set temp1 [" & Obj.My_Peer.Name.all &
            ".text get ""insert linestart"" ""insert lineend""]" )
         ;
         Peer.Get_Value("temp1",Str,Num);
         if Num<1 then
            return "";
         else
            return Str(1..Num);
         end if;
      end Get_Line;

      -----------------------------------------------
   procedure Goto_Line (
         Obj : in out Text_Window; 
         Num : in     Integer      ) is 
      begin
         Peer.Eval(Obj.My_Peer.Name.all & ".text mark set insert "
            & Integer'Image(Num) & ".0");
      end Goto_Line;
      
   procedure Goto_Line_Col (
         Obj : in out Text_Window; 
         Num,Col : in     Integer      ) is 
         c:string:=Integer'Image(Col);
         row:string:=Integer'Image(Num);
      begin
         Peer.Eval(Obj.My_Peer.Name.all & ".text mark set insert "
            & row(2..row'length) & "." & c(2..c'length));
      end Goto_Line_col;
      

   procedure Foc (
         Obj : in     Text_Window ) is 
      begin
         Peer.Eval("focus " & Obj.My_Peer.Name.all);
      end Foc;

   procedure Update is 
      begin
         Peer.Eval("update");
      end Update;

   function Line_Number (
         Obj : in     Text_Window ) 
     return Integer is 
      Num  : Integer          := 0;  
      Temp : String (1 .. 40);  
      begin
         Peer.Eval("set indx [" & Obj.My_Peer.Name.all & ".text index ""insert linestart""]"
            );
         Peer.Get_Value("indx",Temp,Num);
         Num:=Integer'Value(Temp(1..Num-2));
         return Num;
      end Line_Number;

   procedure Change_Insert (
         Obj    : in out Text_Window; 
         Change : in     Integer      ) is 
      begin

         Peer.Eval(Obj.My_Peer.Name.all & ".text tag configure ovr -overstrike "
            & Integer'Image(Change) & Ascii.Lf &
            Obj.My_Peer.Name.all & ".text tag add ovr 1.0 end");
      end Change_Insert;

   function Column_Number (
         Obj : in     Text_Window ) 
     return Integer is 
      Num  : Integer          := 0;  
      Temp : String (1 .. 40);  
      begin
         Peer.Eval("set indx [" & Obj.My_Peer.Name.all & ".text index insert]"
            );
         Peer.Get_Value("indx",Temp,Num);
         while Temp(1)/='.' loop
            Temp(1..39):=Temp(2..40);
            Num:=Num-1;
         end loop;
         Temp(1..39):=Temp(2..40);
         Num:=Num-1;
         Num:=Integer'Value(Temp(1..Num));
         return Num;
      end Column_Number;

   function Last_Line (
         Obj : in     Text_Window ) 
     return Integer is 
      Num  : Integer          := 0;  
      Temp : String (1 .. 40);  
      begin
         Peer.Eval("set indx [" & Obj.My_Peer.Name.all & ".text index ""end linestart""]"
            );
         Peer.Get_Value("indx",Temp,Num);
         Num:=Integer'Value(Temp(1..Num-2));
         return Num;
      end Last_Line;
      ----------------------------------------------------------------------
      
      function color_box return string is
         temp:string(1..20);
         last:integer;
      begin
         peer.eval("set color [ tk_chooseColor \"& Ascii.Lf & 
                   "-initialcolor lightgreen \" & Ascii.Lf &
                   "-title ""Color""]");
         Peer.Get_Value("color",temp,last);
         return temp(1..last);
      end color_box;
      

   procedure Comments_Strings (
         S    : in     String;      
         Obj  : in out Text_Window; 
         Line : in     Integer      ) is 
      Instr : String := Obj.My_Peer.Name.
         all&
         ".text tag configure com_str -foreground " & options.get_comments_color & Ascii
         .
         Lf ;
      Lines : String := Integer'Image (Line);  
      Chars : String := Integer'Image (S'First - 1);  

      begin

         Peer.Eval(Instr & Obj.My_Peer.Name.all & ".text tag add com_str "
            & Lines(Lines'First+1..Lines'Last)& "." & Chars(Chars'
               First+1..Chars'Last)& " """
            & Lines(Lines'First+1..Lines'Last)& "." & Chars(Chars'
               First+1..Chars'Last)&
            " + " &
            Integer'Image(S'Length) &" chars""");
      end Comments_Strings;

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

   procedure Constants (
         S    : in     String;      
         Obj  : in out Text_Window; 
         Line : in     Integer      ) is 
      Instr : String := Obj.My_Peer.Name.
         all&
         ".text tag configure const -foreground " & options.get_constants_color & Ascii
         .
         Lf ;
      Lines : String := Integer'Image (Line);  
      Chars : String := Integer'Image (S'First - 1);  

      begin

         Peer.Eval(Instr & Obj.My_Peer.Name.all & ".text tag add const "
            & Lines(Lines'First+1..Lines'Last)& "." & Chars(Chars'
               First+1..Chars'Last)& " """
            & Lines(Lines'First+1..Lines'Last)& "." & Chars(Chars'
               First+1..Chars'Last)&
            " + " &
            Integer'Image(S'Length) &" chars""");
      end Constants;

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

   procedure Reserve (
         S    : in     String;      
         Obj  : in out Text_Window; 
         Line : in     Integer      ) is 
      Instr : String := Obj.My_Peer.Name.
         all&
         ".text tag configure reserve -foreground " & options.get_reserve_color & Ascii.Lf ;
      Lines : String := Integer'Image (Line);  
      Chars : String := Integer'Image (S'First - 1);  

      begin
         Peer.Eval(Instr & Obj.My_Peer.Name.all & ".text tag add reserve "
            & Lines(Lines'First+1..Lines'Last)& "." & Chars(Chars'
               First+1..Chars'Last)& " """
            & Lines(Lines'First+1..Lines'Last)& "." & Chars(Chars'
               First+1..Chars'Last)&
            " + " &
            Integer'Image(S'Length) &" chars""");

      end Reserve;

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

   procedure Update_Line (
         S   : in     String;      
         Obj : in out Text_Window; 
         L   : in     Integer      ) is 
      First   : Integer             := 1;  
      Last    : Integer;  
      Result  : Lexer.Token;  
      Haveone : Boolean;  
      Done    : Boolean             := False;  
      Sptr    : Lexer.Stringpointer;  
      begin
         Sptr:=new String(S'range);
         Sptr.all:=S;
         while not Done loop
            Lexer.Getnexttoken(Sptr,First,Last,Result,Haveone,Done
               );
            --                        Mcc.Common_Dialogs.Ok_Box(Integer'Image(First));
            --                        Mcc.Common_Dialogs.Ok_Box(Integer'Image(last));

            if Haveone then
               if Result.Token_Type in Lexer.Reservedwords then
                  Reserve(S(First..Last),Obj,L);
               elsif
                  Lexer."="(Result.Token_Type,Lexer.String_T) then
                  Comments_Strings(S(First..Last),Obj,L);
               elsif
                  Lexer."="(Result.Token_Type,Lexer.Comment_T) then
                  Comments_Strings(S(First..Last-1),Obj,L);
               elsif
                  Result.Token_Type in Lexer.Constants then
                  Constants(S(First..Last),Obj,L);
               end if;
               First:=Last+1;
            end if;
         end loop;
      end Update_Line;
      ----------------------------------------------------------------------

   end Mcc.Gui.Widget.Text_Window;
