home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
OS/2 Shareware BBS: 10 Tools
/
10-Tools.zip
/
adapm_15.zip
/
gpi.adb
< prev
next >
Wrap
Text File
|
1994-12-07
|
27KB
|
855 lines
------------------------------------------------------------------------------
-- --
-- PM Bindings --
-- --
-- GPI --
-- --
-- B o d y --
-- --
-- $Revision: .14 $ --
-- --
-- Copyright (c) 1994 Dimensional Media Systems, All Rights Reserved --
-- --
-- The PM bindings are free software; you can redistribute them and/or --
-- modify them 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. The PM bindings are distributed in the --
-- hope that they 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 The PM bindings; see file COPYING. If not, write to --
-- the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. --
-- --
------------------------------------------------------------------------------
-- --
-- For more information about these PM bindings and their usage with GNAT --
-- you can contact Bill Yow at --
-- --
-- Dimensional Media Systems (DMS) --
-- 1522 Festival Dr. --
-- Houston TX, 77062 --
-- Phone - (713) 488-7050 --
-- Email - byow@mci.com --
-- --
------------------------------------------------------------------------------
with Pm_Types;
with Win;
with System;
package body GPI is
Background_Mix_Values : constant array (Background_Mix_Type)
of Pm_Types.Long :=
(Bm_Error => -1,
Bm_Default => 0,
Bm_Or => 1,
Bm_Overpaint => 2,
Bm_Leave_Alone => 5,
Bm_Xor => 4,
Bm_And => 6,
Bm_Subtract => 7,
Bm_Mask_Src_Not => 8,
Bm_Zero => 9,
Bm_Not_Merge_Src => 10,
Bm_Not_Xor_Src => 11,
Bm_Invert => 12,
Bm_Merge_Src_Not => 13,
Bm_Not_Copy_Src => 14,
Bm_Merge_Not_Src => 15,
Bm_Not_Mask_Src => 16,
Bm_One => 17,
Bm_Src_Transparent => 18,
Bm_Dest_Transparent => 19);
---------------------------------------------------------
Outline_Values : constant array (Outline_Style_Type)
of Pm_Types.Long :=
(Dro_Fill => 1,
Dro_Outline => 2,
Dro_Outline_Fill => 3);
---------------------------------------------------------
function Failed_To (Value : Boolean) return Boolean is
begin
return not Value;
end Failed_To;
---------------------------------------------------------
function GPISetBackMix (
Ps : Win.Ps_Type;
Mix : Pm_Types.Long) return Pm_Types.Long;
pragma Import (Convention => C,
Entity => GpiSetBackMix,
Link_Name => "GpiSetBackMix");
---------------------------------------------------------
function Set_Background_Mix (
Ps : Win.Ps_Type;
Mix : Background_Mix_Type) return Boolean is
begin
return GPISetBackMix (Ps, Background_Mix_Values (Mix)) = 1;
end Set_Background_Mix;
---------------------------------------------------------
procedure Set_Background_Mix (
Ps : Win.Ps_Type;
Mix : Background_Mix_Type) is
begin
if not Set_Background_Mix (Ps, Mix) then
raise GPI_Error;
end if;
end Set_Background_Mix;
---------------------------------------------------------
function Set_Background_Color (
Ps : Win.Ps_Type;
Color : Color_Type) return Boolean is
function GpiSetBackColor (
Ps : Win.Ps_Type;
Color : Color_Type) return Pm_Types.Long;
pragma Import (Convention => C,
Entity => GpiSetBackColor,
Link_Name => "GpiSetBackColor");
begin
return GpiSetBackColor (Ps, Color) = 1;
end Set_Background_Color;
---------------------------------------------------------
procedure Set_Background_Color (
Ps : Win.Ps_Type;
Color : Color_Type) is
begin
if not Set_Background_Color (Ps, Color) then
raise GPI_Error;
end if;
end Set_Background_Color;
---------------------------------------------------------
function Set_Color (
Ps : Win.Ps_Type;
Color : Color_Type) return Boolean is
function GpiSetColor (
Ps : Win.Ps_Type;
Color : Color_Type) return Pm_Types.Long;
pragma Import (Convention => C,
Entity => GpiSetColor,
Link_Name => "GpiSetColor");
begin
return GpiSetColor (Ps, Color) = 1;
end Set_Color;
---------------------------------------------------------
procedure Set_Color (
Ps : Win.Ps_Type;
Color : Color_Type) is
begin
if not Set_Color (Ps, Color) then
raise GPI_Error;
end if;
end Set_Color;
---------------------------------------------------------
function Status_Is (Value : Pm_Types.Long) return Status_Type is
begin
case Value is
when 0 => return Error;
when 1 => return Okay;
when 2 => return Hits;
when others => null;
end case;
return Error;
end Status_Is;
---------------------------------------------------------
function Char_String_At (
Ps : Win.Ps_Type;
Point : Win.Point_Type;
Text : String) return Status_Type is
function GPICharStringAt (
Ps : Win.Ps_Type;
Point : System.Address;
Length : Pm_Types.Long;
Str : System.Address) return Pm_Types.Long;
pragma Import (Convention => C,
Entity => GpiCharStringAt,
Link_Name => "GpiCharStringAt");
Result : Pm_Types.Long;
begin
Result := GPICharStringAt (
Ps => Ps,
Point => Point'address,
Length => Pm_Types.Long (Text'Length),
Str => Text (Text'first)'address);
return Status_Is (Result);
end Char_String_At;
---------------------------------------------------------
procedure Char_String_At (
Ps : in Win.Ps_Type;
Point : in Win.Point_Type;
Text : in String) is
begin
if Error = Char_String_At (Ps, Point, Text) then
raise GPI_Error;
end if;
end Char_String_At;
---------------------------------------------
function Char_String (
Ps : Win.Ps_Type;
Text : String) return Status_Type is
function GPICharString (
Ps : Win.Ps_Type;
Length : Pm_Types.Long;
Str : System.Address) return Pm_Types.Long;
pragma Import (Convention => C,
Entity => GpiCharString,
Link_Name => "GpiCharString");
Result : Pm_Types.Long;
begin
Result := GPICharString (
Ps => Ps,
Length => Pm_Types.Long (Text'Length),
Str => Text (Text'first)'address);
return Status_Is (Result);
end Char_String;
---------------------------------------------------------
procedure Char_String (
Ps : in Win.Ps_Type;
Text : in String) is
begin
if Error = Char_String (Ps, Text) then
raise GPI_Error;
end if;
end Char_String;
---------------------------------------------
function Set_Current_Position (
Ps : Win.Ps_Type;
Point : Win.Point_Type) return Boolean is
function GPISetCurrentPosition (
Ps : Win.Ps_Type;
Point : System.Address) return Pm_Types.Long;
pragma Import (Convention => C,
Entity => GpiSetCurrentPosition,
Link_Name => "GpiSetCurrentPosition");
Result : Pm_Types.Long;
begin
Result := GpiSetCurrentPosition (
Ps => Ps,
Point => Point'Address);
return Result = 1;
end Set_Current_Position;
---------------------------------------------
procedure Set_Current_Position (
Ps : Win.Ps_Type;
Point : Win.Point_Type) is
begin
if not Set_Current_Position (Ps, Point) then
raise Gpi_Error;
end if;
end Set_Current_Position;
---------------------------------------------
function Query_Current_Position (
Ps : Win.Ps_Type;
Point : Win.Point_Pointer_Type) return Boolean is
function GPIQueryCurrentPosition (
Ps : Win.Ps_Type;
Point : Win.Point_Pointer_Type) return Pm_Types.Long;
pragma Import (Convention => C,
Entity => GpiQueryCurrentPosition,
Link_Name => "GpiQueryCurrentPosition");
Result : Pm_Types.Long;
begin
Result := GpiQueryCurrentPosition (
Ps => Ps,
Point => Point);
return Result = 1;
end Query_Current_Position;
---------------------------------------------
procedure Query_Current_Position (
Ps : in Win.Ps_Type;
Point : out Win.Point_Type) is
function GPIQueryCurrentPosition (
Ps : Win.Ps_Type;
Point : System.Address) return Pm_Types.Long;
pragma Import (Convention => C,
Entity => GpiQueryCurrentPosition,
Link_Name => "GpiQueryCurrentPosition");
Result : Pm_Types.Long;
begin
Result := GpiQueryCurrentPosition (
Ps => Ps,
Point => Point'Address);
if Result /= 1 then
raise GPI_Error;
end if;
end Query_Current_Position;
---------------------------------------------
function Erase (Ps : Win.Ps_Type) return Boolean is
function GPIErase (
Ps : Win.Ps_Type) return Pm_Types.Long;
pragma Import (Convention => C,
Entity => GpiErase,
Link_Name => "GpiErase");
Result : Pm_Types.Long;
begin
Result := GpiErase (Ps);
return Result = 1;
end Erase;
---------------------------------------------
procedure Erase (Ps : Win.Ps_Type) is
begin
if Failed_To (Erase (Ps)) then
raise GPI_Error;
end if;
end Erase;
---------------------------------------------
function Destroy_Ps (Ps : Win.Ps_Type) return Boolean is
function GpiDestroyPs (
Ps : Win.Ps_Type) return Pm_Types.Long;
pragma Import (Convention => C,
Entity => GpiDestroyPs,
Link_Name => "GpiDestroyPS");
Result : Pm_Types.Long;
begin
Result := GpiDestroyPS (Ps);
return Result = 1;
end Destroy_Ps;
---------------------------------------------
procedure Destroy_Ps (Ps : in Win.Ps_Type) is
begin
if Failed_To (Destroy_Ps (Ps)) then
raise Gpi_Error;
end if;
end Destroy_Ps;
---------------------------------------------
function Move (
Ps : Win.Ps_Type;
Point : Win.Point_Type) return Boolean is
function GPIMove (
Ps : Win.Ps_Type;
Point : System.Address) return Pm_Types.Long;
pragma Import (Convention => C,
Entity => GpiMove,
Link_Name => "GpiMove");
Result : Pm_Types.Long;
begin
Result := GpiMove (
Ps => Ps,
Point => Point'Address);
return Result = 1;
end Move;
---------------------------------------------
procedure Move (
Ps : Win.Ps_Type;
Point : Win.Point_Type) is
begin
if not Move (Ps, Point) then
raise Gpi_Error;
end if;
end Move;
---------------------------------------------
function Set_Line_End (
Ps : Win.Ps_Type;
Style : Line_End_Style_Type) return Boolean is
begin
return False;
end Set_Line_End;
---------------------------------------------
procedure Set_Line_End (
Ps : in Win.Ps_Type;
Style : in Line_End_Style_Type) is
begin
null;
end Set_Line_End;
---------------------------------------------
function Query_Line_End (Ps : Win.Ps_Type)
return Line_End_Style_Type is
begin
return Line_End_Style_Type'first;
end Query_Line_End;
---------------------------------------------
function Set_Line_Join (
Ps : Win.Ps_Type;
Style : Line_Join_Style_Type) return Boolean is
begin
return False;
end Set_Line_Join;
---------------------------------------------
procedure Set_Line_Join (
Ps : in Win.Ps_Type;
Style : in Line_Join_Style_Type) is
begin
null;
end Set_Line_Join;
---------------------------------------------
function Query_Line_Join (Ps : Win.Ps_Type)
return Line_Join_Style_Type is
begin
return Line_Join_Style_Type'first;
end Query_Line_Join;
---------------------------------------------
function Line (
Ps : Win.Ps_Type;
End_Point : Win.Point_Type) return Status_Type is
function GpiLine (
Ps : Win.Ps_Type;
End_Point : System.Address) return Pm_Types.Long;
pragma Import (Convention => C,
Entity => GpiLine,
Link_Name => "GpiLine");
Result : Pm_Types.Long;
begin
Result := GpiLine (Ps => Ps,
End_Point => End_Point'Address);
return Status_Is (Result);
end Line;
---------------------------------------------
procedure Line (
Ps : Win.Ps_Type;
End_Point : Win.Point_Type) is
begin
if Error = Line (Ps, End_Point) then
raise Gpi_Error;
end if;
end Line;
---------------------------------------------
procedure Line (
Ps : Win.Ps_Type;
Start_Point : Win.Point_Type;
End_Point : Win.Point_Type) is
begin
if Failed_To (Set_Current_Position (Ps, Start_Point)) or else
Error = Line (Ps, End_Point) then
raise Gpi_Error;
end if;
end Line;
---------------------------------------------
function Box (
Ps : Win.Ps_Type;
Corner_Point : Win.Point_Type;
Outline_Style : Outline_Style_Type;
Horz_Rounding : Pm_Types.Long;
Vert_Rounding : Pm_Types.Long) return Status_Type is
function GpiBox (
Ps : Win.Ps_Type;
Outline_Style : Pm_Types.Long;
Corner_Point : System.Address;
Horz_Rounding : Pm_Types.Long;
Vert_Rounding : Pm_Types.Long) return Pm_Types.Long;
pragma Import (Convention => C,
Entity => GpiBox,
Link_Name => "GpiBox");
Result : Pm_Types.Long;
begin
Result := GpiBox (
Ps => Ps,
Corner_Point => Corner_Point'Address,
Outline_Style => Outline_Values (Outline_Style),
Horz_Rounding => Horz_Rounding,
Vert_Rounding => Vert_Rounding);
return Status_Is (Result);
end Box;
---------------------------------------------
procedure Box (
Ps : in Win.Ps_Type;
Corner_Point : in Win.Point_Type;
Outline_Style : in Outline_Style_Type;
Horz_Rounding : in Pm_Types.Long;
Vert_Rounding : in Pm_Types.Long) is
begin
if Error = Box (Ps,
Corner_Point,
Outline_Style,
Horz_Rounding,
Vert_Rounding) then
raise Gpi_Error;
end if;
end Box;
---------------------------------------------
procedure Box (
Ps : in Win.Ps_Type;
Start_Corner : in Win.Point_Type;
End_Corner : in Win.Point_Type;
Outline_Style : in Outline_Style_Type;
Horz_Rounding : in Pm_Types.Long;
Vert_Rounding : in Pm_Types.Long) is
begin
if Failed_To (Set_Current_Position (Ps, Start_Corner)) or else
Error = Box (Ps,
End_Corner,
Outline_Style,
Horz_Rounding,
Vert_Rounding) then
raise Gpi_Error;
end if;
end Box;
---------------------------------------------
function Set_Arc_Parameters (
Ps : Win.Ps_Type;
Parameters : Arc_Parameter_Type) return Boolean is
function GpiSetArcParams (
Ps : Win.Ps_Type;
Parameters : System.Address) return Pm_Types.Long;
pragma Import (Convention => C,
Entity => GpiSetArcParams,
Link_Name => "GpiSetArcParams");
Result : Pm_Types.Long;
begin
Result := GpiSetArcParams (Ps => Ps,
Parameters => Parameters'Address);
return Result = 1;
end Set_Arc_Parameters;
---------------------------------------------
procedure Set_Arc_Parameters (
Ps : in Win.Ps_Type;
Parameters : in Arc_Parameter_Type) is
begin
if not Set_Arc_Parameters (Ps, Parameters) then
raise Gpi_Error;
end if;
end Set_Arc_Parameters;
---------------------------------------------
function Query_Arc_Parameters (
Ps : Win.Ps_Type;
Parameters : Arc_Parameter_Pointer_Type)
return Boolean is
function GpiQueryArcParams (
Ps : Win.Ps_Type;
Parameters : Arc_Parameter_Pointer_Type)
return Pm_Types.Long;
pragma Import (Convention => C,
Entity => GpiQueryArcParams,
Link_Name => "GpiQueryArcParams");
Result : Pm_Types.Long;
begin
Result := GpiQueryArcParams (Ps => Ps,
Parameters => Parameters);
return Result = 1;
end Query_Arc_Parameters;
---------------------------------------------
procedure Query_Arc_Parameters (
Ps : in Win.Ps_Type;
Parameters : out Arc_Parameter_Type) is
function GpiQueryArcParams (
Ps : Win.Ps_Type;
Parameters : System.Address) return Pm_Types.Long;
pragma Import (Convention => C,
Entity => GpiQueryArcParams,
Link_Name => "GpiQueryArcParams");
Result : Pm_Types.Long;
begin
Result := GpiQueryArcParams (Ps => Ps,
Parameters => Parameters'address);
if Result /= 1 then
raise GPI_Error;
end if;
end Query_Arc_Parameters;
---------------------------------------------
function Set_Default_Arc_Parameters (
Ps : Win.Ps_Type;
Parameters : Arc_Parameter_Type) return Boolean is
function GpiSetDefArcParams (
Ps : Win.Ps_Type;
Parameters : System.Address) return Pm_Types.Long;
pragma Import (Convention => C,
Entity => GpiSetDefArcParams,
Link_Name => "GpiSetDefArcParams");
Result : Pm_Types.Long;
begin
Result := GpiSetDefArcParams (Ps => Ps,
Parameters => Parameters'Address);
return Result = 1;
end Set_Default_Arc_Parameters;
---------------------------------------------
procedure Set_Default_Arc_Parameters (
Ps : in Win.Ps_Type;
Parameters : in Arc_Parameter_Type) is
begin
if not Set_Default_Arc_Parameters (Ps, Parameters) then
raise Gpi_Error;
end if;
end Set_Default_Arc_Parameters;
---------------------------------------------
function Query_Default_Arc_Parameters (
Ps : Win.Ps_Type;
Parameters : Arc_Parameter_Pointer_Type)
return Boolean is
function GpiQueryDefArcParams (
Ps : Win.Ps_Type;
Parameters : Arc_Parameter_Pointer_Type)
return Pm_Types.Long;
pragma Import (Convention => C,
Entity => GpiQueryDefArcParams,
Link_Name => "GpiQueryDefArcParams");
Result : Pm_Types.Long;
begin
Result := GpiQueryDefArcParams (Ps => Ps,
Parameters => Parameters);
return Result = 1;
end Query_Default_Arc_Parameters;
---------------------------------------------
procedure Query_Default_Arc_Parameters (
Ps : in Win.Ps_Type;
Parameters : out Arc_Parameter_Type) is
function GpiQueryDefArcParams (
Ps : Win.Ps_Type;
Parameters : System.Address) return Pm_Types.Long;
pragma Import (Convention => C,
Entity => GpiQueryDefArcParams,
Link_Name => "GpiQueryDefArcParams");
Result : Pm_Types.Long;
begin
Result := GpiQueryDefArcParams (Ps => Ps,
Parameters => Parameters'address);
if Result /= 1 then
raise GPI_Error;
end if;
end Query_Default_Arc_Parameters;
---------------------------------------------
--GNAT BUG
function GpiFullArc (
Ps : Win.Ps_Type;
Outline_Style : Pm_Types.Long;
Multiplier : Pm_Types.Long) return Pm_Types.Long;
pragma Import (Convention => C,
Entity => GpiFullArc,
Link_Name => "GpiFullArc");
function Full_Arc (
Ps : Win.Ps_Type;
Outline_Style : Outline_Style_Type;
Multiplier : Multipler_Type) return Status_Type is
Result : Pm_Types.Long;
Mult : Pm_Types.Long;
use Pm_Types;
begin
Mult := 65_536 * Pm_Types.Long (Multiplier);
Result := GpiFullArc (Ps => Ps,
Outline_Style => Outline_Values (Outline_Style),
Multiplier => Mult);
return Status_Is (Result);
end Full_Arc;
---------------------------------------------
procedure Full_Arc (
Ps : in Win.Ps_Type;
Outline_Style : in Outline_Style_Type;
Multiplier : in Multipler_Type) is
begin
if Error = Full_Arc (Ps, Outline_Style, Multiplier) then
raise Gpi_Error;
end if;
end Full_Arc;
---------------------------------------------
procedure Full_Arc (
Ps : in Win.Ps_Type;
Center : in Win.Point_Type;
Arc_Params : in Arc_Parameter_Type;
Outline_Style : in Outline_Style_Type;
Multiplier : in Multipler_Type) is
begin
if Failed_To (Set_Current_Position (Ps, Center)) or else
Failed_To (Set_Arc_Parameters (Ps, Arc_Params)) or else
Error = Full_Arc (Ps, Outline_Style, Multiplier) then
raise Gpi_Error;
end if;
end Full_Arc;
end GPI;
