Event management system / dispatch (working).

Action.ml

@@ -0,0 +1,15 @@
+(* vim: set ts=2 sw=2 et : *)
+
+type t = 
+  | None
+  | Quit
+;;
+
+type event_t = {
+  label : string;
+};;
+
+
+let execute action = 
+  ignore action
+;;

Common.ml

@@ -0,0 +1,8 @@
+(* vim: set st=2 sw=2 et : *)
+
+exception NotImplemented of string
+;;
+
+let init () =
+  ()
+;;

Config.ml

@@ -0,0 +1,81 @@
+(* vim: set ts=2 sw=2 et: *)
+exception ParseError
+;;
+
+type t = {
+  mutable config_dir : string ;
+  mutable video_width : int ;
+  mutable video_height : int ; 
+  mutable show_fps : bool
+}
+
+let create () =
+  let config_dir = Printf.sprintf "%s/.justnukeit" ( Unix.getenv "HOME" )
+  in
+  {
+    config_dir = config_dir ;
+    video_width = 0 ;
+    video_height = 0 ;
+    show_fps = false 
+  }
+;;
+
+let parse_cmdline config =
+  let usagemsg = ( "Usage: " ^ Sys.argv.(0) ^ " <options>\n" ) in
+  Arg.parse 
+  ( 
+    Arg.align [
+      ("-config", Arg.String (fun x -> config.config_dir <- x ) , "<dir> Load configuration from given directory");
+    ]
+  ) (fun x -> ignore x ) usagemsg
+;;
+
+
+let parse_file_load config config_file = 
+  ignore config ;
+  ignore config_file
+;;
+
+let parse_file_test config config_file =
+  let  config_perms = [Unix.R_OK; Unix.W_OK; Unix.F_OK]
+  in
+
+  let dir_exist = 
+    print_string ( "Testing configuration dir '" ^ config.config_dir ^ "'\n" ) ;
+    try Unix.access config.config_dir config_perms ; true
+    with _ -> false
+  in 
+
+  let file_exist = 
+    print_string ( "Testing configuration file '" ^ config_file ^ "'\n" ) ;
+    try Unix.access config_file config_perms ; true
+    with _ -> false 
+  in
+
+  print_string ( "Dir = " ^ ( string_of_bool dir_exist ) ^ " / File = " 
+  ^ ( string_of_bool file_exist ) ^ "\n" ) ;
+
+  match ( dir_exist, file_exist ) with
+  | ( false, false ) -> 
+      (* create missing directory *)
+      Unix.mkdir config.config_dir 0o750
+      (* dump default config *)
+  | ( false, true ) -> (* problem! *)
+      raise ParseError
+  | ( true, false ) -> 
+      (* dump default config *)
+      ()
+  | ( true, true ) -> 
+      (* load file *)
+      ()
+;;
+
+let parse_file config = 
+  let config_file = 
+    Printf.sprintf "%s/config" config.config_dir ;
+  in
+
+  parse_file_test config config_file; 
+  parse_file_load config config_file
+;;
+

Game.ml

@@ -1,32 +1,55 @@
 (* vim: set st=2 sw=2 et : *)
 
 type game_t = {
-  level: Level.level_t ;
-  players: Player.player_t array ;
+  mutable level: Level.t ;
+  mutable players: Player.t option array ;
   (* monsters: Monster.monster.t array ; *)
-  timeline : Timeline.timeline_t ;
+  mutable timeline : Timeline.t ;
+  mutable config : Config.t ;
+  mutable actions : Action.t list ;
+  mutable quit : bool ;
 }
 
-let handle_event ev =
-  ignore ev ; []
+
+let create () = 
+  let level_data = Level.create ()
+  and players_data = Array.make 2 (Some( Player.create() ))
+  and timeline_data = Timeline.create ()
+  and config_data = Config.create ()
+  in 
+  {
+    level = level_data ; 
+    players = players_data ;
+    timeline = timeline_data ;
+    config = config_data ;
+    actions = [] ;
+    quit = false ;
+  }
 ;;
 
-let rec refresh_input () = 
-  (* poll events *)
-  let match_quit ev =
-    if ev = Sdlevent.QUIT then true
-    else false
-  in
+let configure game = 
+  Config.parse_cmdline game.config;
+  Config.parse_file game.config
+;;
 
-  let match_handler ev = 
-    match ev with
+let init game =
+  Video.init game.config;
+  Mouse.init () ;
+  Keyboard.init () ;
+  () 
+;;
+
+
+let add_actions game = 
+  let anon_handler anon_ev = 
+    match anon_ev with
     (* key events *)
-    | Sdlevent.KEYDOWN _ -> Keyboard.handle_event
-    | Sdlevent.KEYUP _ -> Keyboard.handle_event
+    | Sdlevent.KEYDOWN key_ev -> Keyboard.handle_event key_ev
+    | Sdlevent.KEYUP key_ev -> Keyboard.handle_event key_ev
     (* mouse events *)
