Commits

Paweł Wieczorek  committed 7987f56 Draft

added text support and draving for UI algebra

  • Participants
  • Parent commits f3a5098

Comments (0)

Files changed (14)

 OCAMLMAKEFILE = OCamlMakefile
 
-PACKS = sdl sdl.sdlimage sdl.sdlgfx batteries pa_where.syntax
+PACKS = sdl sdl.sdlimage sdl.sdlgfx batteries pa_where.syntax sdl.sdlttf
 RESULT = pixland
 INCDIRS = src
 LIBDIRS = src
 ANNOTATE = yes
 NATIVE = yes
 USE_CAMLP4 = yes
-PP= camlp4find ${PACKS} camlp4/pa_recupd.cmo
+PREDS=camlp4o
+PP= camlp4find ${PACKS} camlp4/pa_recupd.cmo 
 export PP
 PRE_TARGETS =\
     camlp4/pa_recupd.cmi\

File res/ttf/speculo.ttf

Binary file added.

File res/ttf/speculum.ttf

Binary file added.

File src/Resource.ml

  *   Copyrights 2012 by Pawel Wieczorek <wieczyk gmail com>
  *)
 
-open Map;;
-
-
+open BatPathGen.OfString;;
 
 (**************************************************************************
  * Resource
     ; mutable image : Video.image option
     }
 
+type resourceFont =
+    { nameFont      : string
+    ; mutable font  : Sdlttf.font option
+    }
+
 type resource
   = Image of resourceImage
+  | Font of resourceFont
 
 
 (**************************************************************************
 let prepare_image name =
   { id = MkImageId (-1) ; name = name ; image = None }
 
+let prepare_font name =
+  {  nameFont = name ; font = None }
+
+
 (**************************************************************************
  * Predefined resources
  *)
   let img_water = prepare_image "water-32x32"
   let img_rock  = prepare_image "rock-32x32"
 
+  let font_txt  = prepare_font "speculum"
+
   let resources =
     [ Image img_grass
     ; Image img_water
     ; Image img_rock
+    ; Font  font_txt
     ]
 
 end
       i.image <- Some image;
       fresh_id_int := succ !fresh_id_int
 
+  | Font f ->
+      let path = to_ustring (List.rev [ "res" ; "ttf" ; f.nameFont ^ ".ttf" ]) in
+      Printf.printf " - loading font %s\n%!" path;
+      let font = Sdlttf.open_font path 18 in
+      f.font <- Some font
+
+
 let rec load_resources = function
   | []    -> ()
   | x::xs ->

File src/Resource.mli

   mutable image : Video.image option;
 }
 
