-- ----------------------------------------------------------------- --
-- --
-- This 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 software 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 library; if not, write to the --
-- Free Software Foundation, Inc., 59 Temple Place - Suite 330, --
-- Boston, MA 02111-1307, USA. --
-- --
-- ----------------------------------------------------------------- --
-- ----------------------------------------------------------------- --
-- This is a translation, to the Ada programming language, of the --
-- original C test files written by Sam Lantinga - www.libsdl.org --
-- translation made by Antonio F. Vargas - www.adapower.net/~avargas --
-- ----------------------------------------------------------------- --
-- ----------------------------------------------------------------- --
-- WARNING WARNING WARNING WARNING WARNING WARNING WARNING WARNING
-- ----------------------------------------------------------------- --
-- SERIOUS WARNING: The Ada code in this files may, at some points,
-- rely directly on pointer arithmetic which is considered very
-- unsafe and PRONE TO ERROR. The AdaSDL_Framebuffer examples are
-- more appropriate and easier to understand. They should be used in
-- replacement of this files. Please go there.
-- This file exists only for the sake of completness and to test
-- AdaSDL without the dependency of AdaSDL_Framebuffer.
-- ----------------------------------------------------------------- --
-- WARNING WARNING WARNING WARNING WARNING WARNING WARNING WARNING
-- ----------------------------------------------------------------- --
with Interfaces.C.Strings;
with Ada.Text_IO; use Ada.Text_IO;
with Ada.Float_Text_IO; use Ada.Float_Text_IO;
with Ada.Command_Line;
with Ada.Characters.Handling;
with Ada.Numerics.Discrete_Random;
with GNAT.OS_Lib;
with SDL.Types; use SDL.Types;
with SDL.Video;
with SDL.Error;
with SDL.Events;
with SDL.Quit;
with SDL.Timer;
procedure Testsprite is
package C renames Interfaces.C;
use type C.int;
use type C.double;
use type C.unsigned;
package CS renames Interfaces.C.Strings;
package CL renames Ada.Command_Line;
package CH renames Ada.Characters.Handling;
package Uint8_IO is new Ada.Text_IO.Modular_IO (Uint8);
package V renames SDL.Video;
use type V.Surface_ptr;
use type V.Palette_ptr;
use type V.Surface_Flags;
package T renames SDL.Timer;
package Er renames SDL.Error;
package Ev renames SDL.Events;
NUM_SPRITES : constant := 100;
MAX_SPEED : constant := 1;
Screen_Width : constant := 640; -- 640 800 1024
Screen_Height : constant := 480; -- 480 600 768
sprite : V.Surface_ptr;
numsprites : C.unsigned;
screen : V.Surface_ptr;
type Rects_Array_Access is access V.Rects_Array;
sprite_rects, positions, velocities : Rects_Array_Access;
sprites_visible : C.int;
use SDL.Types.Uint8_Ptrs;
-- Packages for random generation numbers
type Screen_Width_Type is range 0 .. Screen_Width - 1;
package Random_w is new Ada.Numerics.Discrete_Random (
Screen_Width_Type);
Width_Generator : Random_w.Generator;
type Screen_Height_Type is range 0 .. Screen_Height - 1;
package Random_h is new Ada.Numerics.Discrete_Random (
Screen_Height_Type);
Height_Generator : Random_h.Generator;
type Velocity_Type is range 0 .. MAX_SPEED * 2 + 1;
package Random_Velocity is new Ada.Numerics.Discrete_Random (
Velocity_Type);
Velocity_Generator : Random_Velocity.Generator;
-- ##################################
function LoadSprite (screen : V.Surface_ptr; file : String)
return C.int
is
temp : V.Surface_ptr;
begin
-- Load the sprite image
sprite := V.LoadBMP (CS.New_String(file));
if sprite = null then
Put_Line ("Couldn't load " & file & " : " & Er.Get_Error);
return -1;
end if;
-- Set transparent pixel as the pixel at (0,0)
if sprite.format.palette /= null then
V.SetColorKey (
sprite,
(V.SRCCOLORKEY or V.RLEACCEL),
Uint32 (To_Pointer (sprite.pixels).all));
end if;
-- Convert sprite to video format
temp := V.DisplayFormat(sprite);
if temp = null then
Put_Line ("Couldn't convert background: " &
CS.Value (Er.GetError));
return -1;
end if;
sprite := temp;
-- we're ready to roll. :)
return 0;
end LoadSprite;
-- ##################################
procedure MoveSprites (screen : V.Surface_ptr; background : Uint32)
is
nupdates : C.unsigned;
area : V.Rect;
type Rect_Access is access all V.Rect;
position, velocity : Rect_Access;
begin
nupdates := 0;
-- Erase all sprites if necessary
if sprites_visible /= 0 then
V.FillRect(screen, null, background);
end if;
-- Move the sprite, bounce at the wall, and draw
for i in sprite_rects'Range loop
position := positions(i)'Access;
velocity := velocities(i)'Access;
position.x := position.x + velocity.x;
if (position.x < 0) or (C.int (position.x) >= screen.w) then
velocity.x := -velocity.x;
position.x := position.x + velocity.x;
end if;
position.y := position.y + velocity.y;
if (position.y < 0) or (C.int (position.y) >= screen.h) then
velocity.y := -velocity.y;
position.y := position.y + velocity.y;
end if;
-- Blit the sprite onto the screen
area := position.all;
V.BlitSurface (sprite, null, screen, area);
sprite_rects (nupdates) := area;
nupdates := nupdates + 1;
end loop;
-- Update the screen
if (screen.flags and V.DOUBLEBUF) = V.DOUBLEBUF then
V.Flip (screen);
else
V.UpdateRects (screen, C.int (nupdates), sprite_rects.all);
end if;
sprites_visible := 1;
end MoveSprites;
-- ##################################
function FastestFlags(flags : V.Surface_Flags)
return V.Surface_Flags
is
info : V.VideoInfo_ConstPtr;
new_flags : V.Surface_Flags := flags;
begin
-- Hardware aceleration is only used in fullscreen mode
new_flags := new_flags or V.FULLSCREEN;
-- Check for various video capabilities
info := V.GetVideoInfo;
if (info.blit_hw_CC /= 0) and (info.blit_fill /= 0) then
-- We use accelerated colorkeying and color filling
new_flags := new_flags or V.HWSURFACE;
end if;
-- If we have enough video memory, and will use accelerated
-- blits directly to it, then use page flipping.
if (new_flags and V.HWSURFACE) = V.HWSURFACE then
-- Direct hardware blitting without double-buffering
-- causes really bad flickering.
if info.video_mem > Screen_Width * Screen_Height then
new_flags := new_flags or V.DOUBLEBUF;
else
new_flags := new_flags and not V.HWSURFACE;
end if;
end if;
-- Return the flags
return new_flags;
end FastestFlags;
-- ##################################
video_bpp : Uint8;
videoflags : V.Surface_Flags;
background : Uint32;
done : C.int;
event : Ev.Event;
and_then, now, frames : Uint32;
argc : Natural := CL.Argument_Count;
PollEvent_Result : C.int;
-- ##################################
begin
if SDL.Init (SDL.INIT_VIDEO) < 0 then
Put_Line ("Couldn't initialize SDL: " &
C.Strings.Value (Er.GetError));
GNAT.OS_Lib.OS_Exit (1);
end if;
SDL.Quit.atexit (SDL.SDL_Quit'Access);
numsprites := NUM_SPRITES;
videoflags := V.SWSURFACE or V.ANYFORMAT;
video_bpp := 8;
Put_Line ("Número de argumentos: " & Natural'Image (argc));
while argc > 0 loop
if (argc > 1) and then
(CL.Argument (argc - 1) = "-bpp") and then
CH.Is_Digit (CL.Argument (argc) (1)) then
declare
use Uint8_IO;
last : Positive;
begin
Get (CL.Argument (argc), video_bpp, last);
end;
videoflags := videoflags and not V.ANYFORMAT;
argc := argc - 2;
Put_Line ("-bpp" & Uint8'Image (video_bpp));
elsif CL.Argument (argc) = "-fast" then
videoflags := FastestFlags (videoflags);
argc := argc - 1;
Put_Line ("-fast");
elsif CL.Argument (argc) = "-hw" then
videoflags := videoflags xor V.DOUBLEBUF;
argc := argc -1;
Put_Line ("-hw");
elsif CL.Argument (argc) = "-fullscreen" then
videoflags := videoflags xor V.FULLSCREEN;
argc := argc - 1;
Put_Line ("-fullscreen");
elsif CH.Is_Digit (CL.Argument (argc) (1)) then
declare
package unsigned_IO is new Modular_IO (C.unsigned);
use unsigned_IO;
last : Positive;
begin
Get (CL.Argument (argc), numsprites, last);
argc := argc - 1;
Put ("numsprites: "); Put (numsprites);
New_Line;
end;
else
Put_Line ("Usage: " & CL.Command_Name & " " &
"[-bpp N] [-hw] [-flip] [-fast] " &
"[-fullscreen] [numsprites]");
GNAT.OS_Lib.OS_Exit (1);
end if;
end loop;
sprite_rects := new V.Rects_Array (0 .. numsprites - 1);
positions := new V.Rects_Array (0 .. numsprites - 1);
velocities := new V.Rects_Array (0 .. numsprites - 1);
-- Set video mode
screen := V.SetVideoMode (Screen_Width, Screen_Height,
C.int (video_bpp), videoflags);
if screen = null then
Put_Line ("Couldn't set " & Integer'Image (Screen_Width) &
"x" & Integer'Image (Screen_Height) &
" video mode: " & CS.Value (Er.GetError));
GNAT.OS_Lib.OS_Exit (1);
end if;
-- Load the sprite
if LoadSprite (screen, "icon.bmp") < 0 then
GNAT.OS_Lib.OS_Exit (1);
end if;
Random_w.Reset (Width_Generator, 17);
Random_h.Reset (Height_Generator, 13);
for i in 0 .. numsprites - 1 loop
positions (i).x := Sint16 (Random_w.Random (Width_Generator));
positions (i).y := Sint16 (Random_h.Random (Height_Generator));
positions (i).w := Uint16 (sprite.w);
positions (i).h := Uint16 (sprite.h);
velocities (i).x := 0;
velocities (i).y := 0;
while (velocities (i).x = 0) and (velocities (i).y = 0) loop
velocities (i).x := Sint16 (Random_Velocity.Random (Velocity_Generator)
- MAX_SPEED);
velocities (i).y := Sint16 (Random_Velocity.Random (Velocity_Generator)
- MAX_SPEED);
end loop;
end loop;
background := V.MapRGB (screen.format, 16#00#, 16#00#, 16#00#);
-- Print out information about our surfaces
Put_Line ("Screen is at " & Uint8'Image (screen.format.BitsPerPixel) &
" bits per pixel");
if (screen.flags and V.HWSURFACE) = V.HWSURFACE then
Put_Line ("Screen is in video memory");
else
Put_Line ("Screen is in system memory");
end if;
if (screen.flags and V.DOUBLEBUF) = V.DOUBLEBUF then
Put_Line ("Screen has double-buffering enabled");
end if;
if (sprite.flags and V.HWSURFACE) = V.HWSURFACE then
Put_Line ("Sprite is in video memory");
else
Put_Line ("Sprite in in system memory");
end if;
-- Run a sample blit to trigger blit aceleration
declare
dst : V.Rect;
begin
dst.x := 0;
dst.y := 0;
dst.w := Uint16 (sprite.w);
dst.h := Uint16 (sprite.h);
V.BlitSurface (sprite, null, screen, dst);
V.FillRect(screen, dst, background);
end;
if (sprite.flags and V.HWACCEL) = V.HWACCEL then
Put_Line ("Sprite blit uses hardware acceleration");
end if;
if (sprite.flags and V.RLEACCEL) = V.RLEACCEL then
Put_Line ("Sprite blit uses RLE acceleration");
end if;
-- Loop, blitting sprite and waiting for a keystroke
frames := 0;
and_then := T.GetTicks;
done := 0;
sprites_visible := 0;
while done = 0 loop
-- Check for events
frames := frames + 1;
loop
Ev.PollEventVP (PollEvent_Result, event);
exit when PollEvent_Result = 0;
case event.the_type is
when Ev.KEYDOWN =>
-- any keypress quits teh app
done := 1;
when Ev.QUIT =>
done := 1;
when others => null;
end case;
end loop;
MoveSprites (screen, background);
end loop;
V.FreeSurface (sprite);
-- Print out some timing information
now := T.GetTicks;
if now > and_then then
Put (Float (frames) * 1000.0 / Float (now - and_then),
3, 2, 0);
Put_Line (" frames per second");
end if;
end Testsprite;
syntax highlighted by Code2HTML, v. 0.9.1