-    | Sdlevent.MOUSEMOTION _ -> Mouse.handle_event
-    | Sdlevent.MOUSEBUTTONDOWN _ -> Mouse.handle_event
-    | Sdlevent.MOUSEBUTTONUP _ -> Mouse.handle_event
+    | Sdlevent.MOUSEMOTION mouse_ev -> Mouse.handle_event mouse_ev
+    | Sdlevent.MOUSEBUTTONDOWN mouse_ev -> Mouse.handle_event mouse_ev
+    | Sdlevent.MOUSEBUTTONUP mouse_ev -> Mouse.handle_event mouse_ev
     (* joystick events *)
     | Sdlevent.JOYAXISMOTION _ -> Joystick.handle_event
     | Sdlevent.JOYBALLMOTION _ -> Joystick.handle_event
@@ -36,24 +59,57 @@ let rec refresh_input () =
     (* video events *)
     | Sdlevent.VIDEORESIZE _ -> Video.handle_event
     | Sdlevent.VIDEOEXPOSE -> Video.handle_event
-    | Sdlevent.ACTIVE _ -> Video.handle_event
+    | Sdlevent.ACTIVE _ -> Video.handle_event 
     (* system events *)
-    | Sdlevent.QUIT -> handle_event
-    | Sdlevent.SYSWM -> handle_event
+    | Sdlevent.QUIT -> (fun x -> ignore x ; [Action.Quit] )
+    | Sdlevent.SYSWM -> (fun x -> ignore x ; [Action.None] )
     (* user defined events *)
-    | Sdlevent.USER _ -> (fun x -> ignore x ; [] )
+    | Sdlevent.USER user_ev -> (fun x -> ignore x ; ignore user_ev ; [Action.None] )
   in
 
   let some_event = Sdlevent.poll ()
   in
 
   match some_event with
-  | Some ev -> 
-      let handler = match_handler ev
-      and quit = match_quit ev
-      in  
-      ignore ( handler ev );
-      if not quit then refresh_input ()
-     
-  | None -> ()
+  | Some anon_ev -> 
+      let specific_handler = anon_handler anon_ev 
+      in
+
+      (* return actions resulting from selected handler *)
+      game.actions <- ( game.actions @ ( specific_handler anon_ev ) ) ;
+      ()
+
+  | None -> 
+      ()
+;;
+
+
+(** Looping while the program is active *)
+let rec loop game = 
+  Sdltimer.delay 100 ;
+  (* poll events  and get actions *)
+  add_actions game ;
+  (* remove and run "head" action from action list *)
+  (* and quit = match_quit anon_ev *)
+  (* if not quit then loop game *)
+  let remaining_actions () = ( game.actions != [] )
+  in
+
+  while (remaining_actions ()) do
+    let hd::tail = game.actions 
+    in
+
+    game.actions <- tail ;
+    if hd = Action.Quit then
+      begin
+        print_string "Leaving game...\n" ;
+        game.quit <- true
+      end
+    else
+      begin
+        print_string "Executing action...\n" ;
+        Action.execute hd
+      end
+  done ;
+  if not game.quit then loop game
 ;;

Keyboard.ml

@@ -1,5 +1,69 @@
 (* vim: set st=2 sw=2 et : *)
 
-let handle_event ev =
-    ignore ev ; []
+module KeyMap = Map.Make(
+  struct
+    type t = Sdlkey.t
+
+    let compare x y =
+      let xval = Sdlkey.int_of_key x
+      and yval = Sdlkey.int_of_key y
+      in 
+      if xval = yval then 0
+      else 
+        if xval < yval then -1
+        else 1
+
+  end
+)
+
+type mapdata_editable_t =
+  | Static
+  | Editable
+;;
+
+
+type key_action_t = mapdata_editable_t * Action.t
+;;
+
+
+type t = {
+  mutable map : key_action_t KeyMap.t ;
+}
+;;
+
+
+(** used keys *)
+let keys = {
+  map = KeyMap.empty ;
+}
+
+let handle_event key_ev anon_ev =
+  let {Sdlevent.keysym = keysym} = key_ev
+  in 
+
+  let map_fold_fun map_key map_action action_list = 
+    if keysym = map_key then
+      let (sub_editable, sub_action) = map_action
+      in
+      match action_list with
+      | [Action.None] -> [sub_action]
+      | hd::tail -> 
+          raise ( Common.NotImplemented "Keyboard: folding 2 concrete actions" )
+      | [] -> [sub_action]
+    else
+      action_list
+  in
+
+  KeyMap.fold map_fold_fun keys.map [Action.None]
+;;
+
+let init () =
+  (* do nothing *)
+  (* init an associative array of 
+     key -> actions events 
+     with KEY_ESCAPE -> (Action.Quit, 
+  *) 
+  keys.map <- KeyMap.add Sdlkey.KEY_ESCAPE ( Static, Action.Quit ) keys.map ;
+  keys.map <- KeyMap.add Sdlkey.KEY_q ( Static, Action.Quit ) keys.map ;
+  ()
 ;;

Level.ml

@@ -18,7 +18,7 @@ type tileset_t =
     | Tileset_library (* crayon, books, papers, *)
 ;;
 
-type level_t = {
+type t = {
     size_x : int ;
     size_y : int ;
     items : (item_t ref) array array ;

Makefile

@@ -1,6 +1,8 @@
 PROGRAMS=justnukeit
 
 justnukeit_OBJS= \
+				 Common \
+				 Config \
 				 Position \
 				 Timeline \
 				 Mouse \
@@ -10,6 +12,7 @@ justnukeit_OBJS= \
 				 Level \
 				 Player \
 				 Video \
+				 Action \
 				 Game \
 				 main
 

Menu.ml

@@ -30,8 +30,9 @@ type t = {
   keyboard_handle : string (* Keyboard.a *)
 };;
 
+(*
 let handle_event ev =
   let actions = (Keyboard.handle_event ev) :: (Mouse.handle_event ev)
   in
   actions;;
-
+*)

Mouse.ml

@@ -4,7 +4,13 @@
 
 (** Returns a list of "abstract events" generated 
     by this SDL event *)
-let handle_event ev =
-  ignore ev ; []
+let handle_event mouse_ev anon_ev =
+  ignore mouse_ev ;
+  ignore anon_ev ;
+  [Action.None]
 ;;
 
+let init () =
+  (* do nothing *)
+  ()
+;;

Player.ml

@@ -1,5 +1,5 @@
 
-type player_t = {
+type t = {
     mutable name : string ;
     mutable lifes : int ;
     mutable position : Position.t;

Timeline.ml

@@ -1,8 +1,16 @@
 
 type timeslice_t = {
     (* Action *)
+    action: Action.t;
     label: string ;
 }
 
-type timeline_t = timeslice_t list
+type t = timeslice_t list
 
+let create () = 
+    [];;
+
+
+let add_slice timeline slice = timeline @ [slice];;
+
+let add_action timeline action = ();;

Video.ml

@@ -1,5 +1,50 @@
 (* vim: set st=2 sw=2 et : *)
 
-let handle_event ev =
-    ignore ev ; []
+type t = {
+  mutable screen : Sdlvideo.surface option;
+  mutable height: int;
+  mutable width : int
+};;
+
+
+let video = { 
+  width = 0 ;
+  height = 0 ;
+  screen = None
+};;
+
+(** Initialize video, open windows, etc. *)
+let init config = 
+  Sdl.init [`VIDEO] ;
+  at_exit Sdl.quit ;
+  Sdlttf.init () ;
+  at_exit Sdlttf.quit ;
+  let bpp = 
+    Sdlvideo.video_mode_ok 
+    ~w:config.Config.video_width 
+    ~h:config.Config.video_height 
+    ~bpp:32
+    [`DOUBLEBUF]
+  in
+  let screen_surface = 
+    Sdlvideo.set_video_mode 
+    ~w:config.Config.video_width 
+    ~h:config.Config.video_height
+    ~bpp:bpp
+    [`DOUBLEBUF]
+  in (
+    video.width <- config.Config.video_width ;
+    video.height <- config.Config.video_height ;
+    video.screen <- Some screen_surface
+  )
+;;
+
+
+(* set parameters & title *)
+(* { screen = Sdlvideo.set_video_mode config.width config.height [`DOUBLEBUF];
+} *)
+
+let handle_event anon_ev =
+    ignore anon_ev ;
+    []
 ;;

main.ml

@@ -74,6 +74,7 @@ let rec event_loop () =
 *)
 
 
+(* 
 let rec game_loop ~screen =
   let image = Sdlloader.load_image image_filename
   and image_from = Sdlvideo.rect 0 0 300 300 
@@ -84,26 +85,39 @@ let rec game_loop ~screen =
   (* let action_fun = event_loop () ; *)
   game_loop ~screen:screen
 ;;
-
+*)
 
 
 let main () =
-  let player1 = Player.create ()
-  and map1 = Level.create ()
-  and config = { width = 640 ; height = 480 }
-  in
-  ignore player1 ;
-  ignore map1 ;
-  (* open window *)
-  Sdl.init [`VIDEO];
-  at_exit Sdl.quit;
-  Sdlttf.init ();
-  at_exit Sdlttf.quit;
-  (* set parameters & title *)
-  let screen = Sdlvideo.set_video_mode config.width config.height [`DOUBLEBUF]
-  in
-  game_loop ~screen:screen;
-  (* close window *)
+  let game = Game.create ()
+  in 
+  Printf.printf "Game.configure...\n" ;
+  Game.configure game ;
+  Game.init game ;
+  Printf.printf "Game.loop...\n" ;
+  Game.loop game ;
+  fun x -> ignore x
 ;;
 
-main ();
+(*
+  in 
+  let player1 = Player.create ()
+  and map1 = Level.create ()
+  and config = Config.create ()
+  in
+  ( try 
+    let config_file = config.find ()
+    config.load config_file
+    with
+    exit 1;
+  ) ;
+  (* { width = 640 ; height = 480 } *)
+  ignore player1 ;
+  ignore map1 ;
+  Game.init game config;
+  Game.loop game;
+  (* close window *)
+;;
+*)
+
+Printexc.print ( main () );