--
-- SHOWIMAGE: Port to the Ada programming language of a test application for the
-- the SDL image library.
--
-- The original code was written in C by Sam Lantinga http://www.libsdl.org.
--
-- This program is free software; you can redistribute it and/or modify
-- it under the terms of the GNU General Public License as published by
-- the Free Software Foundation; either version 2 of the License, or
-- (at your option) any later version.
--
-- This program 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
-- along with this program; if not, write to the Free Software
-- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
--
-- Ada code written by:
-- Antonio M. F. Vargas --
-- Ponta Delgada - Azores - Portugal --
-- E-mail: avargas@adapower.net --
-- http://www.adapower.net/~avargas --
with System;
with Interfaces.C.Strings;
with Ada.Command_Line;
with Ada.Text_IO; use Ada.Text_IO;
with GNAT.OS_Lib;
with SDL.Video;
with SDL.Types; use SDL.Types;
with SDL.Byteorder;
with SDL.Byteorder.Extra;
with SDL.Quit;
with SDL.Error;
with SDL.Events;
with SDL_Image;
procedure ShowImage is
package C renames Interfaces.C;
use type C.int;
package It renames Interfaces;
use type It.Unsigned_32;
package CL renames Ada.Command_Line;
package CS renames Interfaces.C.Strings;
package V renames SDL.Video;
use type V.Palette_ptr;
use type V.Surface_ptr;
use type V.Surface_Flags;
package Er renames SDL.Error;
package Ev renames SDL.Events;
use type Ev.Event_Type;
package IMG renames SDL_Image;
-- Draw a Gimpish background pattern to show transparency in the image
-- ======================================
procedure draw_background (screen : V.Surface_ptr) is
use Uint8_PtrOps;
use Uint8_Ptrs;
use Uint16_PtrOps;
use Uint16_Ptrs;
use Uint32_PtrOps;
use Uint32_Ptrs;
use SDL.Byteorder;
use SDL.Byteorder.Extra;
package It renames Interfaces;
dst : System.Address := screen.pixels;
bpp : C.int := C.int (screen.format.BytesPerPixel);
type col_Array is array (It.Unsigned_32 range 0 .. 1) of It.Unsigned_32;
col : col_Array;
IS_LIL_ENDIAN : boolean := BYTE_ORDER = LIL_ENDIAN;
begin
col (0) := It.Unsigned_32 (V.MapRGB (screen.format, 16#66#, 16#66#, 16#66#));
col (1) := It.Unsigned_32 (V.MapRGB (screen.format, 16#99#, 16#99#, 16#99#));
for y in It.Unsigned_32 range 0 .. It.Unsigned_32 (screen.h) - 1 loop
for x in It.Unsigned_32 range 0 .. It.Unsigned_32 (screen.w) loop
-- use an 8x8 checkboard pattern
declare
cl : It.Unsigned_32 := col (It.Shift_Right (x xor y, 3) and 1);
begin
case bpp is -- The following code is not very nice. Suggestions?
when 1 =>
Uint8_PtrOps.Pointer (
Uint8_PtrOps.Pointer (Uint8_Ptrs.To_Pointer (dst))
+ C.ptrdiff_t (x)
).all := Uint8 (cl);
when 2 =>
Uint16_PtrOps.Pointer (
Uint16_PtrOps.Pointer (Uint16_Ptrs.To_Pointer (dst))
+ C.ptrdiff_t (x)
).all := Uint16 (cl);
when 3 =>
if IS_LIL_ENDIAN then
Uint8_PtrOps.Pointer (
Uint8_PtrOps.Pointer (Uint8_Ptrs.To_Pointer (dst))
+ C.ptrdiff_t (x * 3)
).all := Uint8 (cl);
Uint8_PtrOps.Pointer (
Uint8_PtrOps.Pointer (Uint8_Ptrs.To_Pointer (dst))
+ C.ptrdiff_t (x * 3 + 1)
).all := Uint8 (It.Shift_Right (cl, 8));
Uint8_PtrOps.Pointer (
Uint8_PtrOps.Pointer (Uint8_Ptrs.To_Pointer (dst))
+ C.ptrdiff_t (x * 3 + 2)
).all := Uint8 (It.Shift_Right (cl, 16));
else
Uint8_PtrOps.Pointer (
Uint8_PtrOps.Pointer (Uint8_Ptrs.To_Pointer (dst))
+ C.ptrdiff_t (x * 3)
).all := Uint8 (It.Shift_Right (cl, 16));
Uint8_PtrOps.Pointer (
Uint8_PtrOps.Pointer (Uint8_Ptrs.To_Pointer (dst))
+ C.ptrdiff_t (x * 3 + 1)
).all := Uint8 (It.Shift_Right (cl, 8));
Uint8_PtrOps.Pointer (
Uint8_PtrOps.Pointer (Uint8_Ptrs.To_Pointer (dst))
+ C.ptrdiff_t (x * 3 + 2)
).all := Uint8 (cl);
end if;
when 4 =>
Uint32_PtrOps.Pointer (
Uint32_PtrOps.Pointer (Uint32_Ptrs.To_Pointer (dst))
+ C.ptrdiff_t (x)
).all := Uint32 (cl);
when others => null;
end case;
end;
dst := Uint8_Ptrs.To_Address (Uint8_Ptrs.Object_Pointer (
Uint8_PtrOps.Pointer (Uint8_Ptrs.To_Pointer (dst))
+ C.ptrdiff_t (screen.pitch)));
end loop;
end loop;
end draw_background;
-- ======================================
screen, image : V.Surface_ptr;
depth : C.int;
begin
-- Check command line usage
if CL.Argument_Count = 0 then
Put_Line ("Usage: " & CL.Command_Name & " <image_file>");
GNAT.OS_Lib.OS_Exit (1);
end if;
-- Initialize the SDL library
if SDL.Init (SDL.INIT_VIDEO) < 0 then
Put_Line ("Couldn't initialize SDL: " & IMG.Get_Error);
GNAT.OS_Lib.OS_Exit (255);
end if;
-- Open the image file
image := IMG.Load (CL.Argument (1));
if image = null then
Put_Line ("Couldn't load " & CL.Argument (1)& ": " & IMG.Get_Error);
SDL.SDL_Quit;
GNAT.OS_Lib.OS_Exit (2);
end if;
V.WM_Set_Caption (CL.Argument (1), "showimage");
-- Create a display for the image
depth := V.VideoModeOK (image.w, image.h, 32, V.SWSURFACE);
-- Use the deepest native mode, except that we emulate 32bpp for
-- viewing non-indexed images on 8bpp screens
if image.format.BytesPerPixel > 1 and depth = 8 then
depth := 32;
end if;
screen := V.SetVideoMode (image.w, image.h, depth, V.SWSURFACE);
if screen = null then
Put_Line ("Couldn't set "
& C.int'Image (image.w) & "x"
& C.int'Image (image.h) & "x"
& C.int'Image (depth)
& " video mode: "
& IMG.Get_Error);
SDL.SDL_Quit;
GNAT.OS_Lib.OS_Exit (3);
end if;
-- set the palette, if one exists
if image.format.palette /= null then
V.SetColors (screen, image.format.palette.colors,
0, image.format.palette.ncolors);
end if;
-- Draw a background pattern if the surface has transparency
if (image.flags and (V.SRCALPHA or V.SRCCOLORKEY)) /= 0 then
null;
end if;
-- Display the image
V.BlitSurface (image, null, screen, null);
V.UpdateRect (screen, 0, 0, 0, 0);
-- Wait for any keyboard or mouse input
for i in Ev.NOEVENT .. Ev.NUMEVENTS - 1 loop
case i is
when Ev.KEYDOWN | Ev.MOUSEBUTTONDOWN | Ev.QUIT =>
-- Valid event, keep it
null;
when others =>
-- We don't want this event
Ev.EventState (Ev.Event_Type (i), Ev.IGNORE);
end case;
end loop;
Ev.WaitEvent (null);
-- We're done!
V.FreeSurface (image);
SDL.SDL_Quit;
GNAT.OS_Lib.OS_Exit (0);
end ShowImage;
syntax highlighted by Code2HTML, v. 0.9.1