------------------------------------------------------------------------------ -- AGAR GUI LIBRARY -- -- A G A R . S U R F A C E -- -- B o d y -- -- -- -- Copyright (c) 2018-2023 Julien Nadeau Carriere (vedge@csoft.net) -- -- -- -- Permission to use, copy, modify, and/or distribute this software for any -- -- purpose with or without fee is hereby granted, provided that the above -- -- copyright notice and this permission notice appear in all copies. -- -- -- -- THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES -- -- WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF -- -- MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR -- -- ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES -- -- WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN -- -- ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF -- -- OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. -- ------------------------------------------------------------------------------ with Agar.Error; package body Agar.Surface is procedure Pixel_Format_RGB (Format : in Pixel_Format_not_null_Access; #if AG_MODEL = AG_LARGE Bits_per_Pixel : in Positive := 64; R_Mask : in AG_Pixel := 16#000000000000ffff#; G_Mask : in AG_Pixel := 16#00000000ffff0000#; B_Mask : in AG_Pixel := 16#0000ffff00000000#) is #else Bits_per_Pixel : in Positive := 32; R_Mask : in AG_Pixel := 16#000000ff#; G_Mask : in AG_Pixel := 16#0000ff00#; B_Mask : in AG_Pixel := 16#00ff0000#) is #end if; begin AG_PixelFormatRGB (Format => Format, Bits_per_Pixel => C.int(Bits_per_Pixel), R_Mask => R_Mask, G_Mask => G_Mask, B_Mask => B_Mask); end; procedure Pixel_Format_RGBA (Format : Pixel_Format_not_null_Access; #if AG_MODEL = AG_LARGE Bits_per_Pixel : in Positive := 64; R_Mask : in AG_Pixel := 16#000000000000ffff#; G_Mask : in AG_Pixel := 16#00000000ffff0000#; B_Mask : in AG_Pixel := 16#0000ffff00000000#; A_Mask : in AG_Pixel := 16#ffff000000000000#) is #else Bits_per_Pixel : in Positive := 32; R_Mask : in Unsigned_32 := 16#000000ff#; G_Mask : in Unsigned_32 := 16#0000ff00#; B_Mask : in Unsigned_32 := 16#00ff0000#; A_Mask : in Unsigned_32 := 16#ff000000#) is #end if; begin AG_PixelFormatRGBA (Format => Format, Bits_per_Pixel => C.int(Bits_per_Pixel), R_Mask => R_Mask, G_Mask => G_Mask, B_Mask => B_Mask, A_Mask => A_Mask); end; procedure Pixel_Format_Indexed (Format : Pixel_Format_not_null_Access; Bits_per_Pixel : Positive := 8) is begin AG_PixelFormatIndexed (Format => Format, Bits_per_Pixel => C.int(Bits_per_Pixel)); end; procedure Pixel_Format_Grayscale (Format : Pixel_Format_not_null_Access; Bits_per_Pixel : Positive := 32) is begin AG_PixelFormatGrayscale (Format => Format, Bits_per_Pixel => C.int(Bits_per_Pixel)); end; -- -- Compare the contents of two Pixel formats (if both are indexed, -- then compare their palettes as well). -- --function "=" (Left, Right : Pixel_Format_Access) return Boolean is --begin -- if Left = null and Right = null then -- return True; -- end if; -- if Left = null or Right = null then -- return False; -- end if; -- return 0 = AG_PixelFormatCompare (Left, Right); --end; -- -- Create a new surface in PACKED, INDEXED or GRAYSCALE pixel format. -- -- With PACKED mode, masks can be specified optionally in the Format -- argument (if Format is null then the default RGBA masks are used). -- -- Src_Colorkey enables colorkey transparency and Src_Alpha enables -- overall per-surface alpha in blits where Surface is the source. -- GL_Texture advises that the surface is a valid OpenGL texture. -- function New_Surface (Mode : in Surface_Mode := PACKED; W,H : in Natural := 0; Bits_per_Pixel : in Positive := 32; Format : in Pixel_Format_Access := null; Src_Colorkey : in Boolean := false; Src_Alpha : in Boolean := false; GL_Texture : in Boolean := false) return Surface_Access is Flags : C.unsigned := 0; begin if Src_Colorkey then Flags := Flags or SURFACE_COLORKEY; end if; if Src_Alpha then Flags := Flags or SURFACE_ALPHA; end if; if GL_Texture then Flags := Flags or SURFACE_GL_TEXTURE; end if; if Format = null then case (Mode) is when PACKED => #if AG_MODEL = AG_LARGE case (Bits_per_Pixel) is when 64 => return AG_SurfaceRGBA (W => C.unsigned(W), H => C.unsigned(H), Bits_per_Pixel => C.unsigned(Bits_per_Pixel), Flags => Flags, R_Mask => 16#000000000000ffff#, G_Mask => 16#00000000ffff0000#, B_Mask => 16#0000ffff00000000#, A_Mask => 16#ffff000000000000#); when 48 => return AG_SurfaceRGBA (W => C.unsigned(W), H => C.unsigned(H), Bits_per_Pixel => C.unsigned(Bits_per_Pixel), Flags => Flags, R_Mask => 16#000000000000ffff#, G_Mask => 16#00000000ffff0000#, B_Mask => 16#0000ffff00000000#, A_Mask => 0); when others => null; end case; #end if; case (Bits_per_Pixel) is when 32 => return AG_SurfaceRGBA (W => C.unsigned(W), H => C.unsigned(H), Bits_per_Pixel => C.unsigned(Bits_per_Pixel), Flags => Flags, R_Mask => 16#000000ff#, G_Mask => 16#0000ff00#, B_Mask => 16#00ff0000#, A_Mask => 16#ff000000#); when 24 => return AG_SurfaceRGBA (W => C.unsigned(W), H => C.unsigned(H), Bits_per_Pixel => C.unsigned(Bits_per_Pixel), Flags => Flags, R_Mask => 16#000000ff#, G_Mask => 16#0000ff00#, B_Mask => 16#00ff0000#, A_Mask => 0); when 16 => return AG_SurfaceRGBA (W => C.unsigned(W), H => C.unsigned(H), Bits_per_Pixel => C.unsigned(Bits_per_Pixel), Flags => Flags, R_Mask => 16#000f#, G_Mask => 16#00f0#, B_Mask => 16#0f00#, A_Mask => 16#f000#); when 12 => return AG_SurfaceRGBA (W => C.unsigned(W), H => C.unsigned(H), Bits_per_Pixel => C.unsigned(Bits_per_Pixel), Flags => Flags, R_Mask => 16#000f#, G_Mask => 16#00f0#, B_Mask => 16#0f00#, A_Mask => 0); when others => null; end case; when INDEXED => return AG_SurfaceIndexed (W => C.unsigned(W), H => C.unsigned(H), Bits_per_Pixel => C.unsigned(Bits_per_Pixel), Flags => Flags); when GRAYSCALE => return AG_SurfaceGrayscale (W => C.unsigned(W), H => C.unsigned(H), Bits_per_Pixel => C.unsigned(Bits_per_Pixel), Flags => Flags); end case; -- Mode end if; -- Format = null return AG_SurfaceNew (Format => Format, W => C.unsigned(W), H => C.unsigned(H), Flags => Flags); end; -- -- Create a new surface in PACKED pixel format with RGBA masks. -- function New_Surface (W,H : in Natural := 0; Bits_per_Pixel : in Positive := 32; R_Mask : in AG_Pixel := 16#000000ff#; G_Mask : in AG_Pixel := 16#0000ff00#; B_Mask : in AG_Pixel := 16#00ff0000#; A_Mask : in AG_Pixel := 16#ff000000#; Src_Colorkey : in Boolean := false; Src_Alpha : in Boolean := false; GL_Texture : in Boolean := false) return Surface_Access is Flags : C.unsigned := 0; begin if Src_Colorkey then Flags := Flags or SURFACE_COLORKEY; end if; if Src_Alpha then Flags := Flags or SURFACE_ALPHA; end if; if GL_Texture then Flags := Flags or SURFACE_GL_TEXTURE; end if; if A_Mask /= 0 then return AG_SurfaceRGBA (W => C.unsigned(W), H => C.unsigned(H), Bits_per_Pixel => C.unsigned(Bits_per_Pixel), Flags => Flags, R_Mask => R_Mask, G_Mask => G_Mask, B_Mask => B_Mask, A_Mask => A_Mask); else return AG_SurfaceRGB (W => C.unsigned(W), H => C.unsigned(H), Bits_per_Pixel => C.unsigned(Bits_per_Pixel), Flags => Flags, R_Mask => R_Mask, G_Mask => G_Mask, B_Mask => B_Mask); end if; end New_Surface; -- -- Create a new PACKED surface (with given RGBA masks), -- and initialize its contents from existing pixel data. -- function New_Surface (Pixels : in Pixel_not_null_Access; W,H : in Natural; Bits_per_Pixel : in Positive := 32; R_Mask : in AG_Pixel := 16#000000ff#; G_Mask : in AG_Pixel := 16#0000ff00#; B_Mask : in AG_Pixel := 16#00ff0000#; A_Mask : in AG_Pixel := 16#ff000000#; Src_Colorkey : in Boolean := false; Src_Alpha : in Boolean := false; GL_Texture : in Boolean := false) return Surface_Access is S : Surface_Access; begin if A_Mask /= 0 then S := AG_SurfaceFromPixelsRGBA (Pixels => Pixels, W => C.unsigned(W), H => C.unsigned(H), Bits_per_Pixel => C.int(Bits_per_Pixel), R_Mask => R_Mask, G_Mask => G_Mask, B_Mask => B_Mask, A_Mask => A_Mask); else S := AG_SurfaceFromPixelsRGB (Pixels => Pixels, W => C.unsigned(W), H => C.unsigned(H), Bits_per_Pixel => C.int(Bits_per_Pixel), R_Mask => R_Mask, G_Mask => G_Mask, B_Mask => B_Mask); end if; if S = null then return null; end if; if Src_Colorkey then S.Flags := S.Flags or SURFACE_COLORKEY; end if; if Src_Alpha then S.Flags := S.Flags or SURFACE_ALPHA; end if; if GL_Texture then S.Flags := S.Flags or SURFACE_GL_TEXTURE; end if; return S; end New_Surface; -- -- Create a new surface by loading a BMP, PNG or JPEG image file. -- function New_Surface (File : in String; Src_Colorkey : in Boolean := false; Src_Alpha : in Boolean := false; GL_Texture : in Boolean := false) return Surface_Access is Ch_File : aliased C.char_array := C.To_C(File); S : Surface_Access; begin S := AG_SurfaceFromFile (File => CS.To_Chars_Ptr(Ch_File'Unchecked_Access)); if S = null then return null; end if; if Src_Colorkey then S.Flags := S.Flags or SURFACE_COLORKEY; end if; if Src_Alpha then S.Flags := S.Flags or SURFACE_ALPHA; end if; if GL_Texture then S.Flags := S.Flags or SURFACE_GL_TEXTURE; end if; return S; end; -- -- Return a Color from 8-bit RGBA components. -- function Color_8 (R,G,B : in Unsigned_8; A : in Unsigned_8 := 255) return AG_Color is #if AG_MODEL = AG_LARGE Color : constant AG_Color := (Unsigned_16(Float(R) / 255.0 * 65535.0), Unsigned_16(Float(G) / 255.0 * 65535.0), Unsigned_16(Float(B) / 255.0 * 65535.0), Unsigned_16(Float(A) / 255.0 * 65535.0)); #else Color : constant AG_Color := (R,G,B,A); #end if; begin return Color; end; -- -- Return an AG_Color from 16-bit RGBA components. -- function Color_16 (R,G,B : in Unsigned_16; A : in Unsigned_16 := 65535) return AG_Color is #if AG_MODEL = AG_LARGE Color : constant AG_Color := (R,G,B,A); #else Color : constant AG_Color := (Unsigned_8(Float(R) / 65535.0 * 255.0), Unsigned_8(Float(G) / 65535.0 * 255.0), Unsigned_8(Float(B) / 65535.0 * 255.0), Unsigned_8(Float(A) / 65535.0 * 255.0)); #end if; begin return Color; end; -- -- Return a Color from Hue, Saturation, Value and Alpha components. -- function Color_HSV (H,S,V : in Intensity; A : in Intensity := 1.0) return AG_Color is Color : aliased AG_Color; begin AG_HSV2Color (H => C.c_float(H), S => C.c_float(S), V => C.c_float(V), Color => Color'Unchecked_Access); #if AG_MODEL = AG_LARGE Color.A := AG_Component(A * 65535.0); #else Color.A := AG_Component(A * 255.0); #end if; return Color; end; -- -- Return a native component offset amount for a given 8-bit component. -- function Component_Offset_8 (X : in Unsigned_8) return AG_Component is begin #if AG_MODEL = AG_LARGE return AG_Component(Float(X) / 255.0 * 65535.0); #else return AG_Component(X); #end if; end; -- -- Return a native component offset amount for a given 16-bit component. -- function Component_Offset_16 (X : in Unsigned_16) return AG_Component is begin #if AG_MODEL = AG_LARGE return AG_Component(X); #else return AG_Component(Float(X) / 65535.0 * 255.0); #end if; end; -- -- Set a color palette entry of an Indexed surface (AG_Color argument) -- procedure Set_Color (Surface : in Surface_not_null_Access; Index : in Natural; Color : in AG_Color) is C_Color : aliased AG_Color := Color; begin AG_SurfaceSetColors (Surface => Surface, Color => C_Color'Unchecked_Access, Offset => C.unsigned(Index), Count => 1); end; -- -- Set a color palette entry of an Indexed surface (AG_Color access argument) -- procedure Set_Color (Surface : in Surface_not_null_Access; Index : in Natural; Color : in Color_not_null_Access) is begin AG_SurfaceSetColors (Surface => Surface, Color => Color, Offset => C.unsigned(Index), Count => 1); end; -- -- Copy a Source surface (or a region of its pixels) to a Target surface -- which can be of a different format. Handle format conversion, clipping -- and blending according to the pixel formats of the surfaces (and their -- Colorkey and Src_Alpha settings). -- procedure Blit_Surface (Source : in Surface_not_null_Access; Src_Rect : in Rect_access := null; Target : in Surface_not_null_Access; Dst_X : in Natural := 0; Dst_Y : in Natural := 0) is begin AG_SurfaceBlit (Source => Source, Src_Rect => Src_Rect, Target => Target, X => C.int(Dst_X), Y => C.int(Dst_Y)); end; -- -- Change the dimensions of a surface without scaling its contents. Pixel -- data is reallocated (if growing the surface, then then new pixels are -- left uninitialized). -- function Resize_Surface (Surface : in Surface_not_null_Access; W,H : in Natural) return Boolean is begin return 0 = AG_SurfaceResize (Surface => Surface, W => C.unsigned(W), H => C.unsigned(H)); end; procedure Resize_Surface (Surface : in Surface_not_null_Access; W,H : in Natural) is Result : C.int; begin Result := AG_SurfaceResize (Surface => Surface, W => C.unsigned(W), H => C.unsigned(H)); if Result /= 0 then raise Program_Error with Agar.Error.Get_Error; end if; end; -- -- Export the surface to a BMP, PNG or JPEG image file. -- function Export_Surface (Surface : in Surface_not_null_Access; File : in String) return Boolean is Ch_File : aliased C.char_array := C.To_C(File); begin return 0 = AG_SurfaceExportFile (Surface => Surface, File => CS.To_Chars_Ptr(Ch_File'Unchecked_Access)); end; -- -- Export the surface to a Windows bitmap image file. -- function Export_BMP (Surface : in Surface_not_null_Access; File : in String := "output.bmp") return Boolean is Ch_File : aliased C.char_array := C.To_C(File); begin return 0 = AG_SurfaceExportBMP (Surface => Surface, File => CS.To_Chars_Ptr(Ch_File'Unchecked_Access)); end; -- -- Export the surface to a PNG image file. -- function Export_PNG (Surface : in Surface_not_null_Access; File : in String := "output.png"; Adam7 : in Boolean := false) return Boolean is Ch_File : aliased C.char_array := C.To_C(File); Flags : C.unsigned := 0; begin if Adam7 then Flags := EXPORT_PNG_ADAM7; end if; return 0 = AG_SurfaceExportPNG (Surface => Surface, File => CS.To_Chars_Ptr(Ch_File'Unchecked_Access), Flags => Flags); end; -- -- Export the surface to a JPEG image file. -- function Export_JPEG (Surface : in Surface_not_null_Access; File : in String := "output.jpg"; Quality : in JPEG_Quality := 100; Method : in JPEG_Method := JDCT_ISLOW) return Boolean is Ch_File : aliased C.char_array := C.To_C(File); Flags : C.unsigned := 0; begin case (Method) is when JDCT_ISLOW => Flags := EXPORT_JPEG_JDCT_ISLOW; when JDCT_IFAST => Flags := EXPORT_JPEG_JDCT_IFAST; when JDCT_FLOAT => Flags := EXPORT_JPEG_JDCT_FLOAT; end case; return 0 = AG_SurfaceExportJPEG (Surface => Surface, File => CS.To_Chars_Ptr(Ch_File'Unchecked_Access), Quality => C.unsigned(Quality), Flags => Flags); end; -- -- Blend a target pixel against a specified color. The target pixel's -- alpha component is computed according to Func (by pixel address). -- procedure Blend_Pixel (Surface : in Surface_not_null_Access; Pixel : in Pixel_not_null_Access; Color : in Color_not_null_Access) is begin AG_SurfaceBlend_At (Surface => Surface, Pixel => Pixel, Color => Color); end; -- -- Blend a target pixel against a specified color. The target pixel's -- alpha component is computed according to Func (by X,Y coordinates). -- procedure Blend_Pixel (Surface : in Surface_not_null_Access; X,Y : in Natural; Color : in Color_not_null_Access) is begin AG_SurfaceBlend (Surface => Surface, X => C.int(X), Y => C.int(Y), Color => Color); end; -- -- Return the native-width packed pixel corresponding to an AG_Color -- (under the pixel format of Surface). -- function Map_Pixel (Surface : in Surface_not_null_Access; Color : in AG_Color) return AG_Pixel is C_Color : aliased AG_Color := Color; begin #if AG_MODEL = AG_LARGE return AG_MapPixel64 (Format => Surface.Format'Access, Color => C_Color'Unchecked_Access); #else return AG_MapPixel32 (Format => Surface.Format'Access, Color => C_Color'Unchecked_Access); #end if; end; -- -- Return the native-width packed pixel corresponding to an AG_Color -- (under the specified pixel format). -- function Map_Pixel (Format : in Pixel_Format_not_null_Access; Color : in AG_Color) return AG_Pixel is C_Color : aliased AG_Color := Color; begin #if AG_MODEL = AG_LARGE return AG_MapPixel64 (Format => Format, Color => C_Color'Unchecked_Access); #else return AG_MapPixel32 (Format => Format, Color => C_Color'Unchecked_Access); #end if; end; -- -- Return the native-width packed pixel corresponding to an AG_Color -- (under the pixel format of Surface). -- function Map_Pixel (Surface : in Surface_not_null_Access; Color : in Color_not_null_access) return AG_Pixel is begin #if AG_MODEL = AG_LARGE return AG_MapPixel64 (Format => Surface.Format'Access, Color => Color); #else return AG_MapPixel32 (Format => Surface.Format'Access, Color => Color); #end if; end; -- -- Return a new surface generated by scaling an Input surface to specified -- dimensions. Function form may fail and return null. -- function Scale_Surface (Surface : in Surface_not_null_Access; W,H : in Natural) return Surface_Access is begin return AG_SurfaceScale (Surface => Surface, W => C.unsigned(W), H => C.unsigned(H), Flags => C.unsigned(0)); end; -- -- Return a new surface generated by scaling an Input surface to specified -- dimensions. Procedure form raises fatal exception on failure. -- procedure Scale_Surface (Original : in Surface_not_null_Access; W,H : in Natural; Scaled : out Surface_not_null_Access) is Result : Surface_Access; begin Result := AG_SurfaceScale (Surface => Original, W => C.unsigned(W), H => C.unsigned(H), Flags => C.unsigned(0)); if Result = null then raise Program_Error with Agar.Error.Get_Error; end if; Scaled := Result; end; -- -- Fill a rectangle of pixels with a specified color (AG_Color argument). -- procedure Fill_Rect (Surface : in Surface_not_null_Access; Rect : in Rect_Access := null; Color : in AG_Color) is C_Color : aliased AG_Color := Color; begin AG_FillRect (Surface => Surface, Rect => Rect, Color => C_Color'Unchecked_Access); end; -- -- Extract a native-width packed pixel from a surface (by coordinates). -- function Get_Pixel (Surface : in Surface_not_null_Access; X,Y : in Natural) return AG_Pixel is begin #if AG_MODEL = AG_LARGE return AG_SurfaceGet64 (Surface => Surface, X => C.int(X), Y => C.int(Y)); #else return AG_SurfaceGet32 (Surface => Surface, X => C.int(X), Y => C.int(Y)); #end if; end; -- -- Extract a 32-bit packed pixel from a surface (by coordinates). -- function Get_Pixel_32 (Surface : in Surface_not_null_Access; X,Y : in Natural) return Unsigned_32 is begin return AG_SurfaceGet32 (Surface => Surface, X => C.int(X), Y => C.int(Y)); end; #if AG_MODEL = AG_LARGE -- -- Extract a 64-bit packed pixel from a surface (by coordinates). -- function Get_Pixel_64 (Surface : in Surface_not_null_Access; X,Y : in Natural) return Unsigned_64 is begin return AG_SurfaceGet64 (Surface => Surface, X => C.int(X), Y => C.int(Y)); end; #end if; -- -- Set a native-width packed pixel in a surface (by coordinates). -- procedure Put_Pixel (Surface : in Surface_not_null_Access; X,Y : in Natural; Pixel : in AG_Pixel; Clipping : in Boolean := true) is begin if Clipping then if C.int(X) < Surface.Clip_Rect.X or C.int(Y) < Surface.Clip_Rect.Y or C.int(X) >= Surface.Clip_Rect.X+Surface.Clip_Rect.W or C.int(Y) >= Surface.Clip_Rect.Y+Surface.Clip_Rect.H then return; end if; end if; #if AG_MODEL = AG_LARGE AG_SurfacePut64 (Surface => Surface, X => C.int(X), Y => C.int(Y), Pixel => Pixel); #else AG_SurfacePut32 (Surface => Surface, X => C.int(X), Y => C.int(Y), Pixel => Pixel); #end if; end; -- -- Set a 32-bit packed pixel in a surface (by coordinates). -- procedure Put_Pixel_32 (Surface : in Surface_not_null_Access; X,Y : in Natural; Pixel : in Unsigned_32; Clipping : in Boolean := true) is begin if Clipping then if C.int(X) < Surface.Clip_Rect.X or C.int(Y) < Surface.Clip_Rect.Y or C.int(X) >= Surface.Clip_Rect.X+Surface.Clip_Rect.W or C.int(Y) >= Surface.Clip_Rect.Y+Surface.Clip_Rect.H then return; end if; end if; AG_SurfacePut32 (Surface => Surface, X => C.int(X), Y => C.int(Y), Pixel => Pixel); end; #if AG_MODEL = AG_LARGE -- -- Set a 64-bit packed pixel in a surface (by coordinates). -- procedure Put_Pixel_64 (Surface : in Surface_not_null_Access; X,Y : in Natural; Pixel : in Unsigned_64; Clipping : in Boolean := true) is begin if Clipping then if C.int(X) < Surface.Clip_Rect.X or C.int(Y) < Surface.Clip_Rect.Y or C.int(X) >= Surface.Clip_Rect.X+Surface.Clip_Rect.W or C.int(Y) >= Surface.Clip_Rect.Y+Surface.Clip_Rect.H then return; end if; end if; AG_SurfacePut64 (Surface => Surface, X => C.int(X), Y => C.int(Y), Pixel => Pixel); end; #end if; procedure Unpack_Pixel (Pixel : in AG_Pixel; Format : in Pixel_Format_not_null_Access; R,G,B,A : out AG_Component) is Color : aliased AG_Color; begin #if AG_MODEL = AG_LARGE AG_GetColor64 (Color => Color'Unchecked_Access, Pixel => Pixel, Format => Format); #else AG_GetColor32 (Color => Color'Unchecked_Access, Pixel => Pixel, Format => Format); #end if; R := Color.R; G := Color.G; B := Color.B; A := Color.A; end; -- -- Set source colorkey flag and surface colorkey value. -- procedure Set_Colorkey (Surface : in Surface_not_null_Access; Enable : in Boolean := false; Colorkey : in AG_Pixel := 0) is begin if (Enable) then Surface.Flags := Surface.Flags or SURFACE_COLORKEY; else Surface.Flags := Surface.Flags and not SURFACE_COLORKEY; end if; Surface.Colorkey := Colorkey; end; -- -- Get surface clipping rectangle. -- procedure Get_Clipping_Rect (Surface : in Surface_not_null_Access; X,Y,W,H : out Natural) is begin X := Natural(Surface.Clip_Rect.X); Y := Natural(Surface.Clip_Rect.Y); W := Natural(Surface.Clip_Rect.W); H := Natural(Surface.Clip_Rect.H); end; procedure Set_Clipping_Rect (Surface : in Surface_not_null_Access; X,Y,W,H : in Natural) is begin Surface.Clip_Rect.X := C.int(X); Surface.Clip_Rect.Y := C.int(Y); Surface.Clip_Rect.W := C.int(W); Surface.Clip_Rect.H := C.int(H); end; end Agar.Surface;