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 *)
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).
(** * Semantic properties of generators *)
Class Unsized {A} (g : G A) :=
unsized : forall s1 s2, semGenSize g s1 <--> semGenSize g s2.
Class SizedMonotonic {A} (g : nat -> G A) :=
(* TODO remove prime when GenSizedSizeMotonic is modified *)
sizeMonotonic : forall s s1 s2,
s1 <= s2 ->
semGenSize (g s1) s \subset semGenSize (g s2) s.
(** Sized generators of option type monotonic in the size parameter *)
Class SizedMonotonicOpt {A} (g : nat -> G (option A)) :=
sizeMonotonicOpt : forall s s1 s2,
s1 <= s2 ->
semGenSizeOpt (g s1) s \subset semGenSizeOpt (g s2) s.
(** Generators monotonic in the runtime size parameter *)
Class SizeMonotonic {A} (g : G A) :=
monotonic : forall s1 s2,
s1 <= s2 -> semGenSize g s1 \subset semGenSize g s2.
(** Generators monotonic in the runtime size parameter *)
Class SizeMonotonicOpt {A} (g : G (option A)) :=
monotonicOpt : forall s1 s2,
s1 <= s2 ->
semGenSizeOpt g s1 \subset semGenSizeOpt g s2.
Class SizeAntiMonotonicNone {A} (g : G (option A)) :=
monotonicNone : forall s1 s2,
s1 <= s2 ->
isNone :&: semGenSize g s2 \subset isNone :&: semGenSize g s1.
(** * Semantics of combinators *)
(* end semReturn *)
(* end semReturnSize *)
Instance unsizedReturn {A} (x : A) : Unsized (returnGen x).

Lemma monad_assoc A B C (ga : G A) (fb : A -> G B) (fc : B -> G C) :
semGen (bindGen (bindGen ga fb) fc) <-->
semGen (bindGen ga (fun a => bindGen (fb a) fc)).