Created
April 12, 2016 15:15
-
-
Save dagoof/8a4ae7b8f83f1db726bf2ade46c7b217 to your computer and use it in GitHub Desktop.
tsdl
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
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 () |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
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 | |
} |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
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) |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment