Commits

jprider63  committed 6ce0b80

Backed out changeset d53cb813aebd

  • Participants
  • Parent commits d53cb81

Comments (0)

Files changed (4)

 
 as2-test : check ocamlbuild//runas2testlazysabidi.native ocamlbuild//runas2testnonsaeager.native ocamlbuild//runas2testeagersatotalorder.native
 
-fas2 : check ocamlbuild//runfas2.native 
-
 frtime : check $(addprefix ocamlbuild//Frtime.,cmxa a cma cmi)
 
 frtime-test : check ocamlbuild//frtimetest.native

File Source/Frtime/behavior.ml

 
 	(* Core combinators. *)
 	val const : (module Hashtbl.SeededHashedType with type t = 'a ) -> 'a -> 'a behavior
-	(*val memo_const : (module Hashtbl.SeededHashedType with type t = 'a ) -> 'a -> 'a behavior*)
+	val memo_const : (module Hashtbl.SeededHashedType with type t = 'a ) -> 'a -> 'a behavior
 	val app : ('a->'b) behavior -> (module Hashtbl.SeededHashedType with type t = 'b ) -> 'a behavior -> 'b behavior
 	val memo_app : ('a->'b) behavior -> (module Hashtbl.SeededHashedType with type t = 'b ) -> 'a behavior -> 'b behavior
 	(* TODO:val memo_app ... *)
 	
 	(* Alarm. *)
 	val seconds : unit -> time behavior
-	val time : unit -> time behavior
 
 	(* Extractors. *)
 	val force : 'a behavior -> 'a
 		let t = Tm.const (get_time ()) in
 		(module R), r, t
 
-	(*
 	(* Universal type hackery. 
 	https://ocaml.janestreet.com/?q=node/18
 	*)
 			(fun x -> M.E x), (function M.E x -> Some x | _ -> None)
 	end
 	
-	let memo_const_store = Mixtbl.create 10(*ref []*) (*Hashtbl.create 10*)
-	let memo_const (type t) (module H : Hashtbl.SeededHashedType with type t = t) (c : t) : t behavior = 
-		(*
-		let of1, to1 = Univ.embed () in
-		let of2, to2 = Univ.embed () in
-		let i = ref (of1 13) in
-		assert( to1 !i = Some 13);
-		assert( to2 !i = Some 13);
-		*)
+	let memo_const_store = ref [] (*Hashtbl.create 10*)
+	let memo_const (type t) (module H : Hashtbl.SeededHashedType with type t = t) : t -> t behavior = 
 		let module R = M.Make( H) in
 		let memo = 
-			let get, set = Mixtbl.access () in
-			match get memo_const_store c with
-			| Some m -> 
-				m
-			| None ->
-				let m = R.memo (module R.Data) (fun _ c' -> c') in
-				set memo_const_store c m;
-				m
-		in
-		(*
-		let memo = 
 			let (of_memo_t, to_memo_t) = Univ.embed () in
 			let rec helper = function
 			| [] ->
 			in
 			helper !memo_const_store
 		in	
+		(*
 		let memo = 
 			let mod_r = (module R : SAType.S with type sa = M.sa and type data = t and type t = t M.thunk) in
 			try
 		*)
 		(*let r = memo c in*)
 		let t = Tm.const (get_time ()) in
-		(*fun (c : t) ->*)
+		fun (c : t) ->
 			(module R), memo c, t
-	*)
 		
 	let app (type a) (type b) (((module F), f, tf) : (a -> b) behavior) (module B : Hashtbl.SeededHashedType with type t = b) (((module A), a, ta) : a behavior) : b behavior = 
 		let module R = M.Make( B) in
 		let c = !seconds_store in
 		match c with
 		| None ->
-			(* Can use a store since the value behaviors is forced first and there is not past dependence. *)
-			let store = ref (from_seconds 0.0) in
-			let t = Tm.thunk (fun () -> !store) in
 			let r = Tm.const (get_time ()) in
 			let handle = S.Signal_handle (fun s ->
 				if s <> S.sigalrm then (
 					Printf.printf "Error: FRP seconds handler called for non alarm signal.\n";
 					()
 				) else (
-					let t' = get_time () in
-					store := t';
-					Tm.update_const r t';
+					Tm.update_const r (get_time ());
 					ignore (U.alarm 1);
 					()
 				)
 			in
 			S.set_signal S.sigalrm handle;
 			ignore (U.alarm 1);
-			let beh = (module Tm : SAType.S with type sa = M.sa and type data = time and type t = time M.thunk), r, t in
+			let beh = (module Tm : SAType.S with type sa = M.sa and type data = time and type t = time M.thunk), r, r in
 			seconds_store := Some beh;
 			beh
 		| Some c' ->
 			c'
 
-	(* Time store used to only create one time behavior. *)
-	let time_store = ref None
-	let time () = 
-		match !time_store with
-		| None ->
-			(* Can use a store since the value behaviors is forced first and there is not past dependence. *)
-			let store = ref (from_seconds 0.0) in
-			let t = Tm.thunk (fun () -> !store) in
-			let r = Tm.thunk (fun () ->
-				let t' = get_time () in
-				store := t';
-				t'
-			)
-			in
-			let beh = (module Tm : SAType.S with type sa = M.sa and type data = time and type t = time M.thunk), r, t in
-			time_store := Some beh;
-			beh
-		| Some c ->
-			c
-
 	let force (type a) (((module A), a, _) : a behavior) : a =
 		A.force a
 	

File Source/Frtime/time.ml

 type time = float
 
 let to_seconds (t : time) : float = t
-let from_seconds (s : float) : time = s
 
 let get_time = Unix.gettimeofday
 

File Test/frtimetest.ml

 let ifb = B.ifb oddGuard oddCase evenCase
 let branched = B.app ifb (module T.Unit) ellapsed
 
-let rec loop () = 
-	(*print_time ()l*)
-	B.force branched;
+let rec loop i = 
+	(if false then
+		print_time ()
+	else
+		ignore (B.force branched)
+	);
 	(*Unix.sleep 1;*)
-	loop ()
+	loop (i+1)
 
-let _ = 
-	assert (oddCase != evenCase);
-	assert (evenCase == evenCase);
-	(*testUniv ();*)
-	loop ()
-
-(*
-module Orbiter = struct
-	open Num
-
-	type satellite = {
-		mass : num;
-		altitude0 : num;
-		vel_x0 : num;
-		vel_y0 : num
-	}
-
-	type earth = {
-		mass : num
-	}
-
-	let run () = 
-		let t : Tm.time B.behavior = B.time () in
-		let elapsed : float B.behavior = 
-			let store = ref (Tm.to_seconds (B.force t)) in
-			B.lift (fun t' -> (Tm.to_seconds t') -. !store) (module T.Float) t
-		in
-		let earth : earth = { mass = (Int 5972) */ ((Int 10) **/ (Int 21)) } in
-		ignore (earth);
-		ignore (elapsed);
-		()
-
-end
-
-let _ = Orbiter.run ()
-*)
-
-
-(*
 let testUniv () = 
 	let id x = x in
 	(*let module F = T.makeFunction () in*)
 	assert (B.memo_const (T.makeFunction ()) id == B.memo_const (T.makeFunction ()) id);
 	assert (B.memo_const (T.makeFunction ()) id != B.memo_const (T.makeFunction ()) (fun x -> x));
 	()
-*)
+
+let _ = 
+	assert (oddCase != evenCase);
+	assert (evenCase == evenCase);
+	testUniv ();
+	loop 0
+