-- ----------------------------------------------------------------- --
-- --
-- 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;
with Interfaces.C.Strings;
with Lib_C;
with Ada.Text_IO; use Ada.Text_IO;
with Ada.Command_Line;
with Ada.Characters.Handling;
with GNAT.OS_Lib;
with SDL.Video;
with SDL.Error;
with SDL.Types; use SDL.Types;
with SDL.Timer;
with SDL.Quit;
procedure TestWin is
package C renames Interfaces.C;
use type C.int;
use type C.size_t;
package CS renames Interfaces.C.Strings;
package CL renames Ada.Command_Line;
package CH renames Ada.Characters.Handling;
package V renames SDL.Video;
use type V.Surface_ptr;
use type V.Surface_Flags;
use type V.Palette_ptr;
package Er renames SDL.Error;
package Tm renames SDL.Timer;
type Colors_Array_Ptr is access V.Colors_Array;
-- ======================================
procedure DrawPict (screen : V.Surface_ptr; bmpfile_name :CS.chars_ptr;
speedy : C.int; flip : C.int; nofade : C.int) is
package It renames Interfaces;
use type It.Unsigned_32;
use type CS.chars_ptr;
use V.Color_PtrOps;
bmpfile : CS.chars_ptr := bmpfile_name;
picture : V.Surface_ptr;
dest : V.Rect;
update : V.Rect;
centered : C.int;
i : C.size_t;
ncolors : C.int;
-- cmap, colors : V.Color_ptr;
cmap, colors : Colors_Array_Ptr;
begin
-- Load the image into a surface
if bmpfile = CS.Null_Ptr then
bmpfile := CS.New_String ("sample.bmp"); -- Sample image
end if;
Put_Line ("Loading picture: " & CS.Value (bmpfile));
picture := V.LoadBMP (bmpfile);
if picture = null then
Put_Line ("Couldn't load " & CS.Value (bmpfile) & ": " & Er.Get_Error);
return;
end if;
-- Set the display colors -- on a hicolor display this is a no-op
if picture.format.palette /= null then
ncolors := picture.format.palette.ncolors;
colors := new V.Colors_Array (0 .. C.size_t (ncolors) - 1);
cmap := new V.Colors_Array (0 .. C.size_t (ncolors) - 1);
colors.all := Value (Pointer (picture.format.palette.colors),
C.ptrdiff_t (ncolors));
else
-- Allocate 256 color palette
ncolors := 256;
colors := new V.Colors_Array (0 .. C.size_t (ncolors) - 1);
cmap := new V.Colors_Array (0 .. C.size_t (ncolors) - 1);
-- Set a 3,3,2 color cube
for r in Uint8 range 0 .. 7 loop
for g in Uint8 range 0 .. 7 loop
for b in Uint8 range 0 .. 3 loop
i := C.size_t (Shift_Left (r, 5)
or Shift_Left (g, 2)
or b);
colors (i).r := Shift_Left (r, 5);
colors (i).g := Shift_Left (g, 5);
colors (i).b := Shift_Left (b, 6);
end loop;
end loop;
end loop;
end if;
Put_Line ("testwin: setting colors");
declare
Result : C.int;
begin
Result := V.SetColors (screen, colors.all, 0, ncolors);
if Result = 0 and screen.format.palette /= null then
Put_Line ("Warning: Couldn't set all of the colors, but SDL will " &
"map the image");
Put_Line ("(colormap fading will suffer - try the -warp option)");
end if;
end;
-- Set the screen to black (not really necessary)
if V.LockSurface (screen) = 0 then
declare
black : Uint32;
pixels : Uint8_PtrOps.Pointer;
use Uint8_Ptrs;
use Uint8_PtrOps;
begin
black := V.MapRGB (screen.format, 0, 0, 0);
pixels := Uint8_PtrOps.Pointer (To_Pointer (screen.pixels));
for i in 0 .. screen.h - 1 loop
Lib_C.Mem_Set (To_Address (Object_Pointer (pixels)),
C.int (black),
C.size_t (screen.w)
* C.size_t (screen.format.BytesPerPixel));
pixels := pixels + C.ptrdiff_t (screen.pitch);
end loop;
V.UnlockSurface (screen);
V.UpdateRect (screen, 0, 0, 0, 0);
end;
end if;
-- Display the picture
if speedy /= 0 then
declare
displayfmt : V.Surface_ptr;
begin
Put_Line ("Converting picture");
displayfmt := V.DisplayFormat (picture);
if displayfmt = null then
Put_Line ("couldn't convert image: " & Er.Get_Error);
goto done;
end if;
V.FreeSurface (picture);
picture := displayfmt;
end;
end if;
Put ("(image surface located in ");
if (picture.flags and V.HWSURFACE) /= 0 then
Put ("video");
else
Put ("system");
end if;
Put_Line (" memory");
centered := (screen.w - picture.w) / 2;
if centered < 0 then
centered := 0;
end if;
dest.y := Sint16 ((screen.h - picture.h) / 2);
dest.w := Uint16 (picture.w);
dest.h := Uint16 (picture.h);
Put_Line ("testwin: moving image");
for i in 0 .. centered - 1 loop
dest.x := Sint16 (i);
update := dest;
if V.BlitSurface (picture, null, screen, update) < 0 then
Put_Line ("Blit failed: " & Er.Get_Error);
end if;
if flip /= 0 then
V.Flip (screen);
else
V.Update_Rect (screen, update);
end if;
end loop;
-- #ifdef SCREENSHOT
if V.SaveBMP (screen, CS.New_String ("screen.bmp")) < 0 then
Put_Line ("Couldn't save screen: " & Er.Get_Error);
end if;
-- #endif
-- #ifndef BENCHMARK_SDL
-- Let it sit there for a while
-- Tm.SDL_Delay (5 * 1000);
-- #endif
-- Fade the colormap
if nofade = 0 then
declare
maxstep : C.int;
final : V.Color;
palcolors : Colors_Array_Ptr :=
new V.Colors_Array (0 .. C.size_t (ncolors) - 1);
type cdist_Rec is
record
r, g, b : Sint16;
end record;
type cdist_Array is
array (C.size_t range <>) of cdist_Rec;
type cdist_Array_ptr is access cdist_Array;
cdist : cdist_Array_ptr :=
new cdist_Array (0 .. C.size_t (ncolors) - 1);
begin
Put_Line ("testwin: fading out ...");
cmap.all := colors.all;
maxstep := 32 - 1;
final.r := 16#FF#;
final.g := 16#00#;
final.b := 16#00#;
palcolors.all := colors.all;
for i in cdist'Range loop
cdist (i).r := Sint16 (final.r - palcolors (i).r);
cdist (i).g := Sint16 (final.g - palcolors (i).g);
cdist (i).b := Sint16 (final.b - palcolors (i).b);
end loop;
for i in 0 .. maxstep / 2 loop -- halfway fade
for count in C.size_t range 0 .. C.size_t (ncolors) - 1 loop
colors (count).r := Uint8 (
Sint16 (palcolors (count).r) + (cdist (count).r * Sint16 (i))
/ Sint16 (maxstep));
colors (count).g := Uint8 (
Sint16 (palcolors (count).g) + (cdist (count).g * Sint16 (i))
/ Sint16 (maxstep));
colors (count).b := Uint8 (
Sint16 (palcolors (count).r) + (cdist (count).b * Sint16 (i))
/ Sint16 (maxstep));
end loop;
V.SetColors (screen, colors.all, 0, ncolors);
Tm.SDL_Delay (1);
end loop;
final.r := 16#00#;
final.g := 16#00#;
final.b := 16#00#;
palcolors.all := colors.all;
for i in cdist'Range loop
cdist (i).r := Sint16 (final.r - palcolors (i).r);
cdist (i).g := Sint16 (final.g - palcolors (i).g);
cdist (i).b := Sint16 (final.b - palcolors (i).b);
end loop;
maxstep := maxstep / 2;
for i in 0 .. maxstep - 1 loop -- finish fade out
for count in C.size_t range 0 .. C.size_t (ncolors) - 1 loop
colors (count).r := Uint8 (
Sint16 (palcolors (count).r) + (cdist (count).r * Sint16 (i))
/ Sint16 (maxstep));
colors (count).g := Uint8 (
Sint16 (palcolors (count).g) + (cdist (count).g * Sint16 (i))
/ Sint16 (maxstep));
colors (count).b := Uint8 (
Sint16 (palcolors (count).r) + (cdist (count).b * Sint16 (i))
/ Sint16 (maxstep));
end loop;
V.SetColors (screen, colors.all, 0, ncolors);
Tm.SDL_Delay (1);
end loop;
for i in colors'Range loop
colors (i).r := final.r;
colors (i).g := final.g;
colors (i).b := final.b;
end loop;
V.SetColors (screen, colors.all, 0, ncolors);
Put_Line ("testwin: fading in ..");
palcolors.all := colors.all;
for i in cdist'Range loop
cdist (i).r := Sint16 (final.r - palcolors (i).r);
cdist (i).g := Sint16 (final.g - palcolors (i).g);
cdist (i).b := Sint16 (final.b - palcolors (i).b);
end loop;
for i in 0 .. maxstep - 1 loop -- 32 step fade
for count in C.size_t range 0 .. C.size_t (ncolors) - 1 loop
colors (count).r := Uint8 (
Sint16 (palcolors (count).r) + (cdist (count).r * Sint16 (i))
/ Sint16 (maxstep));
colors (count).g := Uint8 (
Sint16 (palcolors (count).g) + (cdist (count).g * Sint16 (i))
/ Sint16 (maxstep));
colors (count).b := Uint8 (
Sint16 (palcolors (count).r) + (cdist (count).b * Sint16 (i))
/ Sint16 (maxstep));
end loop;
V.SetColors (screen, colors.all, 0, ncolors);
Tm.SDL_Delay (1);
end loop;
Put_Line ("testing: fading over");
end; -- declare
end if; -- nofade = 0
<<done>>
-- Free the picture and return
V.FreeSurface (picture);
end DrawPict;
-- ======================================
package int_IO is
new Ada.Text_IO.Integer_IO (C.int);
use int_IO;
screen : V.Surface_ptr;
-- Options
speedy, flip, nofade : C.int;
the_delay : C.int;
w, h : C.int;
desired_bpp : C.int;
video_flags : V.Surface_Flags;
-- #ifdef BENCHMARK_SDL
and_then, now : Uint32;
-- #endif;
argc : Integer := CL.Argument_Count;
argv_i : Integer := 1;
bmpfile_name : CS.chars_ptr := CS.Null_Ptr;
begin
-- Set default option and check command-line
speedy := 0;
flip := 0;
nofade := 0;
the_delay := 1;
w := 640;
h := 480;
desired_bpp := 0;
video_flags := 0;
while argc > 0 loop
if CL.Argument (argv_i) = "-speedy" then
speedy := 1;
argv_i := argv_i + 1;
argc := argc - 1;
elsif CL.Argument (argv_i) = "-nofade" then
nofade := 1;
argv_i := argv_i + 1;
argc := argc - 1;
elsif (argc > 1) and then
(CL.Argument (argv_i) = "-delay") then
if CH.Is_Digit (CL.Argument (argv_i + 1) (1)) then
declare
last : Positive;
begin
Get (CL.Argument (argc), the_delay, last);
end;
argv_i := argv_i + 2;
argc := argc - 2;
else
Put_Line ("The -delay requires a numeric argument");
GNAT.OS_Lib.OS_Exit (1);
end if;
elsif (argc > 1) and then
(CL.Argument (argv_i) = "-width") then
if CH.Is_Digit (CL.Argument (argv_i + 1) (1)) then
declare
last : Positive;
begin
Get (CL.Argument (argc), w, last);
end;
argv_i := argv_i + 2;
argc := argc - 2;
else
Put_Line ("The -width requires a numeric argument");
GNAT.OS_Lib.OS_Exit (1);
end if;
elsif (argc > 1) and then
(CL.Argument (argv_i) = "-height") then
if CH.Is_Digit (CL.Argument (argv_i + 1) (1)) then
declare
last : Positive;
begin
Get (CL.Argument (argc), h, last);
end;
argv_i := argv_i + 2;
argc := argc - 2;
else
Put_Line ("The -height requires a numeric argument");
GNAT.OS_Lib.OS_Exit (1);
end if;
elsif (argc > 1) and then
(CL.Argument (argv_i) = "-bpp") then
if CH.Is_Digit (CL.Argument (argv_i + 1) (1)) then
declare
last : Positive;
begin
Get (CL.Argument (argc), desired_bpp, last);
end;
argv_i := argv_i + 2;
argc := argc - 2;
else
Put_Line ("The -bpp requires a numeric argument");
GNAT.OS_Lib.OS_Exit (1);
end if;
elsif CL.Argument (argv_i) = "-warp" then
video_flags := video_flags or V.HWPALETTE;
argv_i := argv_i + 1;
argc := argc -1;
elsif CL.Argument (argv_i) = "-hw" then
video_flags := video_flags or V.HWSURFACE;
argv_i := argv_i + 1;
argc := argc - 1;
elsif CL.Argument (argv_i) = "-flip" then
video_flags := video_flags or V.DOUBLEBUF;
argv_i := argv_i + 1;
argc := argc - 1;
elsif CL.Argument (argv_i) = "-fullscreen" then
video_flags := video_flags or V.FULLSCREEN;
argv_i := argv_i + 1;
argc := argc - 1;
elsif CL.Argument (argv_i) = "-help" then
Put_Line ("Usage: " & CL.Command_Name & " " &
"[-speedy] [-nofade] [-delay N] [-width N] [-height -N] " &
"[-bpp N] [-warp] [-hw] [-flip] [-fullscreen] [-help]");
GNAT.OS_Lib.OS_Exit (1);
else
bmpfile_name := CS.New_String (CL.Argument (argv_i));
argv_i := argv_i + 1;
argc := argc - 1;
end if;
end loop;
if SDL.Init (SDL.INIT_VIDEO) < 0 then
Put_Line ("Couldn't initialize SDL: " & Er.Get_Error);
GNAT.OS_Lib.OS_Exit (1);
end if;
-- Set video mode
screen := V.SetVideoMode (w, h,
C.int (desired_bpp), video_flags);
if screen = null then
Put_Line ("Couldn't set " & C.int'Image (w) &
"x" & C.int'Image (h) &
" video mode: " & Er.Get_Error);
GNAT.OS_Lib.OS_Exit (1);
end if;
Put_Line ("Set " & C.int'Image (screen.w) & "x"
& C.int'Image (screen.h) & "x"
& Uint8'Image (screen.format.BitsPerPixel)
& " mode");
Put ("(video surface located in ");
if (screen.flags and V.HWSURFACE) /= 0 then
Put ("video");
else
Put ("system");
end if;
Put_Line (" memory");
if (screen.flags and V.DOUBLEBUF) /= 0 then
Put_Line ("Double-buffering enabled");
flip := 1;
end if;
-- Set the window manager title bar
V.WM_SetCaption (CS.New_String ("SDL test window"), CS.New_String ("testwin"));
SDL.Quit.atexit (SDL.SDL_Quit'Access); -- Clean up on exit
-- Do all the drawing work
-- #ifdef BENCHMARK_SDL
and_then := Tm.GetTicks;
DrawPict (screen, bmpfile_name, speedy, flip, nofade);
now := Tm.GetTicks;
Put_Line ("Time: " & Uint32'Image (now - and_then) &
" milliseconds");
-- #else
-- DrawPict (screen, bmpfile_name, speedy, flip, nofade);
-- #endif
Tm.SDL_Delay (Uint32 (the_delay * 1000));
GNAT.OS_Lib.OS_Exit (0);
end TestWin;
syntax highlighted by Code2HTML, v. 0.9.1