let num_sprite = 100 let max_speed = 1 let debug = ref true let dbug_msg msg = if !debug then prerr_endline msg let add_to_updates l x = l := (Sdlvideo.copy_rect x) :: !l let sprite_visible = ref false let x_vel = ref 0 let y_vel = ref 0 let alpha_vel = ref 0 let position = { Sdlvideo.r_x = 0; Sdlvideo.r_y = 0; Sdlvideo.r_w = 0; Sdlvideo.r_h = 0; } let sprite_x = Array.create num_sprite 0 let sprite_y = Array.create num_sprite 0 let sprite_vx = Array.create num_sprite 0 let sprite_vy = Array.create num_sprite 0 let screen_w = 640 let screen_h = 480 let sprite_w = 32 let sprite_h = 32 let right = screen_w - sprite_w let bottom = screen_h - sprite_h let load_sprite ~screen ~sprite = (* Set transparent pixel as the pixel at (0,0) *) if Sdlvideo.use_palette sprite then begin let pixels = Sdlvideo.pixel_data_8 sprite in dbug_msg (Printf.sprintf "## setting color key : %x" pixels.{0}) ; Sdlvideo.set_color_key sprite (Int32.of_int pixels.{0}) ; end ; (* Convert sprite to video format *) dbug_msg "## converting to display format" ; let sprite' = Sdlvideo.display_format sprite in (* Create the background *) let { Sdlvideo.w = w ; Sdlvideo.h = h } = Sdlvideo.surface_info sprite' in let backing = Sdlvideo.create_RGB_surface [ `SWSURFACE ] w h 8 Int32.zero Int32.zero Int32.zero Int32.zero in (* Convert background to video format *) let backing' = Sdlvideo.display_format backing in let { Sdlvideo.w = scr_w ; Sdlvideo.h = scr_h } = Sdlvideo.surface_info screen in position.Sdlvideo.r_x <- (scr_w - w) / 2 ; position.Sdlvideo.r_y <- (scr_h - h) / 2 ; position.Sdlvideo.r_w <- w ; position.Sdlvideo.r_h <- h ; x_vel := 0 ; y_vel := 0 ; alpha_vel := 1 ; (sprite', backing') let add_to_updates l x = l := (Sdlvideo.copy_rect x) :: !l let move_sprites ~screen ~sprite ~backing = let { Sdlvideo.w = w ; Sdlvideo.h = h } = Sdlvideo.surface_info screen in let rect = Sdlvideo.rect 0 0 w h in Sdlvideo.fill_rect ~rect screen (Int32.zero); let updates = ref [] in for i=0 to pred num_sprite do sprite_x.(i) <- sprite_x.(i) + sprite_vx.(i); sprite_y.(i) <- sprite_y.(i) + sprite_vy.(i); if sprite_x.(i) < 0 || sprite_x.(i) >= right then begin sprite_vx.(i) <- -sprite_vx.(i); sprite_x.(i) <- sprite_x.(i) + sprite_vx.(i) end; if sprite_y.(i) < 0 || sprite_y.(i) >= bottom then begin sprite_vy.(i) <- -sprite_vy.(i); sprite_y.(i) <- sprite_y.(i) + sprite_vy.(i) end; let area = Sdlvideo.rect sprite_x.(i) sprite_y.(i) 0 0 in Sdlvideo.blit_surface ~src:sprite ~dst:screen ~dst_rect:area (); add_to_updates updates area done; Sdlvideo.update_rects !updates screen let process_cli ini_bpp = let videoflags = ref [ `SWSURFACE ] in let bpp = ref ini_bpp in let add_to_flags fl = fun () -> videoflags := fl :: !videoflags in let cli_args = [ ( "-d", Arg.Set debug, "debugging" ) ; ( "-bpp", Arg.Int ((:=) bpp), "bpp for video mode" ) ; ( "-hw", Arg.Unit (add_to_flags `HWSURFACE) , "hardware surface" ) ; ( "-warp", Arg.Unit (add_to_flags`HWPALETTE), "hardware palette" ) ; ( "-fs", Arg.Unit (add_to_flags `FULLSCREEN), "fullscreen" ) ; ] in let usg_msg = Printf.sprintf "usage: %s [options]" (Filename.basename Sys.argv.(0)) in Arg.parse cli_args ignore usg_msg ; (!videoflags, !bpp) exception Continue let main () = (* Initialize SDL *) Sdl.init ~auto_clean:true [ `VIDEO ] ; let sprite = Sdlvideo.load_BMP "icon.bmp" in (* Alpha blending doesn't work well at 8-bit color *) let video_bpp = let info_fmt = Sdlvideo.get_video_info_format () in if info_fmt.Sdlvideo.bits_pp > 8 then info_fmt.Sdlvideo.bits_pp else 16 in let (video_flags, bpp) = process_cli video_bpp in (* Set 640x480 video mode *) dbug_msg "## setting video mode" ; let screen = Sdlvideo.set_video_mode ~w:screen_w ~h:screen_h ~bpp video_flags in (* Set the surface pixels and refresh! *) dbug_msg "## setting surface" ; let { Sdlvideo.pitch = pitch ; Sdlvideo.w = w ; Sdlvideo.h = h ; } = Sdlvideo.surface_info screen in (* Load the sprite *) dbug_msg "## loading sprite" ; let (sprite, backing) = load_sprite ~screen ~sprite in dbug_msg "## initialize sprite" ; let sw = w in let sh = h in let { Sdlvideo.w = w ; Sdlvideo.h = h } = Sdlvideo.surface_info sprite in for i=0 to pred num_sprite do sprite_x.(i) <- Random.int right; sprite_y.(i) <- Random.int bottom; while sprite_vx.(i) == 0 && sprite_vy.(i) == 0 do sprite_vx.(i) <- Random.int (max_speed * 2 + 1) - max_speed ; sprite_vy.(i) <- Random.int (max_speed * 2 + 1) - max_speed ; done done; (* wait for a keystroke *) let lastticks = ref (Sdltimer.get_ticks ()) in let frame = ref 0 in let first = Sdltimer.get_ticks () in dbug_msg "## entering event loop" ; begin try while true do try while true do move_sprites ~screen ~sprite ~backing; frame := !frame + 1; (* Check for events *) match Sdlevent.poll () with | None -> raise Continue | Some evt -> match evt with | Sdlevent.KEYDOWN _ (* Any keypress quits the app... *) | Sdlevent.QUIT -> dbug_msg "## exiting ..." ; let elapsed = Sdltimer.get_ticks () - first in let fps = !frame * 1000 / elapsed in let msg = Printf.sprintf "%d frames per second\n" fps in dbug_msg msg; raise Exit | _ -> () done with Continue -> () done with Exit -> () end let _ = try main () with exn -> Sdl.quit () ; raise exn