-type resource = Image of resourceImage
+type resourceFont =
+    { nameFont      : string
+    ; mutable font  : Sdlttf.font option
+    }
+
+type resource
+  = Image of resourceImage
+  | Font of resourceFont
 
 (**************************************************************************
  * Resources
     val img_grass : resourceImage
     val img_water : resourceImage
     val img_rock : resourceImage
+    val font_txt : resourceFont
   end
 

File src/Screens/MainScreen.ml

 
 open Screen;;
 open UI;;
+open UI_Algebra;;
+
 (**************************************************************************
  * Types
  *)
 
 let menu_width  = 300
 
-let menu_height = 400
+
+let ui_contener = Panel ("Main menu", main_widget)
+  where main_widget = HorizontalBox widgets
+  where widgets =
+    [ Button "Play game"
+    ; Button "Load saved game"
+    ; Button "Options"
+    ; Button "Exit"
+    ]
+
+   
 
 let _screen_draw img state surface = 
   Video.put_image img surface (0,0);
   let (width, height) = Video.get_image_size surface in
+  let menu_height = calculate_height_for_ui_contener ui_contener in
   let padding_ver = (width - menu_width ) / 2 in
   let padding_hor = (height - menu_height ) / 2 in
   let rc          = (padding_ver, padding_hor, menu_width, menu_height) in
-  let rcb         = set_height (narrow_rect rc 10) 50 in
-  UI_Panel.draw_panel   UI_Panel.default_params "Menu" rc surface;
-  UI_Button.draw_button UI_Button.default_params "Play" rcb surface;
-  let rcb         = move_down rcb (50+10) in
-  UI_Button.draw_button UI_Button.default_params "Play" rcb surface;
+  draw_ui_contener rc surface ui_contener;
   Continue
 
 let _screen_keydown state = function

File src/System.ml

 let init () = 
   printf "===> PixLand %i.%i\n%!" ver_mayor ver_minor;
   Sdl.init_subsystem [ `VIDEO ] ;
+  Sdlttf.init ();
   let sdl_ver = Sdl.version () in
   printf " - running on libSDL %i.%i.%i\n%!" sdl_ver.major sdl_ver.minor sdl_ver.patch;
   Resource.init_resources ();

File src/UI/UI.ml

 
 let narrow_rect (x,y,w,h) c = (x+c, y+c, w-c-c, h-c-c)
 
+let narrow_up   (x,y,w,h) c = (x, y + c, w, h - c)
+let narrow_down (x,y,w,h) c = (x, y, w, h - c)
+
+let split_hor   ((x,y,w,h) as rc) c =
+  (narrow_down rc (h-c), narrow_up rc c)
+
 let move_down   (x,y,w,h) c = (x, y + c, w, h)
 let move_up     (x,y,w,h) c = (x, y - c, w, h)
 let move_left   (x,y,w,h) c = (x - c, y, w, h)
 (*  let frame_color      = from_hex 0x6e7f80 *)
 end
 
+(**************************************************************************
+ * Settings
+ *) 
+
+module UISettings = struct
+  let border_size       = 1
+  let text_height       = 30
+  let padding           = 5
+  let panel_padding     = 10
+  let panel_border_size = 3
+  let box_spacing       = 5
+end
+

File src/UI/UI_Algebra.ml

  *   Copyrights 2012 by Pawel Wieczorek <wieczyk gmail com>
  *)
 
+open UI;;
 
 (**************************************************************************
  * Types
 
 type ui_widget
     = Button of string
-    | HorizontalBox of int * ui_widget list
+    | HorizontalBox of ui_widget list
 
 type ui_contener
     = Panel of string * ui_widget
  * 
  *)
 
-let draw_ui_widget (x,y,w,h) surface = ()
+let pred_nat = function
+  | 0 -> 0
+  | n -> pred n
 
-let draw_ui_contener (x,y,w,h) surface = ()
+let rec calculate_height_for_ui_widget = function
+  | Button title ->
+      UI_Button.calculate_height UI_Button.default_params
+  | HorizontalBox widgets ->
+      let heights = List.map calculate_height_for_ui_widget widgets in
+      let height0 = List.fold_left (+) 0 heights in
+      let spacing = UISettings.box_spacing * pred_nat (List.length widgets) in
+      height0 + spacing
+      
+
+let calculate_height_for_ui_contener = function
+  | Panel (title, widget) ->
+      let height0 = UI_Panel.calculate_height UI_Panel.default_params in
+      let height1 = calculate_height_for_ui_widget widget in
+      height0 + height1
+  | Tabs _ ->
+      0
+
+
+let rec draw_horizontal_box rc surface = function
+  | [] ->
+      ()
+  | w::ws ->
+      let height    = calculate_height_for_ui_widget w in
+      let (rcw,rcr) = split_hor rc height in
+      draw_ui_widget rcw surface w;
+      let rcr'      = narrow_up rcr UISettings.box_spacing in
+      draw_horizontal_box rcr' surface ws
+
+and draw_ui_widget rc surface = function
+  | Button title ->
+      ignore (UI_Button.draw_button UI_Button.default_params title rc surface)
+  | HorizontalBox widgets ->
+      draw_horizontal_box rc surface widgets
+
+let draw_ui_contener rc surface = function
+  | Panel (title, widget) ->
+      let rc' = UI_Panel.draw_panel UI_Panel.default_params title rc surface in
+      draw_ui_widget rc' surface widget 
+  | Tabs _ ->
+      ()
+
+

File src/UI/UI_Button.ml

 open Video;;
 open UI;;
 open UI_Frame;;
+open Resource;;
 
 (**************************************************************************
  * Types
     ; UI_Frame.background_color = params.background_color
     }
 
+let get_font font =
+  let f = function
+    | None -> raise Exit
+    | Some fnt -> fnt
+  in f font
+
 let draw_button params text (x, y, w, h) surface =
     let fparams = mk_frame_params params in
     draw_frame fparams (x,y,w,h) surface;
-    ()
+    draw_text (get_font PAK0.font_txt.font) (0,0,0) text (x+3,y+3) surface
+
+let calculate_height params = 
+    let fparams = mk_frame_params params in
+    let height  = UI_Frame.calculate_height fparams in
+    height + UISettings.text_height + UISettings.padding
+

File src/UI/UI_Frame.ml

  *)
 
 let default_params =
-    { border_size        = 2
+    { border_size        = UISettings.border_size
     ; light_border_color = UIColor.border_light
     ; dark_border_color  = UIColor.border_dark
     ; background_color   = UIColor.bg_color
     let rc_bor_r = (x + w - 2*bs, y, bs, h - bs) in
     let rc_bor_t = (x, y, w - bs, bs) in
     let rc_bor_b = (x, y + h - 2*bs, w - bs, bs) in
-    let rc_in    = (x + bs, y + bs, w - 2*bs, h - 2*bs) in
-    Video.draw_rect params.background_color   rc_in   surface;
+    let rc_in    = (x + bs, y + bs, w - 3*bs, h - 3*bs) in
     Video.draw_rect params.light_border_color rc_bor_l surface;
     Video.draw_rect params.light_border_color rc_bor_t surface;
     Video.draw_rect params.dark_border_color  rc_bor_r surface;
     Video.draw_rect params.dark_border_color  rc_bor_b surface;
-    ()
+    Video.draw_rect params.background_color   rc_in   surface;
 
+    rc_in
 
+let calculate_height params =
+  let bs = params.border_size in
+  2*bs

File src/UI/UI_Panel.ml

 open Video;;
 open UI;;
 open UI_Frame;;
+open Resource;;
 
 (**************************************************************************
  * Types
 
 let default_params =
   { background_color = UIColor.panel_bg_color
-  ; border_size      = 3
+  ; border_size      = UISettings.panel_border_size
   ; text_color       = UIColor.text_color
   }
 
     ; UI_Frame.background_color = params.background_color
     }
 
+let get_font font =
+  let f = function
+    | None -> raise Exit
+    | Some fnt -> fnt
+  in f font
+
 let draw_panel params text (x, y, w, h) surface =
     let fparams = mk_frame_params params in
-    draw_frame fparams (x,y,w,h) surface;
-    ()
+    let rc_in   = draw_frame fparams (x,y,w,h) surface in
+    let (rc_top, rc_bot) = split_hor rc_in UISettings.text_height in
+    Video.draw_rect Color.cadet_grey rc_top surface;
+    draw_text (get_font PAK0.font_txt.font) (0,0,0) text (x+3,y+3) surface;
+    narrow_rect rc_bot UISettings.panel_padding
+
+let calculate_height params =
+  let fparams = mk_frame_params params in
+  let height  = UI_Frame.calculate_height fparams in
+  height + UISettings.text_height + 2*UISettings.panel_padding

File src/Video.ml

     fill_rect ~rect:rc image.sdlSurface i32
 
 
+let _draw_text font color text =
+  _create_image (Sdlttf.render_text font (Sdlttf.SOLID color) text)
+
+let draw_text font color text pos image =
+  let txtimg = _draw_text font color text in
+  put_image txtimg image pos

File src/Video.mli

 val draw_screen : unit -> unit
 val draw_rect : color -> rect -> image -> unit
 val get_image_size : image -> int * int
+val draw_text : Sdlttf.font -> color -> string -> int * int -> image -> unit