Set Warnings "-extraction-opaque-accessed,-extraction".
Set Warnings "-notation-overridden,-parsing".
From ExtLib.Structures Require Export
Monads.
From ExtLib.Structures Require Import
Functor Applicative.
Open Scope monad_scope.
GenLowInterface RandomQC RoseTrees Sets Tactics.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.
Set Bullet Behavior "Strict Subproofs".
(* Low-level Generators *)
Open Scope fun_scope.
Open Scope set_scope.
Module GenLow : GenLowInterface.Sig.
(** * Type of generators *)
(* begin GenType *)
Inductive GenType (A:Type) : Type := MkGen : (nat -> RandomSeed -> A) -> GenType A.
(* end GenType *)
Definition G := GenType.
(** * Primitive generator combinators *)
(* begin run *)
Definition run {A : Type} (g : G A) := match g with MkGen f => f end.
(* end run *)
Definition returnGen {A : Type} (x : A) : G A :=
MkGen (fun _ _ => x).
Definition bindGen {A B : Type} (g : G A) (k : A -> G B) : G B :=
MkGen (fun n r =>
let (r1,r2) := randomSplit r in
run (k (run g n r1)) n r2).
Definition fmap {A B : Type} (f : A -> B) (g : G A) : G B :=
MkGen (fun n r => f (run g n r)).
Definition apGen {A B} (gf : G (A -> B)) (gg : G A) : G B :=
bindGen gf (fun f => fmap f gg).
Definition sized {A : Type} (f : nat -> G A) : G A :=
MkGen (fun n r => run (f n) n r).
Definition resize {A : Type} (n : nat) (g : G A) : G A :=
match g with
| MkGen m => MkGen (fun _ => m n)
end.
Definition promote {A : Type} (m : Rose (G A)) : G (Rose A) :=
MkGen (fun n r => fmapRose (fun g => run g n r) m).
Fixpoint rnds (s : RandomSeed) (n' : nat) : list RandomSeed :=
match n' with
| O => nil
| S n'' =>
let (s1, s2) := randomSplit s in
cons s1 (rnds s2 n'')
end.
Fixpoint createRange (n : nat) (acc : list nat) : list nat :=
match n with
| O => List.rev (cons O acc)
| S n' => createRange n' (cons n acc)
end.
Definition choose {A : Type} `{ChoosableFromInterval A} (range : A * A) : G A :=
MkGen (fun _ r => fst (randomR range r)).
Definition sample (A : Type) (g : G A) : list A :=
match g with
| MkGen m =>
let rnd := newRandomSeed in
let l := List.combine (rnds rnd 20) (createRange 10 nil) in
List.map (fun (p : RandomSeed * nat) => let (r,n) := p in m n r) l
end.
(* LL : Things that need to be in GenLow because of MkGen *)
Definition variant {A : Type} (p : SplitPath) (g : G A) : G A :=
match g with
| MkGen f => MkGen (fun n r => f n (varySeed p r))
end.
Definition reallyUnsafeDelay {A : Type} : G (G A -> A) :=
MkGen (fun r n g => (match g with MkGen f => f r n end)).
Definition reallyUnsafePromote {r A : Type} (m : r -> G A) : G (r -> A) :=
(bindGen reallyUnsafeDelay (fun eval =>
returnGen (fun r => eval (m r)))).
(* End Things *)
(** * Semantics of generators *)
(* Set of outcomes semantics definitions (repeated above) *)
(* begin semGen *)
Definition semGenSize {A : Type} (g : G A) (s : nat) : set A := codom (run g s).
Definition semGen {A : Type} (g : G A) : set A := \bigcup_s semGenSize g s.
Definition semGenSizeOpt {A : Type} (g : G (option A)) (s : nat) : set A :=
somes (semGenSize g s).
Definition semGenOpt {A : Type} (g : G (option A)) : set A :=
somes (semGen g).
(* end semGen *)

(* Specifications: *)
Lemma semGenOpt_equiv {A} (g : G (option A)) :
semGenOpt g <--> \bigcup_s semGenSizeOpt g s.
Lemma bindGen_aux {A : Type} (g : G A) (n : nat) (r : RandomSeed) : semGen g (run g n r).
Definition bindGen' {A B : Type} (g : G A) (k : forall (a : A), (a \in semGen g) -> G B) : G B :=
MkGen (fun n r =>
let (r1,r2) := randomSplit r in
run (k (run g n r1) (bindGen_aux g n r1)) n r2).