-- ----------------------------------------------------------------- -- -- -- -- 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 -- -- ----------------------------------------------------------------- -- with Interfaces.C.Strings; with Ada.Numerics.Generic_Elementary_Functions; 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 GNAT.OS_Lib; with SDL.Types; use SDL.Types; with SDL.Video; with SDL.Timer; with SDL.Error; with SDL.Events; with SDL.Mouse; with SDL.Quit; with Lib_C; with SDL_Framebuffer; procedure Testalpha is package C renames Interfaces.C; use type C.int; package CS renames Interfaces.C.Strings; package Uint8_IO is new Modular_IO (Uint8); package CL renames Ada.Command_Line; package CH renames Ada.Characters.Handling; use type SDL.Init_Flags; package V renames SDL.Video; use type V.Surface_Flags; use type V.Surface_ptr; use type V.Palette_ptr; package T renames SDL.Timer; package Er renames SDL.Error; package Ev renames SDL.Events; package M renames SDL.Mouse; package Fb renames SDL_Framebuffer; Screen_Width : constant := 800; -- 1024; -- 640; Screen_Height : constant := 600; -- 768; -- 480; package AN is new Ada.Numerics.Generic_Elementary_Functions (float); FRAME_TICKS : constant := 1000 / 30; -- =========================================================== -- Create a "light" -- a yellowish surface with variable alpha function CreateLight (screen : V.Surface_ptr; radius : C.int) return V.Surface_ptr is trans, alphamask : Uint8; the_range, addition : C.int; xdist, ydist : C.int; skip : Uint16; pixel : Uint32; light : V.Surface_ptr; -- buf : Uint16_ptrs.Object_Pointer; use type Interfaces.Unsigned_32; buf : Fb.Framebuffer_32bPointer; begin -- Create a 16 (4/4/4/4) bpp square with a full 4-bit alpha channel -- Note: this isn't any faster than a 32 bit alpha surface -- alphamask := 16#0000000F#; -- light := V.CreateRGBSurface (V.SWSURFACE, 2*radius, 2*radius, 16, -- 16#0000F000#, 16#00000F00#, alphamask); -- Create a 32 (8/8/8/8) bpp square with a full 8-bit alpha channel alphamask := 16#000000FF#; light := V.CreateRGBSurface (V.SWSURFACE, 2 * radius, 2 * radius, 32, 16#FF000000#, 16#00FF0000#, 16#0000FF00#, Uint32(alphamask)); if light = null then Put_Line ("Couldn't create light: " & Er.Get_Error); return null; end if; -- Fill with a light a yellow-orange color skip :=Fb.Pitch_Gap (light); buf := Fb.Get_Framebuffer (light); -- Get a transparent pixel value - we'll add alpha later pixel := V.MapRGBA (light.format, 16#FF#, 16#DD#, 16#88#, 0); for y in 0 .. light.h - 1 loop for x in 0 .. light.w - 1 loop buf.all := pixel; buf := Increment (buf, 1); end loop; buf := Increment (buf, Natural (skip)); end loop; buf := Fb.Get_Framebuffer (light); for y in 0 .. light.h - 1 loop for x in 0 .. light.w - 1 loop -- Slow distance formula (from center of light) xdist := x - (light.w / 2); ydist := y - (light.h / 2); the_range := C.int ( AN.Sqrt (float (xdist**2 + ydist**2))); -- Scale distance to range of transparency (0-255) if the_range > radius then trans := alphamask; else -- Increasing transparency with distance trans := Uint8 ( float (the_range * C.int (alphamask)) / float (radius)); -- Lights are very transparent addition := C.int (float (alphamask + 1) / 8.0); if C.int (trans) + addition > C.int (alphamask) then trans := alphamask; else trans := trans + Uint8 (addition); end if; end if; -- We set the alpha component as the right N bits buf.all := Uint32 ( Interfaces.Unsigned_32 (buf.all) or Interfaces.Unsigned_32 (255 - trans)); buf := Increment (buf, 1); end loop; buf := Increment (buf, Natural (skip)); end loop; -- Enable RLE acceleration of this alpha surface V.SetAlpha (light, V.SRCALPHA or V.RLEACCEL, 0); -- we're done! return light; end CreateLight; -- =========================================================== flashes : Uint32 := 0; flashtime : Uint32 := 0; -- =========================================================== procedure FlashLight (screen : V.Surface_ptr; light : V.Surface_ptr; x, y : Uint16) is position : V.Rect; ticks1 : Uint32; ticks2 : Uint32; begin -- Easy, center light position.x := Sint16 (x - Uint16 (light.w / 2)); position.y := Sint16 (y - Uint16 (light.h / 2)); position.w := Uint16 (light.w); position.h := Uint16 (light.h); ticks1 := T.GetTicks; V.BlitSurface(light, null, screen, position); ticks2 := T.GetTicks; V.Update_Rect(screen, position); flashes := flashes + 1; -- Update time spend doing alpha blitting flashtime := flashtime + (ticks2 - ticks1); end FlashLight; -- =========================================================== sprite_visible : C.int := 0; sprite : V.Surface_ptr; backing : V.Surface_ptr; position : V.Rect; x_vel, y_vel : C.int; alpha_vel : C.int; -- =========================================================== function LoadSprite (screen : V.Surface_ptr; file : String) return C.int is converted : V.Surface_ptr; begin -- Load the sprite image sprite := V.LoadBMP (file); if sprite = null then Put_Line ("Couldn't load " & file & Er.Get_Error); return -1; end if; -- set transparent pixel as the pixel as (0,0) if sprite.format.palette /= null then V.SetColorKey (sprite, V.SRCCOLORKEY, Fb.Get_Framebuffer( sprite).all); end if; -- Convert sprite to video format converted := V.DisplayFormat (sprite); V.FreeSurface (sprite); if converted = null then Put_Line ("Couldn't convert background: " & Er.Get_Error); return -1; end if; sprite := converted; -- Create the background backing := V.CreateRGBSurface ( V.SWSURFACE, sprite.w, sprite.h, 8, 0, 0, 0, 0); if backing = null then V.FreeSurface (sprite); return -1; end if; -- Create background to video format converted := V.DisplayFormat (backing); V.FreeSurface (backing); if converted = null then Put_Line ("Couldn't convert background: " & Er.Get_Error); V.FreeSurface (sprite); return -1; end if; backing := converted; -- Set the initial position of the sprite position.x := Sint16 (screen.w - sprite.w) / 2; position.y := Sint16 (screen.h - sprite.h) / 2; position.w := Uint16 (sprite.w); position.h := Uint16 (sprite.h); x_vel := 0; y_vel := 0; alpha_vel := 1; -- we're ready to roll return 0; end LoadSprite; -- =========================================================== procedure AttractSprite (x : Uint16; y : Uint16) is begin x_vel := (C.int (x) - C.int (position.x)) / 10; y_vel := (C.int (y) - C.int (position.y)) / 10; end AttractSprite; -- =========================================================== procedure MoveSprite (screen : V.Surface_ptr; light : V.Surface_ptr) is updates : V.Rects_Array (0 .. 1); alpha : Uint8; begin -- Erase the sprite if it was visible; if sprite_visible /= 0 then updates (0) := position; V.BlitSurface (backing, null, screen, updates (0)); else -- updates (0).x := 0; updates (0).y := 0; -- updates (0).w := 0; updates (0).h := 0; updates (0) := (0, 0, 0, 0); sprite_visible := 1; end if; -- Since the sprite is off the screen, we can do other drawing -- without being overwriten by the saved area behing the sprite if light /= null then declare x, y : C.int; State : M.Mouse_State; begin M.Get_Mouse_State (State, x, y); FlashLight (screen, light, Uint16 (x), Uint16 (y)); end; end if; -- Move the sprite, bounce at the wall position.x := position.x + Sint16 (x_vel); if (position.x < 0) or (C.int (position.x) >= screen.w) then x_vel := -x_vel; position.x := position.x + Sint16 (x_vel); end if; position.y := position.y + Sint16 (y_vel); if (position.y < 0) or (C.int (position.y) >= screen.h) then y_vel := -y_vel; position.y := position.y + Sint16 (y_vel); end if; -- Update transparency (fade in and out) alpha := sprite.format.alpha; if (C.int (alpha) + alpha_vel) < 0 then alpha_vel := -alpha_vel; elsif (C.int (alpha) + alpha_vel) > 255 then alpha_vel := -alpha_vel; end if; V.SetAlpha (sprite, V.SRCALPHA, alpha + Uint8 (alpha_vel)); -- Save the area behind the sprite updates (1) := position; V.BlitSurface (screen, updates (1), backing, null); -- Blit the sprite onto the screen updates (1) := position; V.BlitSurface (sprite, null, screen, updates (1)); -- Make it so! V.UpdateRects(screen, updates'Length, updates); end MoveSprite; -- =========================================================== procedure WarpSprite (screen : V.Surface_ptr; x, y : C.int) is updates : V.Rects_Array (0 .. 1); begin -- Erase, move, Draw, update updates (0) := position; V.BlitSurface (backing, null, screen, updates (0)); position.x := Sint16 (x - sprite.w / 2); -- Center about X position.y := Sint16 (y - sprite.h / 2); -- Center about Y updates (1) := position; V.BlitSurface (screen, updates (1), backing, null); updates (1) := position; V.BlitSurface (sprite, null, screen, updates (1)); V.UpdateRects (screen, updates'Length, updates); end WarpSprite; -- =========================================================== info : V.VideoInfo_ConstPtr; screen : V.Surface_ptr; video_bpp : Uint8; videoflags : V.Surface_Flags; buffer : Fb.Framebuffer_8bPointer; done : C.int; event : Ev.Event; light : V.Surface_ptr; mouse_pressed : C.int; ticks, lastticks : Uint32; argc : Integer := CL.Argument_Count; PollEvent_Result : C.int; begin -- Initialize SDL if SDL.Init (SDL.INIT_VIDEO or SDL.INIT_JOYSTICK) < 0 then Put_Line ("Couldn't initialize SDL: " & Er.Get_Error); GNAT.OS_Lib.OS_Exit (1); end if; SDL.Quit.atexit (SDL.SDL_Quit'Access); -- Alpha blending doesn't work well at 8-bit color info := V.GetVideoInfo; if info.vfmt.BitsPerPixel > 8 then video_bpp := info.vfmt.BitsPerPixel; else video_bpp := 16; end if; videoflags := V.SWSURFACE; 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 last : Positive; begin Uint8_IO.Get (CL.Argument (argc), video_bpp, last); end; argc := argc - 2; Put_Line ("-bpp" & Uint8'Image (video_bpp)); elsif CL.Argument (argc) = "-hw" then videoflags := videoflags or V.HWSURFACE; argc := argc - 1; Put_Line ("-hw"); elsif CL.Argument (argc) = "-warp" then videoflags := videoflags or V.HWPALETTE; argc := argc -1; Put_Line ("-warp"); elsif CL.Argument (argc) = "-fullscreen" then videoflags := videoflags or V.FULLSCREEN; argc := argc - 1; Put_Line ("-fullscreen"); else Put_Line ("Usage: " & CL.Command_Name & " " & "[-bpp N] [-warp] [-hw] [-fullscreen]"); GNAT.OS_Lib.OS_Exit (1); end if; end loop; -- 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: " & Er.Get_Error); GNAT.OS_Lib.OS_Exit (2); end if; -- Set the surface pixels and refresh if V.LockSurface (screen) < 0 then Put_Line ("Couldn't lock the display surface: " & Er.Get_Error); GNAT.OS_Lib.OS_Exit (2); end if; buffer := Fb.Get_Framebuffer (screen); for i in 0 .. screen.h - 1 loop Fb.Paint_Line_Unchecked (screen, buffer, i * 255 / screen.h); buffer := Fb.Next_Line_Unchecked (screen, buffer); end loop; V.UnlockSurface (screen); V.UpdateRect (screen, 0, 0, 0, 0); -- Create the light light := CreateLight (screen, 82); if light = null then GNAT.OS_Lib.OS_Exit (1); end if; -- Load the sprite if LoadSprite (screen, "icon.bmp") < 0 then V.FreeSurface (light); GNAT.OS_Lib.OS_Exit (1); end if; -- Set a clipping rectangle do clip the outside edge of the screen declare clip : V.Rect; begin clip.x := 32; clip.y := 32; clip.w := Uint16 (screen.w - (2 * 32)); clip.h := Uint16 (screen.h - (2 * 32)); V.SetClipRect (screen, clip); end; -- Wait for a keystroke lastticks := T.GetTicks; done := 0; mouse_pressed := 0; while done = 0 loop -- Update the frame -- move the sprite if mouse_pressed /= 0 then MoveSprite (screen, light); mouse_pressed := 0; else MoveSprite (screen, null); end if; -- Slow down the loop to 30 frames / second ticks := T.GetTicks; if (ticks - lastticks) < FRAME_TICKS then -- if CHECK_SLEEP_GRANULARITY -- Put_Line ("Sleeping " & -- Uint32'Image (FRAME_TICKS - (ticks - lastticks)) & -- " ticks"); T.SDL_Delay (FRAME_TICKS - (ticks - lastticks)); -- if CHECK_SLEEP_GRANULARIRY -- Put_Line ("Slept " & -- Uint32'Image (FRAME_TICKS - (ticks - lastticks)) & -- " ticks"); end if; lastticks := ticks; -- Check for events loop Ev.PollEventVP (PollEvent_Result, event); exit when PollEvent_Result = 0; case event.the_type is when Ev.MOUSEMOTION => if event.motion.state /= 0 then AttractSprite (event.motion.x, event.motion.y); mouse_pressed := 1; end if; when Ev.MOUSEBUTTONDOWN => if event.button.button = 1 then AttractSprite (event.button.x, event.button.y); mouse_pressed := 1; else declare area : V.Rect; begin area.x := Sint16 (event.button.x - 16); area.y := Sint16 (event.button.y - 16); area.w := 32; area.h := 32; V.FillRect (screen, area, 0); V.Update_Rect (screen, area); end; end if; when Ev.KEYDOWN => -- Any keypress quits the app ... done := 1; when Ev.QUIT => done := 1; when others => null; end case; end loop; end loop; V.FreeSurface (light); V.FreeSurface (sprite); V.FreeSurface (backing); -- print out some timing information if flashes > 0 then Put (Uint32'Image (flashes) & " alpha blits, ~"); Put (Float (flashtime) / Float (flashes), 3, 2, 0); Put_Line (" ms per blit"); end if; end Testalpha;