
-- ----------------------------------------------------------------- --
--                                                                   --
-- 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;
