------------------------------------------------------------------------------
-- COMMON (package body)                                                    --
--                                                                          --
-- Part of TextTools                                                        --
-- Designed and Programmed by Ken O. Burtch                                 --
--                                                                          --
------------------------------------------------------------------------------
--                                                                          --
--                 Copyright (C) 1999-2007 Ken O. Burtch                    --
--                                                                          --
-- This is free software;  you can  redistribute it  and/or modify it under --
-- terms of the  GNU General Public License as published  by the Free Soft- --
-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
-- sion.  This is distributed in the hope that it will be useful, but WITH- --
-- OUT 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 this;  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 is maintained at http://www.pegasoft.ca/tt.html                     --
--                                                                          --
------------------------------------------------------------------------------
pragma Optimize( time );
pragma Suppress( all_checks );

package body Common is
  use Strings255;

---> Housekeeping

procedure StartupCommon( theProgramName, theShortProgramName : string ) is
-- start up this package
begin
  LastError := 0;
  RaisingErrors := false;
  ProgramName := To255( theProgramName );
  ShortProgramName := To255( theShortProgramName );
end StartupCommon;

procedure StartupCommonCPP( theProgramName, theShortProgramName : C_string ) is
begin
  StartupCommon( To_Ada( theProgramName ), To_Ada( theShortProgramName ) );
end StartupCommonCPP;

procedure IdleCommon( IdlePeriod : ATimeStamp ) is
-- idle-time tasks
begin
  NoError;
end IdleCommon;

procedure ShutdownCommon is
-- shutdown this package
begin
  NoError;
end ShutdownCommon;

---> Error Trapping

procedure NoError is
-- clear last error
begin
  LastError := 0;
  --Str255List.Clear( LastErrorDetails );
end NoError;

procedure Error( ErrorCode : AnErrorCode ) is
-- record an error, raising an exception if necessary
begin
  LastError := ErrorCode;
  if ErrorCode /= TT_OK and then RaisingErrors then
     raise GeneralError;
  end if;
end Error;

procedure RaiseErrors is
-- raise a general error on upcoming errors
begin
  RaisingErrors := true;
end RaiseErrors;

procedure TrapErrors is
-- trap upcoming errors and put value in LastError
begin
  RaisingErrors := false;
end TrapErrors;

function RaiseErrors return boolean is
  WasRaising : boolean;
begin
  WasRaising := RaisingErrors;
  RaisingErrors := true;
  return WasRaising;
end RaiseErrors;

function TrapErrors return boolean is
  WasRaising : boolean;
begin
  WasRaising := RaisingErrors;
  RaisingErrors := false;
  return WasRaising;
end TrapErrors; 

procedure RestoreRaising( oldflag : boolean ) is
begin
  RaisingErrors := oldflag;
end RestoreRaising;

---> Rectangles

procedure SetRect( r : out ARect; left, top, right, bottom : integer ) is
-- initialize a rectangle
begin
  r.left := left;
  r.top  := top;
  r.right := right;
  r.bottom := bottom;
end SetRect;

procedure OffsetRect( r : in out ARect; dx, dy : integer ) is
-- shift a rectangle
begin
  r.left := r.left + dx;
  r.top := r.top + dy;
  r.right := r.right + dx;
  r.bottom := r.bottom + dy;
end OffsetRect;

function OffsetRect( r : in ARect; dx, dy : integer ) return ARect is
-- shift a rectangle returning the resulting rectangle
  newRect : ARect;
begin
  newRect.left := r.left + dx;
  newRect.top := r.top + dy;
  newRect.right := r.right + dx;
  newRect.bottom := r.bottom + dy;
  return newRect;
end OffsetRect;

procedure InsetRect( r : in out ARect; dx, dy : integer ) is
-- change the size of a rectangle
begin
  r.left := r.left + dx;
  r.top := r.top + dy;
  r.right := r.right - dx;
  r.bottom := r.bottom - dy;
end InsetRect;

function InsetRect( r : in ARect; dx, dy : integer ) return ARect is
-- change the size of a rectangle returning the resulting rectangle
  newRect : ARect;
begin
  newRect.left := r.left + dx;
  newRect.top := r.top + dy;
  newRect.right := r.right - dx;
  newRect.bottom := r.bottom - dy;
  return newRect;
end InsetRect;

