Create a gist now

Instantly share code, notes, and snippets.

What would you like to do?
(* -*- mode: ocaml; -*- *)
module type NEXT =
sig
type 'a t
exception Timing_error of int * int
val delay : (unit -> 'a) -> 'a t
val map : ('a -> 'b) -> 'a t -> 'b t
val zip : 'a t * 'b t -> ('a * 'b) t
val unzip : ('a * 'b) t -> 'a t * 'b t
val ($) : ('a -> 'b) t -> 'a t -> 'b t (* This op is redundant but convenient *)
val fix : ('a t -> 'a) -> 'a
(* Use these operations to implement an event loop *)
module Runtime : sig
val tick : unit -> unit
val force : 'a t -> 'a
end
end
module Next : NEXT = struct
let time = ref 0
type 'a t = {
time : int;
mutable code : 'a Lazy.t
}
type s = Hide : 'a t -> s
let thunks : s list ref = ref []
exception Timing_error of int * int
let delay t =
let t = { time = 1 + !time; code = Lazy.from_fun t} in
thunks := (Hide t) :: !thunks;
t
let force t =
if t.time != !time then
raise (Timing_error(t.time, !time))
else
Lazy.force t.code
let map f r = delay (fun () -> f (force r))
let zip (r, r') = delay (fun () -> (force r, force r'))
let unzip r = (map fst r, map snd r)
let ($) f x = delay (fun () -> force f (force x))
let rec fix f = f (delay (fun () -> fix f))
module Runtime = struct
let force = force
let cleanup (Hide t) =
let b = t.time < !time in
(if b then t.code <- lazy (raise (assert false)));
b
let tick () =
time := !time + 1;
thunks := List.filter cleanup !thunks
end
end
module Stream :
sig
type 'a stream = Cons of 'a * 'a stream Next.t
val head : 'a stream -> 'a
val tail : 'a stream -> 'a stream Next.t
val unfold : ('a -> 'b * 'a Next.t) -> 'a -> 'b stream
val map : ('a -> 'b) -> 'a stream -> 'b stream
val zip : 'a stream * 'b stream -> ('a * 'b) stream
val unzip : ('a * 'b) stream -> 'a stream * 'b stream
end =
struct
open Next
type 'a stream = Cons of 'a * 'a stream Next.t
let head (Cons(x, xs)) = x
let tail (Cons(x, xs)) = xs
let map f = fix (fun loop (Cons(x, xs)) -> Cons(f x, loop $ xs))
let unfold f = fix (fun loop seed ->
let (x, seed) = f seed in
Cons(x, loop $ seed))
let zip pair =
unfold (fun (Cons(x, xs), Cons(y, ys)) -> ((x, y), Next.zip (xs, ys)))
pair
let unzip xys = fix (fun loop (Cons((x,y), xys')) ->
let (xs', ys') = Next.unzip (loop $ xys') in
(Cons(x, xs'), Cons(y, ys')))
xys
end
module Event :
sig
type 'a event = Now of 'a | Wait of 'a event Next.t
val map : ('a -> 'b) -> 'a event -> 'b event
val return : 'a -> 'a event
val bind : 'a event -> ('a -> 'b event) -> 'b event
val select : 'a event -> 'a event -> 'a event
end =
struct
open Next
type 'a event = Now of 'a | Wait of 'a event Next.t
let map f = fix (fun loop e ->
match e with
| Now x -> Now (f x)
| Wait e' -> Wait (loop $ e'))
let return x = Now x
let bind m f =
fix (fun bind m ->
match m with
| Now v -> f v
| Wait e' -> Wait (bind $ e'))
m
let select e1 e2 =
fix (fun loop e1 e2 ->
match e1, e2 with
| Now a1, _ -> Now a1
| _, Now a2 -> Now a2
| Wait e1, Wait e2 -> Wait (loop $ e1 $ e2))
e1
e2
end
module Test =
struct
open Next
open Stream
let ints n = unfold (fun i -> (i, delay(fun () -> i+1))) n
let rec run k xs =
if k = 0
then ()
else
let (x, xs) = (head xs, tail xs) in
Printf.printf "%d\n" x;
Runtime.tick();
run (k-1) (Runtime.force xs)
end

yminsky commented Aug 17, 2015

Shouldn't this line be "lazy (assert false)" rather than "lazy (raise (assert false))"?

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment