Commits

Yit Phang Khoo committed 42c0111

Move As2 and Adaptime into a new directory Applications.

Comments (0)

Files changed (29)

Applications/Adaptime/Adaptime.mllib

+Adaptime

Applications/Adaptime/Adaptime.mlpack

+Adaptime/Behavior
+Adaptime/Time

Applications/Adaptime/Adaptime/_tags

+<*.cm*>: for-pack(Adaptime)

Applications/Adaptime/Adaptime/behavior.ml

+
+open Adapton.Signatures
+open Time
+module T = Adapton.Types
+
+module type Behavior = sig
+	type 'a behavior
+
+	(* 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 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 ... *)
+	(* val flatten? *)
+	(* val prev : 'a behavior -> 'a -> 'a behavior *)
+	(* How do I implement this?
+	val fix : ('a behavior -> 'a behavior) -> 'a behavior
+	*)
+
+	(*
+	(* val appf? implement without flatten? *)
+
+	val filter : ('a -> bool) -> 'a behavior -> 'a behavior
+	when
+
+	TODO: 
+		memo_app
+		ifb -> switch? ifb (thunkified)
+
+	
+	more...?
+		? update_const/trigger ?
+
+
+
+
+	*)
+	val merge : 'a behavior -> 'a behavior -> 'a behavior
+	val ifb : bool behavior -> 'a behavior -> 'a behavior -> 'a behavior
+
+	(* Derived combinators. *)
+	val lift : ('a -> 'b) -> (module Hashtbl.SeededHashedType with type t = 'b ) -> 'a behavior -> 'b behavior
+	val lift2 : ('a -> 'b -> 'c) -> (module Hashtbl.SeededHashedType with type t = 'c ) -> 'a behavior -> 'b behavior-> 'c behavior
+	val lift3 : ('a -> 'b -> 'c -> 'd) -> (module Hashtbl.SeededHashedType with type t = 'd ) -> 'a behavior -> 'b behavior-> 'c behavior -> 'd behavior
+	val lift4 : ('a -> 'b -> 'c -> 'd -> 'e) -> (module Hashtbl.SeededHashedType with type t = 'e ) -> 'a behavior -> 'b behavior-> 'c behavior -> 'd behavior -> 'e behavior
+
+	val memo_lift : ('a -> 'b) -> (module Hashtbl.SeededHashedType with type t = 'b ) -> 'a behavior -> 'b behavior
+	val memo_lift2 : ('a -> 'b -> 'c) -> (module Hashtbl.SeededHashedType with type t = 'c ) -> 'a behavior -> 'b behavior-> 'c behavior
+	val memo_lift3 : ('a -> 'b -> 'c -> 'd) -> (module Hashtbl.SeededHashedType with type t = 'd ) -> 'a behavior -> 'b behavior-> 'c behavior -> 'd behavior
+	val memo_lift4 : ('a -> 'b -> 'c -> 'd -> 'e) -> (module Hashtbl.SeededHashedType with type t = 'e ) -> 'a behavior -> 'b behavior-> 'c behavior -> 'd behavior -> 'e behavior
+	
+	(* Alarm. *)
+	val seconds : unit -> time behavior
+	val time : unit -> time behavior
+
+	(* Extractors. *)
+	val force : 'a behavior -> 'a
+	val id : 'a behavior -> int
+end
+
+(* Make a behavior, given a SAType. *)
+module Make (M : SAType) : Behavior = struct
+	module Tm = TimeType(M)
+	module S = Sys
+	module U = Unix
+
+	type 'a sa_mod = (module SAType.S with type sa = M.sa and type data = 'a and type t = 'a M.thunk)
+	type 'a behavior = 'a sa_mod * 'a M.thunk * time M.thunk
+	(* Requirement: Always force 'a thunk before time thunk. *)
+
+	let const (type t) (module H : Hashtbl.SeededHashedType with type t = t) (c : t) : t behavior = 
+		let module R = M.Make( H) in
+		let r = R.const c in
+		let t = Tm.const (get_time ()) in
+		(module R), r, t
+
+	(*
+	(* Universal type hackery. 
+	https://ocaml.janestreet.com/?q=node/18
+	*)
+	module Univ : sig
+		type t
+		val embed: unit -> ('a -> t) * (t -> 'a option)
+	end = struct 
+		type t = exn
+
+		let embed (type s) () =
+			let module M = struct exception E of s end in
+			(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 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
+			| [] ->
+				let m = R.memo (module R.Data) (fun _ c' -> c') in
+				let m' = ref (of_memo_t m) in
+				memo_const_store := m'::!memo_const_store;
+				Printf.printf "memo_const: making new..\n%!";
+				m
+			| h::t ->
+				let m = to_memo_t !h in
+				match m with
+				| None ->
+					Printf.printf "memo_const: not this one\n%!";
+					helper t
+				| Some m' ->
+					Printf.printf "memo_const: found!\n%!";
+					m'
+			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
+				Hashtbl.find memo_const_store mod_r
+			with
+			| Not_found -> 
+				let m = R.memo (module R.Data) (fun _ c' -> c') in
+				Hashtbl.add memo_const_store mod_r m
+		in
+		*)
+		(*let r = memo c in*)
+		let t = Tm.const (get_time ()) in
+		(*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 r = R.thunk (fun () -> (F.force f) (A.force a)) in
+		let t = Tm.thunk (fun () -> max_time [ Tm.force tf; Tm.force ta]) in
+		(module R), r, t
+	
+	let memo_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 memo = R.memo2 (module F.Data) (module A.Data) (fun _ f' a' -> f' a') in
+		let r = R.thunk (fun () -> R.force (memo (F.force f) (A.force a))) in
+		let t = Tm.thunk (fun () -> max_time [ Tm.force tf; Tm.force ta]) in
+		(module R), r, t
+
+		
+	(* Contains the previous value of the behavior. Takes on the default value until the behavior changes. *)
+	(* TODO: Not pure... How do we fix this?
+	let prev (type a) (((module A), a, ta) : a behavior) (default : a) : a behavior =
+		(* TODO: Combine stores? Otherwise, might lead to race conditions?
+		Need to keep track of times, to see if force causes store to update.
+		let store = ref (default, get_time ()) in
+		*)
+		let valStore = ref default in
+		let tmStore = ref (get_time ()) in (* default time should time prev was called? *)
+		let r = A.thunk (fun () ->
+			let r' = !valStore in
+			valStore := A.force a;
+			r'
+		)
+		in
+		let t = Tm.thunk (fun () ->
+			let t' = !tmStore in
+			tmStore := Tm.force ta;
+			t'
+		)
+		in
+		(module A), r, t
+	*)
+
+	let lift (type a) (type b) (f : a -> b) (module B : Hashtbl.SeededHashedType with type t = b) (a : a behavior) : b behavior =
+		let mF = T.makeFunction () in
+		let f' = const mF f in
+		app f' (module B) a
+
+	let lift2 (type a) (type b) (type c) (f : a -> b -> c) (module C : Hashtbl.SeededHashedType with type t = c) (a : a behavior) (b : b behavior) : c behavior =
+		let mF = T.makeFunction () in
+		let f' = lift f mF a in
+		app f' (module C) b
+	
+	let lift3 (type a) (type b) (type c) (type d) (f : a -> b -> c -> d) (module D : Hashtbl.SeededHashedType with type t = d) (a : a behavior) (b : b behavior) (c : c behavior) : d behavior =
+		let mF = T.makeFunction () in
+		let f' = lift2 f mF a b in
+		app f' (module D) c
+	
+	let lift4 (type a) (type b) (type c) (type d) (type e) (f : a -> b -> c -> d -> e) (module E : Hashtbl.SeededHashedType with type t = e) (a : a behavior) (b : b behavior) (c : c behavior) (d : d behavior) : e behavior =
+		let mF = T.makeFunction () in
+		let f' = lift3 f mF a b c in
+		app f' (module E) d
+
+	let memo_lift (type a) (type b) (f : a -> b) (module B : Hashtbl.SeededHashedType with type t = b) ((module A), a, ta : a behavior) : b behavior =
+		let module R = M.Make( B) in
+		let memo = R.memo (module A.Data) (fun _ -> f) in
+		let r = R.thunk (fun () -> R.force (memo (A.force a))) in
+		let t' = Tm.const (get_time ()) in
+		let t = Tm.thunk (fun () -> max_time [ Tm.force t'; Tm.force ta]) in
+		(module R), r, t
+		
+	(* Can't be compositional here because memoizing on closures does not work. *)
+	let memo_lift2 (type a) (type b) (type c) (f : a -> b -> c) (module C : Hashtbl.SeededHashedType with type t = c) ((module A), a, ta : a behavior) ((module B), b, tb : b behavior) : c behavior =
+		let module R = M.Make( C) in
+		let memo = R.memo2 (module A.Data) (module B.Data) (fun _ -> f) in
+		let r = R.thunk (fun () -> R.force (memo (A.force a) (B.force b))) in
+		let t' = Tm.const (get_time ()) in
+		let t = Tm.thunk (fun () -> max_time [ Tm.force t'; Tm.force ta; Tm.force tb]) in
+		(module R), r, t
+		(*
+		let mF = T.makeFunction () in
+		let f' = memo_lift f mF a in
+		memo_app f' (module C) b
+		*)
+
+	let memo_lift3 (type a) (type b) (type c) (type d) (f : a -> b -> c -> d) (module D : Hashtbl.SeededHashedType with type t = d) ((module A), a, ta : a behavior) ((module B), b, tb : b behavior) ((module C), c, tc : c behavior) : d behavior =
+		let module R = M.Make( D) in
+		let memo = R.memo3 (module A.Data) (module B.Data) (module C.Data) (fun _ -> f) in
+		let r = R.thunk (fun () -> R.force (memo (A.force a) (B.force b) (C.force c))) in
+		let t' = Tm.const (get_time ()) in
+		let t = Tm.thunk (fun () -> max_time [ Tm.force t'; Tm.force ta; Tm.force tb; Tm.force tc]) in
+		(module R), r, t
+
+	let memo_lift4 (type a) (type b) (type c) (type d) (type e) (f : a -> b -> c -> d -> e) (module E : Hashtbl.SeededHashedType with type t = e) ((module A), a, ta : a behavior) ((module B), b, tb : b behavior) ((module C), c, tc : c behavior) ((module D), d, td : d behavior) : e behavior =
+		let module R = M.Make( E) in
+		let memo = R.memo4 (module A.Data) (module B.Data) (module C.Data) (module D.Data) (fun _ -> f) in
+		let r = R.thunk (fun () -> R.force (memo (A.force a) (B.force b) (C.force c) (D.force d))) in
+		let t' = Tm.const (get_time ()) in
+		let t = Tm.thunk (fun () -> max_time [ Tm.force t'; Tm.force ta; Tm.force tb; Tm.force tc; Tm.force td]) in
+		(module R), r, t
+
+	(* Take on the value of the most recently updated behavior. *)
+	let merge (type a) (((module A), a, ta) : a behavior) (( _, b, tb) : a behavior) : a behavior =
+		(* Precompute force to satisfy requirement and maintain consistency. *)
+		ignore (A.force a);
+		ignore (A.force b);
+		let t = Tm.const (max_time [ Tm.force ta; Tm.force tb]) in
+		let r = A.thunk (fun () ->
+			let ta' = Tm.force ta in
+			let tb' = Tm.force tb in
+			A.force begin
+				(* ta < tb -> !(ta >= tb) *)
+				if cmp_time ta' tb' then (
+					Tm.update_const t tb';
+					b
+				) else (
+					Tm.update_const t ta';
+					a
+				)
+			end
+		)
+		in
+		(*let t = Tm.thunk (fun () -> max_time [ Tm.force ta; Tm.force tb]) in (* TODO: switch to a tmStore? *)*)
+		(module A), r, t
+
+	(*
+	(* Only pass on events that satisfy the predicate. add a default? *)
+	let filter (type a) (pred : a -> bool) (((module A), a, ta) : a behavior) : a behavior =
+		let t = Tm.const (Tm.force ta) in
+		let r = A.thunk (fun () ->
+			let a' = A.force a in
+			if pred a' then
+				Tm.update_const t (Tm.force ta);
+				a'
+			else
+				...
+		)
+		in
+		(module A), r, t
+	*)
+
+	let ifb (type a) (((module G), g, tg) : bool behavior) (((module A), a, ta) : a behavior) ((_, b, tb) : a behavior) : a behavior = 
+		let r = A.thunk (fun () ->
+			A.force begin
+				if G.force g then
+					a
+				else
+					b
+			end
+		)
+		in
+		let t = Tm.thunk (fun () -> max_time [ Tm.force tg; Tm.force ta; Tm.force tb]) in
+		(module A), r, t
+
+	let seconds_store = ref None
+	let seconds () : time behavior = 
+		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';
+					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
+			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
+	
+	(* Returns the id of the underlying thunk. *)
+	let id (type a) ((module A), a, _ : a behavior) : int = 
+		A.id a
+end
+

Applications/Adaptime/Adaptime/time.ml

+
+type time = float
+
+let to_seconds (t : time) : float = t
+let from_seconds (s : float) : time = s
+
+let get_time = Unix.gettimeofday
+
+let cmp_time = (<)
+
+let min_time (l : time list) : time = 
+	List.fold_left min max_float l
+
+let max_time (l : time list) : time = 
+	List.fold_left max min_float l
+
+module TimeType (M : Adapton.Signatures.SAType) = M.Make( Adapton.Types.Float)
+

Applications/As2/As2.mlpack

+As2/Ast
+As2/Global
+As2/Interp
+As2/Lexer
+As2/Main
+As2/Parser

Applications/As2/As2/Ast.ml

+
+module type S = sig
+  module A : Adapton.PolySA.S
+
+  type col = int
+  type row = int
+  type sht = int
+
+  (** -- commands -- **)
+
+  type cmd =
+    | C_help | C_exit
+    | C_nav of nav_cmd
+    | C_mut of mut_cmd
+    | C_seq of cmd * cmd
+    | C_print
+    | C_repeat of formula' * cmd
+
+  and scramble_flags =
+    | Sf_sparse
+    | Sf_dense
+    | Sf_one
+
+  and mut_cmd =
+    | C_set of formula'
+    | C_scramble of scramble_flags
+
+  and nav_cmd =
+    | C_next of nav_thing
+    | C_prev of nav_thing
+    | C_goto of coord
+
+  and nav_thing = Nav_row | Nav_col | Nav_sht
+
+  (** - - Coordinates, Regions - - **)
+
+  and local_coord = col * row
+  and absolute_coord = sht * local_coord
+  and pos = absolute_coord
+      (* pos is nice short-hand; pos is a "cononical form" for
+         coordinates within the interpreter. *)
+  and coord =
+    | Lcl of local_coord
+    | Abs of absolute_coord
+
+  and local_region = local_coord * local_coord
+  and absolute_region = sht * local_region
+  and region =
+    | R_lcl of local_region
+    | R_abs of absolute_region
+
+  (** - - Formulas - - **)
+
+  and formula =
+    | F_func of func * region
+    | F_binop of binop * formula' * formula'
+    | F_const of const
+    | F_coord of coord
+    | F_paren of formula'
+
+  and formula' = formula A.thunk
+
+  and binop =
+    | Bop_add
+    | Bop_sub
+    | Bop_div
+    | Bop_mul
+
+  and func =
+    | Fn_sum
+    | Fn_max
+    | Fn_min
+
+  and const =
+    | Num   of Num.num (* ocaml standard library; arbitrary-precision numbers. *)
+    | Fail
+    | Undef
+
+  val absolute : sht -> coord -> pos
+  val frm_equal : formula -> formula -> bool
+  val frm_hash : int -> formula -> int
+  val memo_frm : formula -> formula'
+
+  module Pretty : sig
+    val string_of_const : const -> string
+    val pp_cmd : cmd -> unit
+    val pp_nav_cmd : nav_cmd -> unit
+    val pp_nav_thing : nav_thing -> unit
+    val pp_local_coord : local_coord -> unit
+    val pp_pos : pos -> unit
+    val pp_coord : coord -> unit
+    val pp_local_region : local_region -> unit
+    val pp_region : region -> unit
+    val pp_mut_cmd : mut_cmd -> unit
+    val pp_formula : formula -> unit
+    val pp_formula' : formula' -> unit
+    val pp_binop : binop -> unit
+    val pp_func : func -> unit
+  end
+end
+
+module Make (SA : Adapton.Signatures.SAType) : S with module A = Adapton.PolySA.Make (SA) = struct
+  module A = Adapton.PolySA.Make (SA)
+
+  type col = int
+  type row = int
+  type sht = int
+
+  (** -- commands -- **)
+
+  type cmd =
+    | C_help | C_exit
+    | C_nav of nav_cmd
+    | C_mut of mut_cmd
+    | C_seq of cmd * cmd
+    | C_print
+    | C_repeat of formula' * cmd
+
+  and scramble_flags = 
+    | Sf_sparse 
+    | Sf_dense 
+    | Sf_one
+
+  and mut_cmd =
+    | C_set of formula'
+    | C_scramble of scramble_flags
+
+  and nav_cmd =
+    | C_next of nav_thing
+    | C_prev of nav_thing
+    | C_goto of coord
+
+  and nav_thing = Nav_row | Nav_col | Nav_sht
+
+  (** - - Coordinates, Regions - - **)
+
+  and local_coord = col * row
+  and absolute_coord = sht * local_coord
+  and pos = absolute_coord
+      (* pos is nice short-hand; pos is a "cononical form" for
+         coordinates within the interpreter. *)
+  and coord =
+    | Lcl of local_coord
+    | Abs of absolute_coord
+
+  and local_region = local_coord * local_coord
+  and absolute_region = sht * local_region
+  and region =
+    | R_lcl of local_region
+    | R_abs of absolute_region
+
+  (** - - Formulas - - **)
+
+  and formula =
+    | F_func of func * region
+    | F_binop of binop * formula' * formula'
+    | F_const of const
+    | F_coord of coord
+    | F_paren of formula'
+
+  and formula' = formula A.thunk
+
+  and binop =
+    | Bop_add
+    | Bop_sub
+    | Bop_div
+    | Bop_mul
+
+  and func =
+    | Fn_sum
+    | Fn_max
+    | Fn_min
+
+  and const =
+    | Num   of Num.num (* ocaml standard library; arbitrary-precision numbers. *)
+    | Fail
+    | Undef
+          
+  (* create an absolute coord *)
+  let absolute : sht -> coord -> pos
+    = fun s -> function
+      | Abs(s',(c,r)) -> (s',(c,r))
+      | Lcl(c,r)      -> (s,(c,r))
+
+  let frm_equal f1 f2 = match f1, f2 with
+    | F_func (f1, reg1),      F_func (f2, reg2)      -> f1 = f2 && reg1 = reg2
+    | F_binop (b1, f11, f12), F_binop (b2, f21, f22) -> b1 = b2 && (A.id f11 = A.id f21) && (A.id f12 = A.id f22)
+    | F_const (Num n1),       F_const (Num n2)       -> (Num.compare_num n1 n2) = 0
+    | F_const (Fail | Undef), _                      -> false
+    | _,                      F_const (Fail | Undef) -> false
+    | F_coord c1,             F_coord c2             -> c1 = c2
+    | F_paren f1,             F_paren f2             -> A.id f1 = A.id f2
+    | _,                      _                      -> false
+
+(*
+seeded_hash (seeded_hash seed "F_const") "Fail"
+seeded_hash (seeded_hash (seeded_hash (seeded_hash seed "F_const") "Num")) n
+*)
+
+  open Hashtbl
+
+  let rec frm_hash x f = 
+    let my_hash x thing = 
+      seeded_hash_param 10 100 x thing
+    in
+    match f with
+      | F_func (f, reg) -> 
+          let x = my_hash x f in
+          let x = my_hash x reg in
+        x
+    | F_binop (b, f1, f2) -> 
+        let x = my_hash x b in
+        let x = my_hash x (A.id f1) in
+        let x = my_hash x (A.id f2) in
+        x
+    | F_paren f        -> my_hash x f
+    | F_coord c        -> my_hash x f
+    | F_const (Num n)  -> my_hash x n
+    | F_const Fail     -> my_hash x "F"
+    | F_const Undef    -> my_hash x "U"
+
+  (* hash-cons'd formulae: *)
+  let memo_frm : formula -> formula' = 
+    let f = 
+      A.memo ~inp_equal:frm_equal ~inp_hash:frm_hash begin 
+        fun f frm -> frm end
+    in f
+
+  module Pretty = struct
+
+    let string_of_const = function
+      | Num n -> Num.approx_num_exp 10 n
+      | Fail  -> "#fail"
+      | Undef -> "#undef"
+
+    let ps = print_string
+
+    let rec pp_cmd = function
+      | C_help -> ps "help"
+      | C_exit -> ps "exit"
+      | C_nav c -> pp_nav_cmd c
+      | C_mut c -> pp_mut_cmd c
+      | C_print -> ps "print"
+      | C_seq (c1, c2) -> pp_cmd c1 ; ps "; " ; pp_cmd c2
+      | C_repeat (f, c) ->
+          ps "repeat " ;
+          pp_formula' f ; ps " do " ;
+          pp_cmd c ;
+          ps " done"
+
+    (** - - Navigation / Focus - - **)
+
+    and pp_nav_cmd = function
+      | C_next nt -> ps "next " ; pp_nav_thing nt
+      | C_prev nt -> ps "prev " ; pp_nav_thing nt
+      | C_goto c -> ps "goto " ; pp_coord c
+
+    and pp_nav_thing = function
+      | Nav_row -> ps "row"
+      | Nav_col -> ps "col"
+      | Nav_sht -> ps "sheet"
+
+    (** - - Coordinates, Regions - - **)
+
+    and pp_local_coord = fun (col,row) ->
+      ps (String.make 1 (Char.chr ((Char.code 'A') + col - 1))) ;
+      (* ps "[" ; ps (string_of_int col) ; ps "]" ; *)
+      ps (string_of_int row)
+
+    and pp_pos (s,lc) = pp_coord (Abs(s,lc))
+    and pp_coord = function
+      | Lcl lc -> pp_local_coord lc
+      | Abs (s,lc) ->
+          ps "sheet" ; ps (string_of_int s) ; ps "!" ;
+          pp_local_coord lc
+
+    and pp_local_region = fun (lc1,lc2) ->
+      pp_local_coord lc1 ; ps ":" ;
+      pp_local_coord lc2
+
+    and pp_region = function
+    | R_lcl lr -> pp_local_region lr
+    | R_abs (s,lr) ->  ps (string_of_int s) ; pp_local_region lr
+
+    (** - - Formulas - - **)
+
+    and pp_mut_cmd = function
+      | C_set f -> ps "=" ; pp_formula' f ; ps "."
+      | C_scramble Sf_sparse -> ps "scramble"
+      | C_scramble Sf_dense  -> ps "scrambled"
+      | C_scramble Sf_one    -> ps "scramble1"
+
+    and pp_formula = function
+      | F_func (f,r) -> pp_func f ; ps "(" ; pp_region r ; ps ")"
+      | F_binop (b,f1,f2) as f ->
+          if !Global.print_ast_db
+          then
+            ps ("##"^(string_of_int (frm_hash 0 f))^"[")
+          else ()
+          ;
+          pp_formula' f1 ; ps " " ;
+          pp_binop b ; ps " " ; pp_formula' f2 ;
+          if !Global.print_ast_db then ps "]" else ()
+      | F_const c -> ps (string_of_const c)
+      | F_coord c -> pp_coord c
+      | F_paren f -> ps "(" ; pp_formula' f ; ps ")"
+
+    and pp_formula' f =
+      if !Global.print_ast_db then
+        ps ("#"^(string_of_int ( A.id f ) )^"[")
+      else
+        ()
+      ;
+      pp_formula ( A.force f ) ;
+      if !Global.print_ast_db then ps "]" else ()
+
+    and pp_binop = function
+      | Bop_add -> ps "+"
+      | Bop_sub -> ps "-"
+      | Bop_div -> ps "/"
+      | Bop_mul -> ps "*"
+
+    and pp_func = function
+      | Fn_sum -> ps "SUM"
+      | Fn_max -> ps "MAX"
+      | Fn_min -> ps "MIN"
+  end
+end

Applications/As2/As2/Global.ml

+
+type stats_test_param = int * [`Switch|`No_switch]
+type func =
+  | F_repl
+  | F_stats_test of stats_test_param
+
+let num_sheets     = ref 20
+let func           = ref F_repl
+let verbose_errors = ref false
+let print_passes   = ref true
+let print_ast_db   = ref false
+let stats_out      = ref "as2-stats.out"
+let stateless_eval = ref true
+let num_changes    = ref 10
+
+
+let rec args = [
+  ("--stateless-eval",  Arg.Set stateless_eval, " use stateless evaluation semantics" ) ;
+  ("--stateful-eval",   Arg.Clear stateless_eval, " use stateful evaluation semantics" ) ;
+
+  ("--repl",              Arg.Unit begin fun _ -> func := F_repl end, " functionality/mode: read-eval-print-loop (REPL)") ;
+
+  ("--stats-test",        Arg.Int begin fun n -> num_sheets := n; func := F_stats_test (n, `No_switch) end, " functionality/mode: run a predefined script, of a given size and record statisitics") ;
+  ("--stats-test-switch", Arg.Int begin fun n -> num_sheets := n; func := F_stats_test (n, `Switch) end,    " functionality/mode: run a predefined script (that switches), of a given size and record statisitics") ;
+  ("--num-sheets",        Arg.Int begin fun i -> num_sheets := i end, " set the total number of sheets (default: 20)" );
+  ("--num-changes",       Arg.Int begin fun i -> num_changes := i end, " set the number changes in the test script") ;
+  ("--stats-out",         Arg.String begin fun s -> stats_out := s end, " write out stats to the given file" ) ;
+
+  ("--Random.self_init", Arg.Unit begin fun _ -> Random.self_init () end, " initialize the Random module's number generator" ) ;  
+  ("--verbose",          Arg.Set verbose_errors, " give verbose (contextual) errors") ;
+  ("--ast-db",           Arg.Set print_ast_db, " give verbose debugging information in formulae") ;
+]
+
+let cur_filename = ref ""
+
+let lexbuf : Lexing.lexbuf ref = ref (Lexing.from_string "")
+
+let set_lexbuf lb = lexbuf := lb
+let get_lex_pos _ = (!lexbuf).Lexing.lex_curr_p
+
+module Prov = struct
+  type loc = Lexing.position
+  type loc_range = loc * loc
+
+  and prov =
+    | Synth
+    | Root of loc_range
+    | Stepped of prov
+
+  let rec sprint_prov prefix = function
+    | Synth -> prefix^"synth"
+    | Stepped p -> sprint_prov prefix p
+    | Root (loc1, loc2) ->
+        Printf.sprintf "%sFile \"%s\", line %d, characters %d-%d"
+          prefix
+          loc1.Lexing.pos_fname
+          loc1.Lexing.pos_lnum
+          (loc1.Lexing.pos_cnum - loc1.Lexing.pos_bol)
+          (loc2.Lexing.pos_cnum - loc2.Lexing.pos_bol)
+
+          (*
+    | Subst (n, p1, p2) ->
+        Printf.sprintf "%sSubstitution of `%s' at\n%s%sfor original `%s' at\n%s"
+          prefix n (sprint_prov (prefix^"  ") p2)
+          prefix n (sprint_prov (prefix^"  ") p1) *)
+end

Applications/As2/As2/Interp.ml

+(* Goals:
+
+   basic goals:
+   -- movement
+   -- writing (creating new formula; eventually, type-checking them too)
+   -- reading (evaluating formula)
+   -- visual display (ascii text to terminal)
+
+   intermediate goals:
+   -- integration with Adapton
+   -- load/save to disk
+   -- replay test scripts
+
+   longer-term goals:
+   -- type checker
+   -- explore circular references:
+      -- loan amortization demo
+      -- game of life demo
+
+   Questions:
+   -- sorting (?) -- how does that fit into this demo?
+   -- lazy lists -- are these needed / relevant here?
+*)
+
+module type INTERP = functor (Ast : Ast.S) -> sig
+  type cell
+  type db
+  type cur
+
+  val empty : int * int * int -> db
+  val eval_ : db -> Ast.sht -> Ast.formula -> Ast.const Ast.A.thunk
+  val eval  : cur -> Ast.formula -> Ast.const Ast.A.thunk
+
+  type 'a fold_body = ( cur -> 'a -> 'a )
+
+  type 'a foldees = { fold_cell      : 'a fold_body ;
+                      fold_row_begin : 'a fold_body ;
+                      fold_row_end   : 'a fold_body ; }
+
+  val fold_region  : Ast.absolute_region -> db -> 'a foldees -> 'a -> 'a
+  val print_region : Ast.absolute_region -> db -> out_channel -> unit
+
+  (* Cursor-based interaction: *)
+  val cursor  : Ast.pos -> db -> cur
+  val move    : Ast.nav_cmd -> cur -> cur
+  val get_pos : cur -> Ast.pos
+  val get_frm : cur -> Ast.formula
+  val get_val : cur -> Ast.const
+(*
+  val load  : string -> db
+  val save  : db -> string -> unit
+*)
+
+  val get_db : cur -> db
+
+  val read   : cur -> Ast.const
+  val write  : Ast.mut_cmd -> cur -> cur
+
+  val scramble       : cur -> unit
+  val scramble_dense : cur -> unit
+  val scramble_one   : cur -> unit
+end
+
+module Make : INTERP = functor (Ast : Ast.S) -> struct
+  open Ast
+
+  exception NYI
+
+  module Coord = struct
+    type t = pos
+    let compare c1 c2 = compare c1 c2
+    let equals c1 c2 = (c1 = c2)
+  end
+
+  module Mp = Map.Make(Coord)
+
+  type cell = { cell_frm : formula A.thunk ;
+                cell_val : const   A.thunk ; 
+                (* Invariant: if ! Global.stateless_semantics then cell_val is Undef *)
+              }
+
+  (* these mutable field below for cells need not be instrumented by
+     adapton bc the changes will only be monotonic (will only add new
+     stuff, will not alter the associations/identity of old stuff). *)
+  type db = { nshts  : int ;
+              ncols  : int ;
+              nrows  : int ;
+              mutable cells : cell Mp.t ;
+              mutable eval : sht -> formula -> const A.thunk ;
+            }
+
+  type cur = { db : db ;
+               pos : pos ; }
+
+  let get_db cur = cur.db
+
+(*
+  let load filename =
+    raise NYI
+
+  let save db filename =
+    raise NYI
+*)
+
+  let cursor pos db = { pos = pos ; db = db }
+
+  let get_pos cur = cur.pos
+
+  let get_frm cur =
+    try A.force (Mp.find cur.pos cur.db.cells).cell_frm with
+      | Not_found -> F_const Undef
+          
+  let sht_of_reg (s,_) = s
+  let sht_of_pos (s,_) = s
+
+  let get_val_ eval cur =
+    try 
+      let cell = Mp.find cur.pos cur.db.cells in
+      if ! Global.stateless_eval then
+        eval (sht_of_pos (get_pos cur)) (A.force cell.cell_frm)
+      else
+        cell.cell_val
+    with
+      | Not_found -> A.const Undef
+
+  let get_val cur = A.force (get_val_ cur.db.eval cur)
+
+  let pos_is_valid : pos -> db -> bool =
+    fun (s,(c,r)) {nshts;ncols;nrows} ->
+      ( s > 0 && c > 0 && r > 0 &&
+          s <= nshts && c <= ncols && r <= nrows )
+
+  (* move with no bounds checks. *)
+  let move_raw navcmd = fun cur ->
+    { cur with pos =
+        let pos = cur.pos in
+        match navcmd with
+          | C_goto (Abs pos) -> pos
+          | C_goto (Lcl lc)  -> (fst pos, lc)
+          | C_prev (Nav_sht) -> (fst pos - 1, snd pos)
+          | C_next (Nav_sht) -> (fst pos + 1, snd pos)
+          | C_next (Nav_col) -> (fst pos, (fst (snd pos) + 1, (snd (snd pos))))
+          | C_prev (Nav_col) -> (fst pos, (fst (snd pos) - 1, (snd (snd pos))))
+          | C_prev (Nav_row) -> (fst pos, (fst (snd pos), (snd (snd pos)) - 1))
+          | C_next (Nav_row) -> (fst pos, (fst (snd pos), (snd (snd pos)) + 1))
+    }
+
+  let move navcmd : cur -> cur = fun cur ->
+    let cur' = move_raw navcmd cur in
+    { cur with pos =
+        if pos_is_valid cur'.pos cur.db
+        then cur'.pos else cur.pos }
+
+  type 'a fold_body = ( cur -> 'a -> 'a )
+  type 'a foldees = { fold_cell      : 'a fold_body ;
+                      fold_row_begin : 'a fold_body ;
+                      fold_row_end   : 'a fold_body ; }
+
+  (* Folding a region: move in row-major order through the region.
+     uses the foldee callbacks to fold a parametric accumulator
+     through the region's structure. *)
+  let fold_region : Ast.absolute_region -> db -> 'a foldees -> 'a -> 'a =
+
+    fun (sht, (lc1, (max_col, max_row))) db foldees x ->
+      let cur =
+        cursor (sht, lc1) db
+      in
+      let within_region {pos=(s,(c,r))} =
+        ((c <= max_col) && (r <= max_row))
+      in
+      let rec loop_rows : cur -> 'a -> 'a = fun cur x ->
+        (* fold cols on current row *)
+        let rec loop_cols : cur -> 'a -> (cur * 'a) = fun cur x ->
+          if within_region cur then
+            let x   = foldees.fold_cell cur x in
+            let cur = move_raw (Ast.C_next Ast.Nav_col) cur in
+            loop_cols cur x
+          else
+            cur, x
+        in
+        (* fold all remaining rows: *)
+        if not (within_region cur) then x
+        else
+          let   x = foldees.fold_row_begin cur x in
+          let _,x = loop_cols cur x in
+          let   x = foldees.fold_row_end cur x in
+          let cur = move_raw (Ast.C_next Ast.Nav_row) cur in
+          loop_rows cur x
+      in
+      loop_rows cur x
+  
+  (* lookup and evaluate an absolute coordinate. *)
+  let lookup_cell : db -> pos -> cell = 
+    fun db pos ->
+      try (Mp.find pos db.cells) with
+        | Not_found -> begin
+            let undef_frm = A.const (F_const Undef) in
+            let undef_cell = { cell_frm = undef_frm ; 
+                               cell_val = A.const Undef } in
+            (* Monotonic side effect: 
+               create and remember a new formula, initially holding Undef. *)
+            db.cells <- Mp.add pos undef_cell db.cells ;
+            undef_cell
+          end
+
+  (* -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- *)
+  (* -- formula evaluation -- *)
+  (* ADAPTON memoizes this function, based on the sheet and formula arguments. *)
+  let eval_ db = 
+    let eval_memoized = A.memo2
+      ~inp2_equal:Ast.frm_equal
+      ~inp2_hash:Ast.frm_hash
+      begin fun eval_memo sht (frm : formula) ->
+      
+        let to_app_form : 'a list -> ('a list -> 'a list)
+          = fun xs -> (fun xs_tail -> xs @ xs_tail)
+        in
+        
+        let snoc : ('a list -> 'a list) -> 'a -> ('a list -> 'a list)
+          = fun xs y -> (fun tl -> xs (y :: tl))
+        in        
+
+        let eval_memo_ sht frm = 
+          eval_memo sht (A.force frm)
+        in
+
+        (* evaluate given formula *)
+        match frm with
+          | F_const c -> c
+          | F_paren f -> A.force (eval_memo_ sht f)
+          | F_coord coord -> A.force (get_val_ eval_memo {pos=(absolute sht coord); db=db})
+          | F_func(f,r) ->
+              let r = match r with
+                | R_lcl lr -> (sht,lr)
+                | R_abs reg -> reg
+              in
+              let cells = fold_region r db {
+                fold_row_begin = begin fun cur x -> x end ;
+                fold_row_end   = begin fun cur x -> x end ;
+                fold_cell      = begin fun cur cells -> 
+                  snoc cells (get_val_ eval_memo cur) end
+              } (to_app_form [])
+              in
+              begin match cells [] with
+                | []    -> Undef
+                | x::xs ->
+                    let x = A.force x in
+                    List.fold_right begin fun x y -> 
+                      let x = A.force x in
+                      match f, x, y with
+                        | Fn_sum,  Num x, Num y -> Num ( Num.add_num x y )
+                        | Fn_max,  Num x, Num y -> Num ( if Num.gt_num x y then x else y )
+                        | Fn_min,  Num x, Num y -> Num ( if Num.gt_num x y then y else x )
+                        | _,       Fail,  _     -> Fail
+                        | _,       _   ,  Fail  -> Fail 
+                        | _,       Undef, _     -> Undef
+                        | _,       _,     Undef -> Undef
+                    end xs x
+              end
+                
+          | F_binop(bop,f1,f2) -> begin
+              let c1 = A.force (eval_memo_ sht f1) in
+              let c2 = A.force (eval_memo_ sht f2) in
+              try
+                begin match bop, c1, c2 with
+                  | Bop_add, Num n1, Num n2 -> Num (Num.add_num n1 n2)
+                  | Bop_sub, Num n1, Num n2 -> Num (Num.sub_num n1 n2)
+                  | Bop_div, Num n1, Num n2 -> Num (Num.div_num n1 n2)
+                  | Bop_mul, Num n1, Num n2 -> Num (Num.mult_num n1 n2)
+                  | _,       Fail,   _      -> Fail
+                  | _,       _,      Fail   -> Fail 
+                  | _,       Undef,  _      -> Undef
+                  | _,       _,      Undef  -> Undef
+                end
+              with
+                | Failure _ -> Fail
+            end
+      end
+    in
+    eval_memoized
+
+  exception Not_yet_back_patched
+
+  let empty (nshts,ncols,nrows) =
+    let db = 
+      { nshts = nshts ;
+        ncols = ncols ;
+        nrows = nrows ;
+        cells = Mp.empty ;
+        eval  = (fun _ _ -> raise Not_yet_back_patched) ;
+      }
+    in
+    db.eval <- eval_ db ;
+    db      
+
+  let eval cur = cur.db.eval (sht_of_pos (get_pos cur))
+
+  (* -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- *)
+  (* -- pretty printing -- *)    
+  let print_region : Ast.absolute_region -> db -> out_channel -> unit =
+    fun reg db out ->
+      let ps = print_string in
+      fold_region reg db {
+        fold_row_begin = begin fun cur x -> ()      end ;
+        fold_row_end   = begin fun _ _   -> ps "\n" end ;
+        fold_cell =
+          begin fun cur _ ->
+            let c = get_val cur in
+            ps "| " ;
+            Printf.fprintf out "%10s" (Pretty.string_of_const c) ;
+            ps " |"
+          end } ()
+
+  let read cur = get_val cur
+    
+  let update_cell_frm cur cell frm =
+    if A.is_self_adjusting then (
+      A.update_const cell.cell_frm frm ;
+      A.update_thunk cell.cell_val begin fun _ ->
+        if (! Global.stateless_eval ) then
+          Undef
+        else
+          A.force (cur.db.eval (sht_of_pos cur.pos) frm)
+      end
+    )
+    else
+      cur.db.cells <-
+        Mp.add cur.pos { 
+          cell_frm=(A.const frm);
+          cell_val=
+            if ! Global.stateless_eval 
+            then (A.const Undef) 
+            else cur.db.eval (sht_of_pos cur.pos) frm ;
+        } cur.db.cells
+      
+  let random_const () = 
+    (Ast.F_const (Ast.Num (Num.num_of_int (Random.int 10000))))
+      
+  let scramble_cell cur cell =
+    update_cell_frm cur cell (random_const ())
+
+   let scramble_one cur =
+    let db = cur.db in
+    let rnd max = (Random.int (max - 1)) + 1 in
+    let s = sht_of_pos (get_pos cur) in
+    let pos = 
+      let s = rnd s in
+      let c = rnd db.ncols in
+      let r = rnd db.nrows in
+      (s, (c,r))
+    in
+    let cell = lookup_cell db pos in
+    scramble_cell cur cell
+
+  let scramble cur =
+    let db = cur.db in
+    for s = 1 to db.nshts do
+      for r = 1 to db.ncols do
+        for c = 1 to db.nrows do
+          let cell = lookup_cell db (s,(c,r)) in
+          if s <= 1 || r <= 1 || c <= 1 then
+            scramble_cell {cur with pos=(s,(r,c))} cell
+          else
+            let rnd max = (Random.int (max - 1)) + 1 in
+            let s1, s2 = rnd s, rnd s in
+            let c1, c2 = rnd db.ncols, rnd db.ncols in
+            let r1, r2 = rnd db.nrows, rnd db.nrows in
+            let b = match Random.int 4 with
+              | 0 -> Ast.Bop_add
+              | 1 -> Ast.Bop_sub 
+              | 2 -> Ast.Bop_div
+              | 3 -> Ast.Bop_mul
+              | _ -> invalid_arg "oops"
+            in
+            let f1 = Ast.F_coord (Abs (s1, (c1, r1))) in
+            let f2 = Ast.F_coord (Abs (s2, (c2, r2))) in
+            let f3 = Ast.F_binop (b, (memo_frm f1), (memo_frm f2)) in
+            update_cell_frm {cur with pos=(s,(r,c))} cell f3
+        done
+      done
+    done
+
+  let scramble_dense cur =
+    let db = cur.db in
+    for s = 1 to db.nshts do
+      for r = 1 to db.ncols do
+        for c = 1 to db.nrows do
+          let cell = lookup_cell db (s,(c,r)) in
+          if s <= 1 || r <= 1 || c <= 1 then
+            scramble_cell {cur with pos=(s,(r,c))} cell
+          else
+            let rnd max = (Random.int (max - 1)) + 1 in
+            let c1, c2 = rnd db.ncols, rnd db.ncols in
+            let r1, r2 = rnd db.nrows, rnd db.nrows in
+            let b = match Random.int 4 with
+              | 0 -> Ast.Bop_add
+              | 1 -> Ast.Bop_sub 
+              | 2 -> Ast.Bop_div
+              | 3 -> Ast.Bop_mul
+              | _ -> invalid_arg "oops"
+            in
+            (* dense ==> use the previous sheet. *)
+            let f1 = Ast.F_coord (Abs (s - 1, (c1, r1))) in
+            let f2 = Ast.F_coord (Abs (s - 1, (c2, r2))) in
+            let f3 = Ast.F_binop (b, (memo_frm f1), (memo_frm f2)) in
+            update_cell_frm {cur with pos=(s,(r,c))} cell f3
+        done
+      done
+    done
+
+  let write mutcmd cur =
+    begin match mutcmd with
+      | C_set frm -> begin
+          let cell = lookup_cell cur.db cur.pos in
+          update_cell_frm cur cell (A.force frm)
+        end
+      | Ast.C_scramble Ast.Sf_sparse -> scramble cur 
+      | Ast.C_scramble Ast.Sf_dense  -> scramble_dense cur
+      | Ast.C_scramble Ast.Sf_one    -> scramble_one   cur
+    end
+    ; cur
+
+end

Applications/As2/As2/Lexer.mll

+{
+  open Lexing
+
+  let incr_linenum lexbuf =
+    let pos = lexbuf.Lexing.lex_curr_p in
+    lexbuf.Lexing.lex_curr_p <-
+      { pos with
+          Lexing.pos_lnum = pos.Lexing.pos_lnum + 1;
+          Lexing.pos_bol = pos.Lexing.pos_cnum;
+      }
+
+  module Make (Ast : Ast.S) (Parser : module type of Parser.Make (Ast)) = struct
+    open Parser
+}
+
+let letter = ['a'-'z' 'A'-'Z']
+let letters = letter*
+let nat = ['0'-'9']+
+
+let hash = ['#']
+let nothash = [^ '#' '\n']
+let noteol = [^'\n']
+
+(* !! Important:
+   when we match this, we must increment the line number
+   of the lexbuf record. *)
+let eol = ['\n']
+
+let strlit = '"' ( [^'"'] | "\\\"" )* '"'
+
+let charlit = '\'' [^'\'']* '\''
+
+rule token = parse
+  | [' ' '\t'] { token lexbuf }
+  | eol        { incr_linenum lexbuf ; token lexbuf }
+  | '/' '*'    { nested_comment 0 lexbuf }
+
+  (* punctiation, separators *)
+  | ':' { COLON }
+  | ";" { SEMI }
+  | "|" { PIPE }
+  | "!" { BANG }
+  | '.' { DOT }
+  | ','  { COMMA }
+  | '=' { EQUALS }
+
+  (* grouping, nesting *)
+  | '(' { LPAREN }
+  | ')' { RPAREN }
+  | '{' { LBRACE }
+  | '}' { RBRACE }
+  | '[' { LBRACKET }
+  | ']' { RBRACKET }
+
+  (* arith *)
+  | "+" { ADD }
+  | "-" { SUB }
+  | "/" { DIV }
+  | "*" { MUL }
+
+  (* primitive functions *)
+  | ("SUM"|"sum") { SUM }
+  | ("MAX"|"max") { MAX }
+  | ("MIN"|"min") { MIN }
+
+  (* Keywords *)
+  | ("do"|"DO") { DO }
+  | ("done"|"DONE") { DONE }
+  | ("repeat"|"REPEAT") { REPEAT }
+  | ("NEXT"|"next") { NEXT }
+  | ("PREV"|"prev") { PREV }
+  | ("GOTO"|"goto") { GOTO }
+  | ("ROW"|"row") { ROW }
+  | ("COL"|"col") { COL }
+  | ("SHEET"|"sheet") { SHEET }
+  | ("SCRAMBLE"|"scramble") { SCRAMBLE }
+  | ("SCRAMBLED"|"scrambled") { SCRAMBLE_D }
+  | ("SCRAMBLE1"|"scramble1") { SCRAMBLE_1 }
+  | ("PRINT"|"print") { PRINT }
+
+  (* meta-level commands *)
+  | ("EXIT"|"exit"|"QUIT"|"quit") { EXIT }
+  | ("HELP"|"help"|"?") { HELP }
+
+  | ['a'-'z' 'A'-'Z'] as a { LETTER ((Char.code (Char.uppercase a)) - (Char.code 'A') + 1)}
+  | nat as n { NAT (int_of_string n) }
+
+  (* Line comments *)
+  | '-' '-' noteol+ eol { incr_linenum lexbuf ; token lexbuf }
+  | '/' '/' noteol+ eol { incr_linenum lexbuf ; token lexbuf }
+
+  (* lastly: *)
+  | eof { EXIT }
+  | _ as c  { OTHER_CHAR c }
+
+
+and nested_comment level = parse
+  | '/' '*' { nested_comment (level + 1) lexbuf }
+  | '*' '/' { if level = 0 then
+                token lexbuf
+              else
+                nested_comment (level-1) lexbuf }
+  | eol { incr_linenum lexbuf ; nested_comment level lexbuf }
+  | _   { nested_comment level lexbuf }
+
+{
+  end
+}

Applications/As2/As2/Main.ml

+module Make (SA : Adapton.Signatures.SAType) = struct
+  module Ast = Ast.Make (SA)
+  module Parser = Parser.Make (Ast)
+  module Interp = Interp.Make (Ast)
+  module Lexer = Lexer.Make (Ast) (Parser)
+
+  exception Error of exn * (int * int * string)
+  exception Internal_error
+
+  let ps = print_string
+
+  let help () =
+    ps "=========================================================================\n" ;
+    ps "AS2 HELP:                                                                \n" ;
+    ps "-------------------------------------------------------------------------\n" ;
+    ps "Commands:                                                                \n" ;
+    ps " 'help'            -- this help                                          \n" ;
+    ps " 'exit'            -- use excel instead                                  \n" ;
+    ps "                                                                         \n" ;
+    ps " = frm .           -- set formula of current cell to frm                 \n" ;
+    ps "                      Note: start with equals; terminate with a dot.     \n" ;
+    ps "                                                                         \n" ;
+    ps " 'goto' coord      -- goto a specific (sheet), row and column            \n" ;
+    ps " 'next' nav-thing  -- next col/row/sheet                                 \n" ;
+    ps " 'prev' nav-thing  -- prev col/row/sheet                                 \n" ;
+    ps "                                                                         \n" ;
+    ps "-------------------------------------------------------------------------\n" ;
+    ps "Formula & Coordinate Syntax                                              \n" ;
+    ps "                                                                         \n" ;
+    ps " Nav. thing   nav-thing ::= 'row' | 'col' | 'sheet'                      \n" ;
+    ps "                                                                         \n" ;
+    ps " Formulae     frm       ::= func ( reg )                                 \n" ;
+    ps "                         | frm binop frm | num | coord | ( frm )         \n" ;
+    ps "                                                                         \n" ;
+    ps " Functions    func      ::= 'sum' | 'max' | 'min'                        \n" ;
+    ps " Binops       binop     ::= + | - | / | *                                \n" ;
+    ps " Regions      reg       ::= lr | 'sheet' num ! lr                        \n" ;
+    ps " Coordinates  coord     ::= lc | 'sheet' num ! lc                        \n" ;
+    ps " Local coord  lc        ::= letters num                                  \n" ;
+    ps " Local region lr        ::= lc : lc                                      \n" ;
+    ps "-------------------------------------------------------------------------\n" ;
+    ps " All keywords, above in quotes, are also valid in all caps               \n" ;
+    ps "-------------------------------------------------------------------------\n" ;
+    ()
+
+  let parse_channel : string -> in_channel -> Ast.cmd =
+    fun filename channel ->
+      let lexbuf = Lexing.from_channel channel in
+      let pos = lexbuf.Lexing.lex_curr_p in
+      let _ =
+        lexbuf.Lexing.lex_curr_p <-
+          { pos with
+              Lexing.pos_fname = filename ;
+              Lexing.pos_lnum = 1 ;
+          }
+      in
+      let _ = Global.set_lexbuf lexbuf in
+      let ast : Ast.cmd =
+        try Parser.cmd Lexer.token lexbuf
+        with
+          | exn -> begin
+              let curr = lexbuf.Lexing.lex_curr_p in
+              let line = curr.Lexing.pos_lnum in
+              let cnum = curr.Lexing.pos_cnum - curr.Lexing.pos_bol in
+              let tok = Lexing.lexeme lexbuf in
+              raise (Error (exn, (line, cnum, tok)))
+            end
+      in
+      ast
+
+  let parse_string : string -> Ast.cmd =
+    fun input ->
+      let lexbuf = Lexing.from_string input in
+      let pos = lexbuf.Lexing.lex_curr_p in
+      let _ =
+        lexbuf.Lexing.lex_curr_p <-
+          { pos with
+              Lexing.pos_fname = "<string>" ;
+              Lexing.pos_lnum = 1 ;
+          }
+      in
+      let _ = Global.set_lexbuf lexbuf in
+      let ast : Ast.cmd =
+        try Parser.cmd Lexer.token lexbuf
+        with
+          | exn -> begin
+              let curr = lexbuf.Lexing.lex_curr_p in
+              let line = curr.Lexing.pos_lnum in
+              let cnum = curr.Lexing.pos_cnum - curr.Lexing.pos_bol in
+              let tok = Lexing.lexeme lexbuf in
+              raise (Error (exn, (line, cnum, tok)))
+            end
+      in
+      ast
+
+  let measure f =
+    let module S = Adapton.Statistics in
+    let x, m = S.measure f
+    in
+    begin Printf.printf "time=%f, heap=%d, stack=%d, upd=%d, eval=%d, dirty=%d, clean=%d\n"
+        m.S.time' m.S.heap' m.S.stack'
+        m.S.update' m.S.evaluate' m.S.dirty' m.S.clean'
+      ;
+      ( x , m )
+    end
+
+  let rec eval_cmd' cmd' cur =
+    match cmd' with
+      | None -> ps "Oops! Try 'help' for reference information.\n" ; cur
+      | Some cmd -> eval_cmd cmd cur
+
+  and eval_cmd cmd cur = begin match cmd with
+    | Ast.C_print ->
+        (* Important: refresh signals to TotalOrder implementation that
+           we want to start re-evaluation now; return to "at the
+           beginning of time".  This is a no-op otherwise. *)
+        if Ast.A.is_self_adjusting then
+          Ast.A.refresh ()
+        else () ;
+        let (sht,_) = Interp.get_pos cur in
+        ps "================================================\n" ;
+        Interp.print_region (sht,((1,1),(10,10))) (Interp.get_db cur) stdout ;
+        ps "================================================\n" ;
+        flush stdout ;
+        cur
+    | Ast.C_seq(c1,c2) ->
+        let cur = eval_cmd c1 cur in
+        eval_cmd c2 cur
+    | Ast.C_repeat(f,c) -> begin
+        try
+          let cnt = Ast.A.force (Interp.eval cur (Ast.A.force f)) in
+          let n = match cnt with
+            | Ast.Num n -> Num.int_of_num n
+            | _ -> invalid_arg "repeat"
+          in
+          let rec loop i cur =
+            if i <= 0 then cur
+            else
+              loop (i - 1) ( eval_cmd c cur )
+          in
+          loop n cur
+        with
+          | _ -> ps "repeat: Oops!\n" ; cur
+      end
+    | Ast.C_help -> help () ; cur
+    | Ast.C_exit -> exit (1)
+    | (Ast.C_nav nc) as cmd ->
+        ps "read: navigation command: `" ; Ast.Pretty.pp_cmd cmd ; ps "'\n" ;
+        (Interp.move nc cur)
+
+    | (Ast.C_mut mc) as cmd ->
+        ps "read: mutation command: `" ; Ast.Pretty.pp_cmd cmd ; ps "'\n" ;
+        let cur = Interp.write mc cur in
+        (* ps ">> " ; ps (Ast.Pretty.string_of_const (Interp.get_val cur)) ; ps "\n" ; *)
+        cur
+  end
+
+  let repl_handler cmd' cur () =
+    ( eval_cmd' cmd' cur )
+
+  (* REPL = Read-Eval-Print Loop *)
+  let rec repl cur =
+    Printf.printf "= " ;
+    Ast.Pretty.pp_formula (Interp.get_frm cur) ;
+    Printf.printf "\n"
+    ;
+    Ast.Pretty.pp_pos (Interp.get_pos cur)
+    ;
+    Printf.printf "> %!" ;
+    let cmd' =
+      try
+        Some ( parse_channel "<stdin>" stdin )
+      with
+        | Error (_, (line, col, token)) ->
+            ( Printf.eprintf "line %d, character %d: syntax error at %s\n%!"
+                (* filename *) line col
+                ( if token = "\n"
+                  then "newline"
+                  else Printf.sprintf "`%s'" token ) ;
+              None
+            )
+    in
+    let cur, _ = measure (repl_handler cmd' cur) in
+    (repl cur) (* repl is a tail-recursive loop. *)
+
+  let test test_flags n cur =
+    let sht_to_demand = n in
+    let num_changes = ! Global.num_changes in
+    let module S = Adapton.Statistics in
+    let cmd =
+      match test_flags with
+        | `No_switch ->
+            parse_string
+            (Printf.sprintf "scrambled; goto %d!a1 ; print ; repeat %d do scramble1 ; print done ."
+               sht_to_demand
+               num_changes)
+
+        | `Switch ->
+            parse_string
+              (Printf.sprintf "scrambled; goto %d!a1 ; print ; repeat %d do scramble1 ; goto %d!a1 ; print ; goto %d!a1 ; print done ."
+                 sht_to_demand
+                 num_changes
+                 (sht_to_demand / 2)
+                 sht_to_demand
+              )
+    in
+    let _, m = measure (fun _ -> eval_cmd cmd cur) in
+    let out = open_out_gen [Open_append] 0 (!Global.stats_out) in
+    output_string out (Printf.sprintf "%d, %d, %f, %d, %d, %d, %d, %d, %d\n"
+                         sht_to_demand
+                         num_changes
+                         m.S.time' m.S.heap' m.S.stack'
+                         m.S.update' m.S.evaluate' m.S.dirty' m.S.clean') ;
+    flush out ;
+    close_out out ;
+    ()
+
+  let run () =
+    let db_init  = Interp.empty (!Global.num_sheets,10,10) in
+    let cur_init = Interp.cursor (1,(1,1)) db_init in
+    match ! Global.func with
+      | Global.F_repl -> repl cur_init
+      | Global.F_stats_test (n, test_flags) -> test test_flags n cur_init
+end
+
+module type S = sig
+  val run : unit -> unit
+end
+
+let as2_list = List.map begin fun ( name, sa ) ->
+    ( name, (module Make ((val sa : Adapton.Signatures.SAType)) : S) )
+end Adapton.All.sa_list
+
+let run () =
+  let as2 = ref (snd (List.hd as2_list)) in
+  let args = Global.args @ [
+    ( "--adapton-module", Arg.Symbol ( fst (List.split as2_list), fun s -> as2 := List.assoc s as2_list ),
+      " use specific Adapton module (default: " ^ (fst (List.hd as2_list)) ^ ")" )
+  ] in
+  let _ = Arg.parse args
+    (fun filename -> invalid_arg "No input files.." )
+    "usage: runas2 [options]"
+  in
+  let module As2 = (val (!as2)) in
+  As2.run ()
+
+
+(* Not in use: FILE processing *)
+
+(* let process_file : string -> Ast.cmd = fun filename -> *)
+(*   let _ = Global.cur_filename := filename in *)
+(*   let input = *)
+(*     if filename = "-" *)
+(*     then stdin *)
+(*     else open_in filename *)
+(*   in *)
+(*   let cmd = *)
+(*     try parse_channel filename input *)
+(*     with *)
+(*       | Error (_, (line, col, token)) -> *)
+(*           ( Printf.eprintf "File %s, line %d, character %d: syntax error at %s\n%!" *)
+(*               filename line col *)
+(*               ( if token = "\n" *)
+(*                 then "newline" *)
+(*                 else Printf.sprintf "`%s'" token ) ; *)
+(*             exit (-1) ) *)
+(*   in *)
+(*   Ast.Pretty.pp_cmd cmd ; *)
+(*   cmd *)
+
+(* let run () = *)
+(*   if false then *)
+(*     let input_files : string list ref = ref [] in *)
+(*     if !Global.print_passes then Printf.eprintf "parsing input files...\n%!" ; *)
+(*     let _ = Arg.parse Global.args *)
+(*       (fun filename -> input_files := filename :: !input_files) *)
+(*       "usage: m3pc [options] [input files]" *)
+(*     in *)
+(*     if !input_files = [] then ( *)
+(*       Printf.eprintf "no input files given!\n" ; *)
+(*       exit (-1); *)
+(*     ); *)
+(*     let _ = List.map process_file (List.rev (!input_files)) in *)
+(*     (\** TODO -- emit/do something! **\) *)
+(*     () *)
+(*     ; *)
+(*     if !Global.print_passes then *)
+(*       Printf.eprintf "done.\n%!" *)
+(*     else () *)

Applications/As2/As2/Parser.mly

+%parameter < Ast : Ast.S >
+
+%{
+
+open Printf
+open Lexing
+
+%}
+
+/* meta tokens */
+%token EOL EOF
+%token <char> OTHER_CHAR
+
+/* punctiation, separators */
+%token COLON SEMI PIPE BANG
+%token DOT COMMA EQUALS
+
+/* grouping, nesting */
+%token LPAREN   RPAREN
+%token LBRACE   RBRACE
+%token LBRACKET RBRACKET
+
+/* math */
+%token ADD SUB DIV MUL
+%token SUM MAX MIN
+
+/* keywords */
+%token NEXT PREV GOTO ROW COL SHEET
+%token EXIT HELP SCRAMBLE SCRAMBLE_D SCRAMBLE_1 PRINT
+%token REPEAT DO DONE
+
+%token <int> LETTER
+%token <int> NAT
+%token <Num.num> NUM /* use Ocaml standard library of arbitrary-precision numbers. */
+
+/* See ast.ml */
+
+%start cmd
+
+%type <Ast.cmd> cmd
+%type <Ast.formula'> frm
+
+%%
+
+cmd:
+| EXIT        { Ast.C_exit }
+| HELP        { Ast.C_help }
+| imp_cmd DOT { $1 }
+;
+
+imp_cmd:
+| imp_cmd_ SEMI imp_cmd { Ast.C_seq ( $1, $3 ) }
+| imp_cmd_ { $1 }
+;
+
+imp_cmd_:
+| REPEAT frm DO imp_cmd DONE { Ast.C_repeat ($2, $4) }
+| mut_cmd { Ast.C_mut $1 }
+| nav_cmd { Ast.C_nav $1 }
+| PRINT   { Ast.C_print }
+;
+
+mut_cmd:
+| EQUALS frm  { Ast.C_set $2 }
+| SCRAMBLE    { Ast.C_scramble (Ast.Sf_sparse) }
+| SCRAMBLE_D  { Ast.C_scramble (Ast.Sf_dense) }
+| SCRAMBLE_1  { Ast.C_scramble (Ast.Sf_one) }
+;
+
+nav_cmd:
+| NEXT nav_thing { Ast.C_next $2 }
+| PREV nav_thing { Ast.C_prev $2 }
+| GOTO coord     { Ast.C_goto $2 }
+;
+
+nav_thing:
+| ROW   { Ast.Nav_row }
+| COL   { Ast.Nav_col }
+| SHEET { Ast.Nav_sht }
+;
+
+num:
+| NAT { Num.Int $1 }
+| NUM { $1 }
+;
+
+local_coord:
+| LETTER NAT { ($1, $2) }
+;
+coord:
+| local_coord                 { Ast.Lcl $1 }
+| SHEET NAT BANG local_coord  { Ast.Abs ($2, $4) }
+|       NAT BANG local_coord  { Ast.Abs ($1, $3) }
+;
+
+local_region:
+| local_coord COLON local_coord { ($1, $3) }
+;
+region:
+| local_region                { Ast.R_lcl $1 }
+| SHEET NAT BANG local_region { Ast.R_abs ($2,$4) }
+;
+
+frm:
+| frm_term ADD frm { Ast.memo_frm (Ast.F_binop(Ast.Bop_add,$1,$3)) }
+| frm_term SUB frm { Ast.memo_frm (Ast.F_binop(Ast.Bop_sub,$1,$3)) }
+| frm_term         { $1 }
+;
+frm_term:
+| frm_factor DIV frm_term { Ast.memo_frm (Ast.F_binop(Ast.Bop_div,$1,$3)) }
+| frm_factor MUL frm_term { Ast.memo_frm (Ast.F_binop(Ast.Bop_mul,$1,$3)) }
+| frm_factor              { $1 }
+;
+frm_factor:
+| const                     { Ast.memo_frm (Ast.F_const $1) }
+| coord                     { Ast.memo_frm (Ast.F_coord $1) }
+| LPAREN frm RPAREN         { Ast.memo_frm  (Ast.F_paren $2) }
+| func LPAREN region RPAREN { Ast.memo_frm (Ast.F_func ($1, $3)) }
+;
+func:
+| SUM { Ast.Fn_sum }
+| MAX { Ast.Fn_max }
+| MIN { Ast.Fn_min }
+;
+const:
+| num { Ast.Num $1 }
+;

Applications/As2/As2/_tags

+<*.cm*>: for-pack(As2)

Applications/As2/runas2.ml

+let _ = As2.Main.run ()
 
-VPATH = Source Test
+VPATH = Source $(wildcard Applications/*) Test
 ifeq ($(shell uname),Darwin)
 	# bump stack size to 4GiB
 	OCAMLBUILD_DARWIN_FLAGS := -lflag -cclib -lflag -Wl,-stack_size,0x100000000

Source/Adaptime.mllib

-Adaptime

Source/Adaptime.mlpack

-Adaptime/Behavior
-Adaptime/Time

Source/Adaptime/_tags

-<*.cm*>: for-pack(Adaptime)

Source/Adaptime/behavior.ml

-
-open Adapton.Signatures
-open Time
-module T = Adapton.Types
-
-module type Behavior = sig
-	type 'a behavior
-
-	(* 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 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 ... *)
-	(* val flatten? *)
-	(* val prev : 'a behavior -> 'a -> 'a behavior *)
-	(* How do I implement this?
-	val fix : ('a behavior -> 'a behavior) -> 'a behavior
-	*)
-
-	(*
-	(* val appf? implement without flatten? *)
-
-	val filter : ('a -> bool) -> 'a behavior -> 'a behavior
-	when
-
-	TODO: 
-		memo_app
-		ifb -> switch? ifb (thunkified)
-
-	
-	more...?
-		? update_const/trigger ?
-
-
-
-
-	*)
-	val merge : 'a behavior -> 'a behavior -> 'a behavior
-	val ifb : bool behavior -> 'a behavior -> 'a behavior -> 'a behavior
-
-	(* Derived combinators. *)
-	val lift : ('a -> 'b) -> (module Hashtbl.SeededHashedType with type t = 'b ) -> 'a behavior -> 'b behavior
-	val lift2 : ('a -> 'b -> 'c) -> (module Hashtbl.SeededHashedType with type t = 'c ) -> 'a behavior -> 'b behavior-> 'c behavior
-	val lift3 : ('a -> 'b -> 'c -> 'd) -> (module Hashtbl.SeededHashedType with type t = 'd ) -> 'a behavior -> 'b behavior-> 'c behavior -> 'd behavior
-	val lift4 : ('a -> 'b -> 'c -> 'd -> 'e) -> (module Hashtbl.SeededHashedType with type t = 'e ) -> 'a behavior -> 'b behavior-> 'c behavior -> 'd behavior -> 'e behavior
-
-	val memo_lift : ('a -> 'b) -> (module Hashtbl.SeededHashedType with type t = 'b ) -> 'a behavior -> 'b behavior
-	val memo_lift2 : ('a -> 'b -> 'c) -> (module Hashtbl.SeededHashedType with type t = 'c ) -> 'a behavior -> 'b behavior-> 'c behavior
-	val memo_lift3 : ('a -> 'b -> 'c -> 'd) -> (module Hashtbl.SeededHashedType with type t = 'd ) -> 'a behavior -> 'b behavior-> 'c behavior -> 'd behavior
-	val memo_lift4 : ('a -> 'b -> 'c -> 'd -> 'e) -> (module Hashtbl.SeededHashedType with type t = 'e ) -> 'a behavior -> 'b behavior-> 'c behavior -> 'd behavior -> 'e behavior
-	
-	(* Alarm. *)
-	val seconds : unit -> time behavior
-	val time : unit -> time behavior
-
-	(* Extractors. *)
-	val force : 'a behavior -> 'a
-	val id : 'a behavior -> int
-end
-
-(* Make a behavior, given a SAType. *)
-module Make (M : SAType) : Behavior = struct
-	module Tm = TimeType(M)
-	module S = Sys
-	module U = Unix
-
-	type 'a sa_mod = (module SAType.S with type sa = M.sa and type data = 'a and type t = 'a M.thunk)
-	type 'a behavior = 'a sa_mod * 'a M.thunk * time M.thunk
-	(* Requirement: Always force 'a thunk before time thunk. *)
-
-	let const (type t) (module H : Hashtbl.SeededHashedType with type t = t) (c : t) : t behavior = 
-		let module R = M.Make( H) in
-		let r = R.const c in
-		let t = Tm.const (get_time ()) in
-		(module R), r, t
-
-	(*
-	(* Universal type hackery. 
-	https://ocaml.janestreet.com/?q=node/18
-	*)
-	module Univ : sig
-		type t
-		val embed: unit -> ('a -> t) * (t -> 'a option)
-	end = struct 
-		type t = exn
-
-		let embed (type s) () =
-			let module M = struct exception E of s end in
-			(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 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
-			| [] ->
-				let m = R.memo (module R.Data) (fun _ c' -> c') in
-				let m' = ref (of_memo_t m) in
-				memo_const_store := m'::!memo_const_store;
-				Printf.printf "memo_const: making new..\n%!";
-				m
-			| h::t ->
-				let m = to_memo_t !h in
-				match m with
-				| None ->
-					Printf.printf "memo_const: not this one\n%!";
-					helper t
-				| Some m' ->
-					Printf.printf "memo_const: found!\n%!";
-					m'
-			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
-				Hashtbl.find memo_const_store mod_r
-			with
-			| Not_found -> 
-				let m = R.memo (module R.Data) (fun _ c' -> c') in
-				Hashtbl.add memo_const_store mod_r m
-		in
-		*)
-		(*let r = memo c in*)
-		let t = Tm.const (get_time ()) in
-		(*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 r = R.thunk (fun () -> (F.force f) (A.force a)) in
-		let t = Tm.thunk (fun () -> max_time [ Tm.force tf; Tm.force ta]) in
-		(module R), r, t
-	
-	let memo_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 memo = R.memo2 (module F.Data) (module A.Data) (fun _ f' a' -> f' a') in
-		let r = R.thunk (fun () -> R.force (memo (F.force f) (A.force a))) in
-		let t = Tm.thunk (fun () -> max_time [ Tm.force tf; Tm.force ta]) in
-		(module R), r, t
-
-		
-	(* Contains the previous value of the behavior. Takes on the default value until the behavior changes. *)
-	(* TODO: Not pure... How do we fix this?
-	let prev (type a) (((module A), a, ta) : a behavior) (default : a) : a behavior =
-		(* TODO: Combine stores? Otherwise, might lead to race conditions?
-		Need to keep track of times, to see if force causes store to update.
-		let store = ref (default, get_time ()) in
-		*)
-		let valStore = ref default in
-		let tmStore = ref (get_time ()) in (* default time should time prev was called? *)
-		let r = A.thunk (fun () ->
-			let r' = !valStore in
-			valStore := A.force a;
-			r'
-		)
-		in
-		let t = Tm.thunk (fun () ->
-			let t' = !tmStore in
-			tmStore := Tm.force ta;
-			t'
-		)
-		in
-		(module A), r, t
-	*)
-
-	let lift (type a) (type b) (f : a -> b) (module B : Hashtbl.SeededHashedType with type t = b) (a : a behavior) : b behavior =
-		let mF = T.makeFunction () in
-		let f' = const mF f in
-		app f' (module B) a
-
-	let lift2 (type a) (type b) (type c) (f : a -> b -> c) (module C : Hashtbl.SeededHashedType with type t = c) (a : a behavior) (b : b behavior) : c behavior =
-		let mF = T.makeFunction () in
-		let f' = lift f mF a in
-		app f' (module C) b
-	
-	let lift3 (type a) (type b) (type c) (type d) (f : a -> b -> c -> d) (module D : Hashtbl.SeededHashedType with type t = d) (a : a behavior) (b : b behavior) (c : c behavior) : d behavior =
-		let mF = T.makeFunction () in
-		let f' = lift2 f mF a b in
-		app f' (module D) c
-	
-	let lift4 (type a) (type b) (type c) (type d) (type e) (f : a -> b -> c -> d -> e) (module E : Hashtbl.SeededHashedType with type t = e) (a : a behavior) (b : b behavior) (c : c behavior) (d : d behavior) : e behavior =
-		let mF = T.makeFunction () in
-		let f' = lift3 f mF a b c in
-		app f' (module E) d
-
-	let memo_lift (type a) (type b) (f : a -> b) (module B : Hashtbl.SeededHashedType with type t = b) ((module A), a, ta : a behavior) : b behavior =
-		let module R = M.Make( B) in
-		let memo = R.memo (module A.Data) (fun _ -> f) in
-		let r = R.thunk (fun () -> R.force (memo (A.force a))) in
-		let t' = Tm.const (get_time ()) in
-		let t = Tm.thunk (fun () -> max_time [ Tm.force t'; Tm.force ta]) in
-		(module R), r, t
-		
-	(* Can't be compositional here because memoizing on closures does not work. *)
-	let memo_lift2 (type a) (type b) (type c) (f : a -> b -> c) (module C : Hashtbl.SeededHashedType with type t = c) ((module A), a, ta : a behavior) ((module B), b, tb : b behavior) : c behavior =
-		let module R = M.Make( C) in
-		let memo = R.memo2 (module A.Data) (module B.Data) (fun _ -> f) in
-		let r = R.thunk (fun () -> R.force (memo (A.force a) (B.force b))) in
-		let t' = Tm.const (get_time ()) in
-		let t = Tm.thunk (fun () -> max_time [ Tm.force t'; Tm.force ta; Tm.force tb]) in
-		(module R), r, t
-		(*
-		let mF = T.makeFunction () in
-		let f' = memo_lift f mF a in
-		memo_app f' (module C) b
-		*)
-
-	let memo_lift3 (type a) (type b) (type c) (type d) (f : a -> b -> c -> d) (module D : Hashtbl.SeededHashedType with type t = d) ((module A), a, ta : a behavior) ((module B), b, tb : b behavior) ((module C), c, tc : c behavior) : d behavior =
-		let module R = M.Make( D) in
-		let memo = R.memo3 (module A.Data) (module B.Data) (module C.Data) (fun _ -> f) in
-		let r = R.thunk (fun () -> R.force (memo (A.force a) (B.force b) (C.force c))) in
-		let t' = Tm.const (get_time ()) in
-		let t = Tm.thunk (fun () -> max_time [ Tm.force t'; Tm.force ta; Tm.force tb; Tm.force tc]) in