tsdl

main.ml

open Batteries
open Tsdl

exception Fucked of string

let width = 640
let height = 480
let pi = 4.0 *. atan 1.0

let value = function
    | `Error e -> raise (Fucked e)
    | `Ok v -> v

type lifetime =
    { lives : int
    ; dying : bool
    }

let immortal = { lives = 1; dying = false }

type entity =
    { x : float
    ; y : float
    ; size : int
    ; v : float
    ; t : float
    ; lifet : lifetime
    }

let render_entity renderer e =
    let d = e.size / 2 in
    let x = int_of_float e.x in
    let y = int_of_float e.y in
    let rect = Sdl.Rect.create (x - d) (y - d) d d in
    if e.lifet.dying
    then
        if e.lifet.lives < 0
        then `Ok ()
        else Sdl.render_fill_rect renderer (Some rect)
    else Sdl.render_fill_rect renderer (Some rect)


let update e =
    let dx = (cos e.t) *. e.v in
    let dy = (sin e.t) *. e.v in
    let lifet = e.lifet in
    { e with
      x = e.x +. dx
    ; y = e.y +. dy
    ; lifet = { lifet with lives = lifet.lives - 1 }
    }

let particle () =
    let size = 2 + (Random.int 10) in
    let lives = Random.int (25 * size) in
    { x = 250.0
    ; y = 250.0
    ; size = size
    ; v = Random.float 1.0
    ; t = Random.float (pi *. 2.0)
    ; lifet = { lives = lives; dying = true }
    }

type state =
    { player : entity
    ; particles : entity list
    ; ticks : int * Sdl.uint32
    }

let init =
    { player =
        { x = 250.0
        ; y = 250.0
        ; size = 50
        ; v = 1.5
        ; t = pi /. 4.0
        ; lifet = immortal
        }
    ; particles =
        List.of_enum (1--256)
        |> List.map (fun v -> particle ())
    ; ticks = (0, 0l)
    }

let update_state s ticks =
    { player = update s.player
    ; particles = List.map update s.particles
    ; ticks = ticks
    }

let state_renderer state =
    let renderer = Renderer.create render_entity in
    Renderer.and_then
        (renderer state.player)
        (List.map renderer state.particles |> Renderer.sequence)

let always x y = x

let draw r state =
    let (t, ticks) = state.ticks in

    Sdl.set_render_draw_color r 0x00 0x00 0x00 0x00 |> value;
    Sdl.render_clear r |> value;
    Sdl.set_render_draw_color r 0xFF 0xFF 0xFF 0xFF |> value;
    Renderer.render r (state_renderer state) |> value;

    for i = 0 to 50 do
        let j = (t mod 25) + (i * 25) in
        Sdl.render_draw_line r 0 j width j |> value;
    done;

    Sdl.render_present r

let run send =
    for t = 0 to 300 do
        send (t, Sdl.get_ticks ());
        Sdl.delay 16l
    done

let main () =
    Sdl.init Sdl.Init.video |> value;
    let (window, renderer) =
        Sdl.create_window_and_renderer
            ~w:width
            ~h:height
            Sdl.Window.shown
        |> value
    in
    let e, send = React.E.create () in
    let state   = React.S.fold update_state init e in
    let view    = React.S.map (draw renderer) state in
    run send;
    React.E.stop e;
    React.S.stop state;
    React.S.stop view;
    Sdl.delay 3000l;
    Sdl.destroy_renderer renderer;
    Sdl.destroy_window window;
    Sdl.quit ()

let () =
    main ()

renderer.ml

open Tsdl

type 'a t =
    { run : (Sdl.renderer -> 'a -> unit Sdl.result)
    ; ctx : 'a
    }

let create run ctx =
    { run = run
    ; ctx = ctx
    }

let render renderer t =
    t.run renderer t.ctx

let always x y = x

let and_then a b =
    { run = begin fun renderer (ac, bc) ->
        Results.and_then (always (render renderer bc)) (render renderer ac)
    end
    ; ctx = (a, b)
    }

let blank =
    { run = (fun renderer t -> `Ok ())
    ; ctx = ()
    }

let sequence items =
    { run = begin fun renderer items ->
        let folder acc item =
            Results.and_then (always (render renderer item)) acc
        in
        List.fold_left folder (`Ok ()) items
    end
    ; ctx = items
    }

results.ml

let and_then fn = function
    | `Error e -> `Error e
    | `Ok v -> fn v

let map fn = function
    | `Error e -> `Error e
    | `Ok v -> `Ok (fn v)