probabilistic-lambda-calculus-R-ocaml.ml

type value = Number of int
  | True
  | False
  | Closure of (((ad_number*((int*value) list)*value) list) ->
      ((ad_number*((int*value) list)*value) list))

type expression = Constant of value
  | Variable of int
  | Lambda of int*expression
  | Application of expression*expression

exception Undecidable

let make_ignore = 0

let make_if_procedure = 1

let make_x0 = 2

let make_x1 = 3

let rec binds a b =
  match a, b with
    [], _ -> false
  | ((variable1, _)::environment), variable2 ->
      if variable1=variable2 then true else binds environment variable2

let rec lookup_value variable1 ((variable2, value)::environment) =
  if variable1=variable2 then value else lookup_value variable1 environment

let same p1 p2 =
  match p1, p2 with
    (Number m), (Number n) -> m=n
  | True, True -> true
  | False, False -> true
  | (Closure _), (Closure _) -> raise Undecidable
  | _, _ -> false

let rec merge_environments p1 p2 =
  (match p1, p2 with
    [], environment2 -> Some environment2
  | ((variable1, value1)::environment1), environment2 ->
      match merge_environments environment1 environment2 with
	None -> None
      | Some environment ->
	  if binds environment variable1
	  then if same (lookup_value variable1 environment) value1
	  then Some environment
	  else None
	  else Some ((variable1, value1)::environment))

let singleton_tagged_distribution value = [((Base 1.0), [], value)]

let boolean_distribution p variable =
  [(((Base 1.0)-.p), [(variable, False)], False);
   (p, [(variable, True)], True)]

let normalize_tagged_distribution tagged_distribution =
  let n = let rec loop a =
    (match a with
      [] -> (Base 0.0)
    | ((p, _, _)::tagged_distribution) -> p+.(loop tagged_distribution))
  in loop tagged_distribution
  in map (fun (p, environment, value) -> ((p/.n), environment, value)) tagged_distribution

let rec remove_inconsistent_triples a =
  match a with
    [] -> []
  | ((_, None, _)::tagged_distribution) -> remove_inconsistent_triples tagged_distribution
  | ((p, (Some environment), value)::tagged_distribution) ->
      ((p, environment, value)::(remove_inconsistent_triples tagged_distribution))

let map_tagged_distribution f tagged_distribution =
  normalize_tagged_distribution
    (let rec loop a =
      match a with
	[] -> []
      | ((p, environment, value)::tagged_distribution) ->
	  (remove_inconsistent_triples
	     (map (fun (p1, environment1, value1) ->
	       ((p*.p1),
		(merge_environments environment environment1),
		value1))
		((f value))))@
	  (loop tagged_distribution)
    in loop tagged_distribution)

let rec evaluate a environment =
  match a with
    (Constant value) -> singleton_tagged_distribution value
  | (Variable variable) -> lookup_value variable environment
  | (Lambda (variable, body)) -> singleton_tagged_distribution
	(Closure (fun tagged_distribution ->
	  evaluate body
	    ((variable, tagged_distribution)::environment)))
  | (Application (callee, argument)) ->
      let tagged_distribution = evaluate argument environment
      in map_tagged_distribution
	(fun value ->
	  match value with
	    Closure f -> f tagged_distribution)
	(evaluate callee environment)

let rec likelihood p1 p2 =
  match p1, p2 with
    value, [] -> (Base 0.0)
  | value1, ((p, _, value2)::tagged_distribution) ->
      (if same value1 value2 then p else (Base 0.0))+.
	(likelihood value1 tagged_distribution)

let make_if antecedent consequent alternate =
  (Application
     ((Application
	 ((Application ((Variable make_if_procedure), antecedent)),
	  (Lambda (make_ignore, consequent)))),
      (Lambda (make_ignore, alternate))))

let example _ =
  (gradient_ascent_R
     (fun [p0; p1] ->
       let tagged_distribution =
	 evaluate
	   (make_if (Variable make_x0)
	      (Constant (Number 0))
	      (make_if (Variable make_x1)
		 (Constant (Number 1))
		 (Constant (Number 2))))
	   [(make_x0, (boolean_distribution p0 make_x0));
	    (make_x1, (boolean_distribution p1 make_x1));
	    (make_if_procedure,
	     (singleton_tagged_distribution
		(Closure
		   (fun x ->
		     (singleton_tagged_distribution
			(Closure
			   (fun y ->
			     (singleton_tagged_distribution
				(Closure
				   (fun z ->
				     (map_tagged_distribution
					(fun xe ->
					  (map_tagged_distribution
					     (fun ye ->
					       match ye with
						 Closure yf ->
						   (map_tagged_distribution
						      (fun ze ->
							match ze with
							  Closure zf ->
							    (match xe with
							      Number _ -> (yf (singleton_tagged_distribution False))
							    | True -> (yf (singleton_tagged_distribution False))
							    | False -> (zf (singleton_tagged_distribution False))
							    | Closure _ -> (yf (singleton_tagged_distribution False))))
						      z))
					     y))
					x)))))))))))]
       in fold_left ( *. )
	 (Base 1.0)
	 (map (fun observation -> likelihood observation tagged_distribution)
	    [(Number 0); (Number 1); (Number 2); (Number 2)]))
     [(Base 0.5); (Base 0.5)]
     (Base 1000.0)
     (Base 0.1))

let _ =
  (let rec loop i result =
    if i<=(Base 0.0) && (Base 0.0)<= i
    then result
    else let ([p0; p1], _, _) = example ()
    in loop (i-.(Base 1.0)) [(write_real p0); (write_real p1)]
  in loop (Base 1000.0) [(Base 0.0); (Base 0.0)]; 0)