Source

StarML / main.ml

Full commit

open Types


module Funlist : sig

(* The funlist datatype *)
type ('a, 'b) t

(* Constructors *)
val nil : ('a, 'a) t
val cons : ('a -> 'b) -> ('b, 'c) t -> ('a, 'c) t

(* Applying a value to a composition *)
val apply : ('a, 'b) t -> 'a -> 'b

val append : ('a, 'b) t -> ('b, 'c) t -> ('a, 'c) t

end = struct
(* List of composable functions.

    The intended type expressed by the four types below is :
    type ('a, 'b) t = Nil of ('a -> 'b)
                    | Cons of exists 'c. ('a -> 'c) * ('c, 'b) t
*)
type ('a, 'b) t =
    | Nil of ('a -> 'b)
    | Cons of ('a, 'b) packed_list

and ('a, 'b, 'z) list_scope =
    { bind_list : 'c. ('a -> 'c) * ('c, 'b) t -> 'z}

and ('a, 'b) packed_list =
    { open_list : 'z. ('a, 'b, 'z) list_scope -> 'z }

(* Packing and unpacking lists *)
let pack_list h t = { open_list = fun scope -> scope.bind_list (h,t) }
let with_packed_list p e = p.open_list e

(* Constructors *)
let nil = Nil(fun x -> x)
let cons h t = Cons(pack_list h t)

(* Type to handle the polymorphic recursion of the apply function *)
type poly_rec = { apply : 'a 'b. poly_rec -> ('a, 'b) t -> 'a -> 'b }
let apply' r l x = match l with
| Nil id -> id x
| Cons l ->
     with_packed_list l { bind_list = function h,t -> r.apply r t (h x) }

let poly_rec = { apply = apply' }
let apply l x = apply' poly_rec l x

let rec append x y =
    match x with
    | Nil id -> invalid_arg "append"
    | Cons l -> invalid_arg "append"

end


module NetworkIO : sig
    type t
    val new_from    : Unix.file_descr -> t
    val read_line   : t -> string
    val send_string : t -> string -> unit

    type 'a io
    val m_put_string : string -> unit io
    val m_read_line : string io

    val bind : 'a io -> ('a -> 'b io) -> 'b io
    val return : 'a -> 'a io

    val io_exec : 'a io -> 'a
end = struct
    type t = Unix.file_descr

    let new_from fd = fd

    let read_char fd =
        let buf = String.make 1 ' ' in
        let z = Unix.recv fd buf 0 1 [] in
        assert (z = 1);
        buf.[0]

    let read_line fd =
        let c = ref ' ' in
        let b = Buffer.create 16 in
        let finished = ref false in
        while (not !finished) do
            c := read_char fd;
            if (!c = '\n') then
                finished  := true
            else
                Buffer.add_char b !c
        done;
        Buffer.contents b

    let send_string fd s =
        ignore (Unix.send fd s 0 (String.length s) [])

    (** Monadic interface *)

    type 'a io = unit

    let return _ = ()
    let bind _ _ = ()
    let io_exec _ = invalid_arg "io_exec"

    let m_put_string _ = ()
    let m_read_line = ()

end

type options =
    { user_control         : bool
    ; complete_information : bool
    }

let options =
    { user_control         = true
    ; complete_information = false
    }

let option_string o =
    let opt x = if x then "1" else "0" in
     (opt o.user_control)
    ^(opt o.complete_information)

type player =
    { player_id : int
    ; player_race : race
    }

let split_re re =
    Str.split (Str.regexp re)

let split_colon =
    split_re ":"

let split_semicolon =
    split_re ";"

let parse_int = int_of_string

let parse_bool s =
    match parse_int s with
    | 0 -> false
    | 1 -> true
    | _ -> invalid_arg "read_bool"

let build_parser parse_fun s =
    let elts = split_colon s in
    List.map (fun s ->
        let a = Array.of_list (split_semicolon s) in
        parse_fun a
    ) (List.tl elts)

let parse_player str =
    let a = Array.of_list (split_colon str) in
         (           (int_of_string a.(0))
         , read_race (int_of_string a.(1))
         ,           (int_of_string a.(2))
         , read_race (int_of_string a.(3))
         )

let parse_location =
    build_parser (fun attr ->
        (int_of_string attr.(0)
        ,int_of_string attr.(1)
        )
    )

type unit_type =
    { unit_id               : int    ; unit_race             : string
    ; unit_name             : string ; unit_min_cost         : int
    ; unit_gas_cost         : int    ; unit_max_hp           : int
    ; unit_max_shld         : int    ; unit_energy           : int
    ; unit_build_time       : int    ; unit_can_attack       : bool
	; unit_can_move         : bool   ; unit_tile_width       : int
	; unit_tile_height      : int    ; unit_supply_req       : int
	; unit_supply_prov      : int    ; unit_sight            : int
	; unit_ground_max_range : int    ; unit_ground_min_range : int
	; unit_ground_damage    : int    ; unit_air_range        : int
	; unit_air_damage       : int    ; unit_is_building      : bool
	; unit_is_flyer         : bool   ; unit_is_spell_caster  : bool
	; unit_is_worker        : bool   ; unit_builder          : int
    }

let parse_units =
    build_parser (fun attr ->
        { unit_id               = int_of_string attr.(0)
        ; unit_race             = attr.(1)
        ; unit_name             = attr.(2)
        ; unit_min_cost         = parse_int  attr.(3)
        ; unit_gas_cost         = parse_int  attr.(4)
        ; unit_max_hp           = parse_int  attr.(5)
        ; unit_max_shld         = parse_int  attr.(6)
        ; unit_energy           = parse_int  attr.(7)
        ; unit_build_time       = parse_int  attr.(8)
        ; unit_can_attack       = parse_bool attr.(9)
        ; unit_can_move         = parse_bool attr.(10)
        ; unit_tile_width       = parse_int  attr.(11)
        ; unit_tile_height      = parse_int  attr.(12)
        ; unit_supply_req       = parse_int  attr.(13)
        ; unit_supply_prov      = parse_int  attr.(14)
        ; unit_sight            = parse_int  attr.(15)
        ; unit_ground_max_range = parse_int  attr.(16)
        ; unit_ground_min_range = parse_int  attr.(17)
        ; unit_ground_damage    = parse_int  attr.(18)
        ; unit_air_range        = parse_int  attr.(19)
        ; unit_air_damage       = parse_int  attr.(20)
        ; unit_is_building      = parse_bool attr.(21)
        ; unit_is_flyer         = parse_bool attr.(22)
        ; unit_is_spell_caster  = parse_bool attr.(23)
        ; unit_is_worker        = parse_bool attr.(24)
        ; unit_builder          = parse_int  attr.(25)
        }
    )

type tech = 
    { tech_id       : int
    ; tech_name     : string
    ; tech_research : int
    ; tech_min_cost : int
    ; tech_gas_cost : int
    }

let parse_techs =
    build_parser (fun attr ->
        { tech_id       = int_of_string attr.(0)
        ; tech_name     = attr.(1)
        ; tech_research = int_of_string attr.(2)
        ; tech_min_cost = int_of_string attr.(3)
        ; tech_gas_cost = int_of_string attr.(4)
        }
    )

type upgrade =
    { upgr_id         : int
    ; upgr_name       : string
    ; upgr_research   : int
    ; upgr_repeats    : int
    ; upgr_min_base   : int
    ; upgr_min_factor : int
    ; upgr_gas_base   : int
    ; upgr_gas_factor : int
    }

let parse_upgrades =
    build_parser (fun attr ->
        { upgr_id         = int_of_string attr.(0)
        ; upgr_name       = attr.(1)
        ; upgr_research   = int_of_string attr.(2)
        ; upgr_repeats    = int_of_string attr.(3)
        ; upgr_min_base   = int_of_string attr.(4)
        ; upgr_min_factor = int_of_string attr.(5)
        ; upgr_gas_base   = int_of_string attr.(6)
        ; upgr_gas_factor = int_of_string attr.(7)
        }
    )

type map_attr =
    { mattr_height    : int
    ; mattr_buildable : bool
    ; mattr_walkable  : bool
    }

type map =
    { map_name  : string
    ; map_w     : int
    ; map_h     : int
    ; map_attrs : map_attr array array
    }

let parse_map s =
    let map = Array.of_list (split_colon s) in
    let split_tokens s =
        List.map (fun x -> match x with
        | Str.Delim s -> s
        | Str.Text  _ -> invalid_arg "split_tokens"
        ) (Str.full_split (Str.regexp "...") s)
    in
    let attr_l = List.map (fun s ->
        { mattr_height    = int_of_char s.[0]
        ; mattr_buildable = (s.[1] = '1')
        ; mattr_walkable  = (s.[2] = '1')
        }
    ) (split_tokens map.(3))
    in
    let mw = int_of_string map.(1) in
    let mh = int_of_string map.(2) in
    let i = ref 0 in
    let attr = Array.make_matrix mh mw
        { mattr_height    = 0
        ; mattr_buildable = false
        ; mattr_walkable  = false 
        }
    in
    List.iter (fun a ->
        let w = !i mod mw in
        let h = !i / mw in
        attr.(h).(w) <- a;
        incr i
    ) attr_l;
    { map_name  = map.(0)
    ; map_w     = mw
    ; map_h     = mh
    ; map_attrs = attr
    }

let main _ =
    print_endline "Sup dawg, I heard you like starcraft";
    print_endline "------------------------------------";
    print_endline "Waiting...";
    let sock = Unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in
    let saddr = Unix.ADDR_INET (Unix.inet_addr_any, 13337) in
    Unix.bind sock saddr;
    Unix.listen sock 4;
    let buflen = 512 in
    let buf = String.create buflen in
    let (fd, _) = Unix.accept sock in
    print_endline "Got it !";
    let io = NetworkIO.new_from fd in
    let player_data = NetworkIO.read_line io in
    flush stdout;
    NetworkIO.send_string io (option_string options);
    let unit_type_data    = NetworkIO.read_line io in
    let location_data     = NetworkIO.read_line io in
    let map_data          = NetworkIO.read_line io in
    let tech_type_data    = NetworkIO.read_line io in
    let upgrade_type_data = NetworkIO.read_line io in

    let (p_id, p_race, e_id, e_race) = parse_player player_data in
    let units = parse_units    unit_type_data    in
    let locs  = parse_location location_data     in
    let map   = parse_map      map_data          in
    let techs = parse_techs    tech_type_data    in
    let upgr  = parse_upgrades upgrade_type_data in
    ()

let _ = main ()