------------------------------------------------------------------------------
-- 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                     --
--                                                                          --
------------------------------------------------------------------------------
package body Common is
   
---> Housekeeping

procedure StartupCommon ( theProgramName, theShortProgramName : string ) is
-- start up this package
begin
  LastError := 0;
  RaisingErrors := false;
  ProgramName := Ada.Strings.Unbounded.To_Unbounded_String (TheProgramName );
  ShortProgramName := Ada.Strings.Unbounded.To_Unbounded_String ( theShortProgramName );
end StartupCommon;

procedure IdleCommon( IdlePeriod : in Duration ) is
-- idle-time tasks
   pragma Unreferenced (Idleperiod);
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;

---> 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 not InsideRect( left, right );
end RectOrder;

end Common;