function InsideRect( Inner, Outer : in ARect ) return boolean is
-- test for one rectangle inside of another
begin
  return (Inner.left   >= Outer.left)   and then
         (Inner.top    >= Outer.top)    and then
         (Inner.right  <= Outer.right ) and then
         (Inner.bottom <= Outer.bottom );
end InsideRect;

function InRect( x, y : integer ; r : ARect ) return boolean is
-- test for a point inside of a rectangle
begin
  return (x >= r.left and x <= r.right) and then
         (y >= r.top and y <= r.bottom);
end InRect;

function IsEmptyRect( r : ARect ) return boolean is
begin
  return (r.left > r.right ) or (r.top > r.bottom );
end IsEmptyRect;

---> Strings

--function To255( s : in Str80 ) return str255 is
-- convert a str255 to a str80
--begin
--  return To255( Strings80.To_String( s ) );
--end To255;

--function To80( s : in Str255 ) return str80 is
-- convert a str80 to a str255
--begin
--  return To80( Strings255.To_String( s ) );
--end To80;

function ToInteger( s : in str255 ) return integer is
-- convert a str255 to an integer
  pos  : integer := 1;
  sign : integer := 1;
  i    : integer := 0;
begin
  if length( s ) > 0 then
     while Element( s, pos ) = ' ' and then pos < Length( s ) loop
       pos := pos + 1;
     end loop;
     if Element( s, pos ) = '-' then
        sign := -1;
        pos := pos + 1;
     elsif Element( s, pos ) = '+' then
        pos := pos + 1;
     end if;
     i := integer'value( To_String( Tail( s, length(s)-pos+1 ) ) );
  end if;
  return i * sign;
end ToInteger;

function ToInteger( s : in string ) return integer is
-- convert a string to an integer
begin
  return ToInteger( To255( s ) );
end ToInteger;

function ToLongInteger( s : in Str255 ) return long_integer is
-- convert a str255 to a long integer
  pos  : integer := 1;
  sign : long_integer := 1;
  l    : long_integer := 0;
begin
  if length( s ) > 0 then
     while Element( s, pos ) = ' ' and then pos < Length( s ) loop
       pos := pos + 1;
     end loop;
     if Element( s, pos ) = '-' then
        sign := -1;
        pos := pos + 1;
     elsif Element( s, pos ) = '+' then
        pos := pos + 1;
     end if;
     l := long_integer'value( To_String( Tail( s, length(s)-pos+1 ) ) );
  end if;
  return l * sign;
end ToLongInteger;

function ToLongInteger( s : in string ) return long_integer is
-- convert a string to a long integer
begin
  return ToLongInteger( To255( s ) );
end ToLongInteger;


---> Fix Gnat 2.0's broken string functions

function Append( Left, Right : in Str255;
   Drop : in Strings.Truncation := Strings.Error ) return Str255 is
   TempStr : str255;
begin
   TempStr := Right;
   Insert( TempStr, 1, ToString( Left ), Drop );
   return TempStr;
end Append;
 
procedure Append( Source : in out Str255;
                  New_Item : in Str255;
                  Drop : in Strings.Truncation := Strings.Error ) is
  TempStr : str255;
begin
  TempStr := Source;
  Source := New_Item;
  Insert( Source, 1, ToString( TempStr ), Drop );
end Append;

function "&"( Left, Right : in Str255 ) return Str255 is
begin
  return Append( Left, Right );
end "&";

function "&"( Left : in string; Right : in Str255 ) return Str255 is
  TempStr : Str255;
begin
  TempStr := Right;
  Insert( TempStr, 1, Left, Strings.Error );
  return TempStr;
end "&";

function Head( Source : in Str255;
               Count  : in Natural;
               Pad    : in Character := Strings.Space;
               Drop   : in Strings.Truncation := Strings.Error )
               return Str255 is
  TempStr : Str255 := NullStr255;
begin
   if Count < length(Source) then
      for i in 1..Count loop
          TempStr := Append( TempStr,  Element( Source, i ) );
      end loop;
   else
      TempStr := Source;
      for i in length(Source)+1..Count loop
          TempStr := TempStr & Pad;
      end loop;
   end if;
   -- Note: I ignore Drop parameter
   return TempStr;
end Head;

---> Sorting order for a list of rectangles

function RectOrder( left, right : ARect ) return boolean is
-- used to order rectangles in a rectangle list
begin
  return InsideRect( left, right );
end RectOrder;

end Common;