-- ----------------------------------------------------------------- --
-- --
-- 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 Ada.Command_Line;
with Ada.Text_IO; use Ada.Text_IO;
with Ada.Float_Text_IO; use Ada.Float_Text_IO;
with Ada.Numerics.Generic_Elementary_Functions;
with GNAT.OS_Lib; use GNAT.OS_Lib;
with SDL.Quit;
with SDL.Error;
with SDL.Types; use SDL.Types;
with SDL.Timer;
with SDL.Events;
with TestPalette_Sprogs; use TestPalette_Sprogs;
procedure TestPalette is
-- ======================================
package It renames Interfaces;
use type It.Unsigned_32;
package C renames Interfaces.C;
use type C.int;
use type C.size_t;
use type C.unsigned;
use type C.C_float;
package CL renames Ada.Command_Line;
package Er renames SDL.Error;
package Ev renames SDL.Events;
use type Ev.Event_Type;
package T renames SDL.Timer;
use type V.Surface_Flags;
use type V.Surface_ptr;
use Random_Integer;
use V.Color_PtrOps;
package M is new Ada.Numerics.Generic_Elementary_Functions (C.C_float);
screen, bg : V.Surface_ptr;
type boat_Array is array (0 .. 1) of V.Surface_ptr;
boat : boat_Array;
vidflags : V.Surface_Flags := 0;
start : C.unsigned;
fade_max : C.int := 400;
fade_level, fade_dir : C.int;
boatcols, frames, red : C.int;
type boats_Array is array (C.unsigned range 0 .. NBOATS - 1) of C.int;
boatx, boaty, boatdir : boats_Array;
gamma_fade : C.int := 0;
gamma_ramp : C.int := 0;
argc : Integer := CL.Argument_Count;
begin
if SDL.Init (SDL.INIT_VIDEO) < 0 then
sdlerr ("initializing SDL");
end if;
SDL.Quit.atexit (SDL.SDL_Quit'Access);
while argc > 0 loop
if CL.Argument (argc) = "-hw" then
vidflags := vidflags or V.HWSURFACE;
argc := argc - 1;
elsif CL.Argument (argc) = "-fullscreen" then
vidflags := vidflags or V.FULLSCREEN;
argc := argc - 1;
elsif CL.Argument (argc) = "-nofade" then
fade_max := 1;
argc := argc - 1;
elsif CL.Argument (argc) = "-gamma" then
gamma_fade := 1;
argc := argc - 1;
elsif CL.Argument (argc) = "-gammaramp" then
gamma_ramp := 1;
argc := argc - 1;
else
Put_Line ("Usage: testpalette" &
"[-hw] [-fullscreen] [-nofade] [-gamma] " &
"[-gammaramp]");
GNAT.OS_Lib.OS_Exit (1);
end if;
end loop;
-- Ask explicitly for 8bpp and a hardware palette
screen := V.SetVideoMode (SCRW, SCRH, 8, vidflags or V.HWPALETTE);
if screen = null then
Put_Line ("error setting " & Integer'Image (SCRW) & " " &
Integer'Image (SCRH) & " " & Er.Get_Error);
GNAT.OS_Lib.OS_Exit (1);
end if;
boat (0) := V.LoadBMP (CS.New_String ("sail.bmp"));
if boat (0) = null then
sdlerr ("loading sail.bmp");
end if;
-- We've chosen magenta (#ff00ff) as colour key for the boat
V.SetColorKey (boat (0), V.SRCCOLORKEY or V.RLEACCEL,
V.MapRGB (boat (0).format, 16#FF#, 16#00#, 16#FF#));
boatcols := boat (0).format.palette.ncolors;
boat (1) := hflip (boat (0));
V.SetColorKey (boat (1), V.SRCCOLORKEY or V.RLEACCEL,
V.MapRGB (boat (1).format, 16#FF#, 16#00#, 16#FF#));
-- First set the physical screen palette to black, so the user won't
-- see our initial drawing on the screen.
cmap := (others => (0,0,0,0));
V.SetPalette (screen, V.PHYSPAL, cmap, C.int(cmap'First), C.int(cmap'Length));
-- Proper palette management is important when playing games with the
-- colormap. We have divided the palette as follows:
--
-- index 0..(boatcols-1): used for the boat
-- index boatcols..(boatcols+63): used for the waves
V.SetPalette (screen, V.LOGPAL,
boat (0).format.palette.colors, 0, boatcols);
V.SetPalette (screen, V.LOGPAL, wavemap (0)'Access, boatcols, 64);
-- Now the logical screen palette is set, and will remain unchanged.
-- The boats already have the same palette so fast blits can be used.
V.Color_PtrOps.Copy_Array (Pointer (screen.format.palette.colors),
cmap (0)'Access,
256);
-- save the index of the red colour for later
red := C.int (V.MapRGB (screen.format, 16#FF#, 16#00#, 16#00#));
bg := make_bg (screen, boatcols); -- make a nice wavy background surface
-- initial screen contents
if V.BlitSurface (bg, null, screen, null) < 0 then
sdlerr ("blitting background to screen");
end if; -- actually put the background on screen
V.Flip (screen); -- actually put the background on screen
-- determine initial boat placements
for i in C.unsigned range 0 .. NBOATS - 1 loop
boatx (i) := (C.int (Random (Integer_Generator))
mod (SCRW + boat (0).w)) - boat (0).w;
boaty (i) := C.int (i) * (SCRH - boat (0).h) / (NBOATS - 1);
boatdir (i) := C.int (
It.Shift_Right (
It.Unsigned_32 (Random (Integer_Generator)),
5)
and 1)
* 2 - 1;
end loop;
start := C.unsigned (T.GetTicks);
frames := 0;
fade_dir := 1;
fade_level := 0;
loop
declare
e : aliased Ev.Event;
updates : V.Rects_Array (0 .. NBOATS - 1);
r : aliased V.Rect;
redphase : C.int;
begin
-- A small event loop: just exit on any key or mouse button event
while Ev.PollEvent (e'Access) /= 0 loop
if (e.the_type = Ev.KEYDOWN) or (e.the_type = Ev.QUIT)
or (e.the_type = Ev.MOUSEBUTTONDOWN) then
if fade_dir < 0 then
fade_level := 0;
end if;
fade_dir := -1;
end if;
end loop;
-- move boats
for i in C.unsigned range 0 .. NBOATS - 1 loop
declare
old_x : C.int := boatx (i);
begin
-- update boat position
boatx (i) := boatx (i) + boatdir (i) * SPEED;
if (boatx (i) <= -boat (0).w) or (boatx (i) >= SCRW) then
boatdir (i) := -boatdir (i);
end if;
-- paint over old boat position
r.x := Sint16 (old_x);
r.y := Sint16 (boaty (i));
r.w := Uint16 (boat (0).w);
r.h := Uint16 (boat (0).h);
if V.BlitSurface (bg, r,
screen, r) < 0 then
sdlerr ("blitting background");
end if;
-- construct update rectangle (bounding box of old and new pos)
updates (i).x := Sint16 (C.int'Min (old_x, boatx (i)));
updates (i).y := Sint16 (boaty (i));
updates (i).w := Uint16 (boat (0).w + SPEED);
updates (i).h := Uint16 (boat (0).h);
-- clip update rectangle to screen
if updates (i).x < 0 then
updates (i).w := Uint16 (
Integer(updates (i).w) + Integer (updates (i).x));
updates (i).x := 0;
end if;
if C.int (updates (i).x) + C.int (updates (i).w) > SCRW then
updates (i).w := Uint16 (SCRW - updates (i).x);
end if;
end; -- declare
end loop; -- move boats
for i in C.unsigned range 0 .. NBOATS - 1 loop
-- paint boat on new position
r.x := Sint16 (boatx (i));
r.y := Sint16 (boaty (i));
if V.BlitSurface (boat (Integer((boatdir (i) + 1) / 2)),
null,
screen,
r) < 0 then
sdlerr ("blitting boat");
end if;
end loop;
-- cycle wave palette
for i in 0 .. 63 loop
cmap (C.size_t (boatcols)
+ C.size_t ((It.Unsigned_32 (C.int (i) + frames)
and 63)))
:= wavemap (i);
end loop;
if fade_dir /= 0 then
-- Fade the entire palette in/out
fade_level := fade_level + fade_dir;
if gamma_fade /= 0 then
-- Fade linearly in gamma level (lousy)
declare
level : C.C_float := C.C_float (fade_level) / C.C_float (fade_max);
begin
if V.SetGamma (level, level, level) < 0 then
sdlerr ("setting gamma");
end if;
end;
elsif gamma_ramp /= 0 then
-- Fade using gamma ramp (better)
declare
ramp : V.ramp_Array;
begin
for i in Natural range 0 .. 255 loop
ramp (i) := Uint16 (
It.Shift_Left (
It.Unsigned_32 (C.int (i) * fade_level / fade_max),
8));
end loop;
if V.SetGammaRamp (ramp, ramp, ramp) < 0 then
sdlerr ("setting gamma ramp");
end if;
end; -- declare
else
-- Fade using direct palette manipulation (best)
V.Color_PtrOps.Copy_Array (
Pointer (screen.format.palette.colors),
cmap (0)'Access,
C.ptrdiff_t (boatcols));
for i in C.size_t range 0 .. C.size_t (boatcols + 63) loop
cmap (i).r := Uint8 (C.C_float (cmap (i).r)
* C.C_float (fade_level) / C.C_float (fade_max));
cmap (i).g := Uint8 (C.C_float (cmap (i).g)
* C.C_float (fade_level) / C.C_float (fade_max));
cmap (i).b := Uint8 (C.C_float (cmap (i).b)
* C.C_float (fade_level) / C.C_float (fade_max));
end loop;
end if;
if fade_level = fade_max then
fade_dir := 0;
end if;
end if;
-- pulse the red colour (done after the fade, for a night effect)
redphase := frames mod 64;
cmap (C.size_t (red)).r := Uint8 (
C.C_float (255)
* M.Sin (C.C_float (redphase)
* C.C_float (Ada.Numerics.Pi)
/ C.C_float (64)));
V.SetPalette (screen, V.PHYSPAL, cmap (0)'Access, 0, boatcols + 64);
-- update changed ares of the screen
V.UpdateRects (screen, updates'Length, updates);
frames := frames + 1;
exit when fade_level <= 0;
end;
end loop;
Put (C.int'Image (frames) & " frames, ");
Put (Float (1000.0) * Float (frames)
/ Float (T.GetTicks - Uint32 (start))
,3, 2, 0);
Put_Line (" fps");
end TestPalette;
syntax highlighted by Code2HTML, v. 0.9.1