Module Impl (GenLow : GenLowInterface.Sig) :
GenHighInterface.Sig GenLow.
Definition liftGen {A B} (f: A -> B) (a : G A)
: G B := nosimpl
(bindGen a (fun x =>
returnGen (f x))).
Definition liftGen2 {A1 A2 B}
(C : A1 -> A2 -> B) (m1 : G A1) (m2  : G A2)
: G B:=
nosimpl (bindGen m1 (fun x1 => bindGen m2 (fun x2 => returnGen (C x1 x2)))).
Definition liftGen3 {A1 A2 A3 R} (F : A1 -> A2 -> A3 -> R)
(m1 : G A1) (m2 : G A2) (m3 : G A3)
: G R := nosimpl(
bindGen m1 (fun x1 =>
bindGen m2 (fun x2 =>
bindGen m3 (fun x3 =>
returnGen (F x1 x2 x3))))).
Definition liftGen4 {A1 A2 A3 A4 R}
(F : A1 -> A2 -> A3 -> A4 -> R)
(m1 : G A1) (m2 : G A2) (m3 : G A3) (m4: G A4)
: G R := nosimpl(
bindGen m1 (fun x1 =>
bindGen m2 (fun x2 =>
bindGen m3 (fun x3 =>
bindGen m4 (fun x4 =>
returnGen (F x1 x2 x3 x4)))))).
Definition liftGen5 {A1 A2 A3 A4 A5 R}
(F : A1 -> A2 -> A3 -> A4 -> A5 -> R)
(m1 : G A1) (m2 : G A2) (m3 : G A3) (m4: G A4) (m5 : G A5)
: G R := nosimpl(
bindGen m1 (fun x1 =>
bindGen m2 (fun x2 =>
bindGen m3 (fun x3 =>
bindGen m4 (fun x4 =>
bindGen m5 (fun x5 =>
returnGen (F x1 x2 x3 x4 x5))))))).
Definition sequenceGen {A : Type} (ms : list (G A)) : G (list A) :=
foldr (fun m m' => bindGen m  (fun x =>
bindGen m' (fun xs =>
returnGen (x :: xs)))) (returnGen [::]) ms.
Fixpoint foldGen {A B : Type} (f : A -> B -> G A) (l : list B) (a : A)
: G A := nosimpl(
match l with
| [::] => returnGen a
| (x :: xs) => bindGen (f a x) (foldGen f xs)
end).
Definition oneOf_ {A : Type} (def: G A) (gs : list (G A)) : G A :=
bindGen (choose (0, length gs - 1)) (nth def gs).
Definition oneof {A} :=
@deprecate (G A -> list (G A) -> G A) "oneof" "oneOf_" oneOf_.
Fixpoint pick {A : Type} (def : G A) (xs : list (nat * G A)) n : nat * G A :=
match xs with
| nil => (0, def)
| (k, x) :: xs =>
if (n < k) then (k, x)
else pick def xs (n - k)
end.
(* This should use urns! *)
Fixpoint pickDrop {A : Type} (xs : list (nat * G (option A))) n : nat * G (option A) * list (nat * G (option A)) :=
match xs with
| nil => (0, returnGen None, nil)
| (k, x) :: xs =>
if (n < k) then  (k, x, xs)
else let '(k', x', xs') := pickDrop xs (n - k)
in (k', x', (k,x)::xs')
end.
Definition sum_fst {A : Type} (gs : list (nat * A)) : nat :=
foldl (fun t p => t + (fst p)) 0 gs.
Definition freq_ {A : Type} (def : G A) (gs : list (nat * G A))
: G A :=
let tot := sum_fst gs in
bindGen (choose (0, tot-1)) (fun n =>
@snd _ _ (pick def gs n)).
Definition frequency {A}:=
@deprecate (G A -> list (nat * G A) -> G A) "frequency" "freq_" freq_.
Fixpoint backtrackFuel {A : Type} (fuel : nat) (tot : nat) (gs : list (nat * G (option A))) : G (option A) :=
match fuel with
| O => returnGen None
| S fuel' => bindGen (choose (0, tot-1)) (fun n =>
let '(k, g, gs') := pickDrop gs n in
bindGen g (fun ma =>
match ma with
| Some a => returnGen (Some a)
| None => backtrackFuel fuel' (tot - k) gs'
end ))
end.
Definition backtrack {A : Type} (gs : list (nat * G (option A))) : G (option A) :=
backtrackFuel (length gs) (sum_fst gs) gs.
Definition vectorOf {A : Type} (k : nat) (g : G A)
: G (list A) :=
foldr (fun m m' =>
bindGen m (fun x =>
bindGen m' (fun xs => returnGen (cons x xs)))
) (returnGen nil) (nseq k g).
Definition listOf {A : Type} (g : G A) : G (list A) :=
sized (fun n => bindGen (choose (0, n)) (fun k => vectorOf k g)).
Definition elems_ {A : Type} (def : A) (l : list A) :=
let n := length l in
bindGen (choose (0, n - 1)) (fun n' =>
returnGen (List.nth n' l def)).
Definition elements {A} :=
@deprecate (A -> list A -> G A) "elements" "elems_" elems_.
Definition bindGenOpt {A B}
(g : G (option A)) (f : A -> G (option B)) : G (option B) :=
bindGen g (fun ma =>
match ma with
| None => returnGen None
| Some a => f a
end).
Definition retryBody {A : Type}
(retry : nat -> G (option A) -> G (option A))
(n : nat) (g : G (option A)) : G (option A) :=
bindGen g (fun x =>
match x, n with
| Some a, _ => returnGen (Some a)
| None, O => returnGen None
| None, S n' => retry n' g
end).
(* Rerun a generator [g] until it returns a [Some], or stop after [n+1] tries. *)
Fixpoint retry {A : Type} (n : nat) (g : G (option A)) :
G (option A) :=
retryBody retry n g.
(* Filter the output of a generator [g], returning [None] when the predicate [p] is [false]. The generator is run once. *)
Definition suchThatMaybe1 {A : Type} (g : G A) (p : A -> bool) :
G (option A) :=
fmap (fun x => if p x then Some x else None) g.
(* Retry a generator [g : G A] until it returns a value satisfying the predicate, or stop after [size+1] times, where [size] is the current size value. *)
Definition suchThatMaybe {A : Type} (g : G A) (p : A -> bool) :
G (option A) :=
sized (fun n => retry n (suchThatMaybe1 g p)).
(* Retry a generator [g : G (option A)] until it returns a value satisfying the predicate, or stop after [size+1] times, where [size] is the current size value. *)
Definition suchThatMaybeOpt {A : Type} (g : G (option A))
(p : A -> bool) : G (option A) :=
sized (fun n => retry n (fmap (fun x =>
match x with
| None => None
| Some a => if p a then Some a else None
end) g)).
(* Retry a generator until it returns a value, or stop after [size+1] times. *)
Definition retrySized {A : Type} (g : G (option A)) : G (option A) :=
sized (fun n => retry n g).
(* * Semantics *)
Ltac solveLiftGenX :=
intros; split; intros;
repeat
match goal with
| [ H : exists _, _ |- _ ] => destruct H as [? [? ?]]
| [ H : semGenSize _ _ _ |- _ ] =>
try (apply semBindSize in H; destruct H as [? [? ?]]);
try (apply semReturnSize in H; subst)
end;
[ by repeat (eexists; split; [eassumption |])
| repeat (apply semBindSize; eexists; split; try eassumption);
by apply semReturnSize ].
Program Instance liftGenUnsized {A B} (f : A -> B) (g : G A)
`{Unsized _ g} : Unsized (liftGen f g).
Next Obligation.
by rewrite ! semLiftGenSize (unsized s1 s2).
Qed.
Program Instance liftGenMonotonic {A B} (f : A -> B) (g : G A)
`{SizeMonotonic _ g} : SizeMonotonic (liftGen f g).
Next Obligation.
rewrite ! semLiftGenSize. apply imset_incl. by apply monotonic.
Qed.
Program Instance liftGen2Monotonic {A1 A2 B} (f : A1 -> A2 -> B) (g1 : G A1)
`{SizeMonotonic _ g1} (g2 : G A2) `{SizeMonotonic _ g2} :
SizeMonotonic (liftGen2 f g1 g2).
Next Obligation.
rewrite ! semLiftGen2Size. rewrite ! curry_imset2l.
move => b [a1 [Ha1 [a2 [Ha2 <-]]]].
do 2 (eexists; split; first by eapply (monotonic H1); eauto).
reflexivity.
Qed.
(* end semLiftGen4SizeMonotonic *)
Program Instance liftGen4Monotonic {A B C D E}
(f : A -> B -> C -> D -> E)
(g1 : G A) (g2 : G B) (g3 : G C) (g4 : G D)
`{ SizeMonotonic _ g1} `{ SizeMonotonic _ g2}
`{ SizeMonotonic _ g3} `{ SizeMonotonic _ g4}
: SizeMonotonic (liftGen4 f g1 g2 g3 g4).
Next Obligation.
rewrite ! semLiftGen4Size.
move => t /= [a1 [a2 [a3 [a4 [Ha1 [Ha2 [Ha3 [Ha4 H5]]]]]]]]; subst.
eexists. eexists. eexists. eexists.
repeat (split; try reflexivity); by eapply monotonic; eauto.
Qed.
Program Instance vectorOfUnsized {A} (k : nat) (g : G A)
`{Unsized _ g } : Unsized (vectorOf k g).
Next Obligation.
rewrite ! semVectorOfSize.
split; move => [H1 H2]; split => //; by rewrite unsized; eauto.
Qed.
Program Instance vectorOfMonotonic {A} (k : nat) (g : G A)
`{SizeMonotonic _ g } : SizeMonotonic (vectorOf k g).
Next Obligation.
rewrite ! semVectorOfSize.
move => l [H1 H2]; split => // a Ha. by eapply (monotonic H0); eauto.
Qed.
Program Instance listOfMonotonic {A} (g : G A)
`{SizeMonotonic _ g } : SizeMonotonic (listOf g).
Next Obligation.
rewrite ! semListOfSize.
move => l [H1 H2]; split => //. by eapply leq_trans; eauto.
move => a /H2 Ha. by eapply monotonic; eauto.
Qed.
Program Instance oneofMonotonic {A} (x : G A) (l : list (G A))
`{ SizeMonotonic _ x} `(l \subset SizeMonotonic)
: SizeMonotonic (oneof x l).
Next Obligation.
rewrite !semOneofSize. elim : l H0 => [_ | g gs IH /subconsset [H2 H3]] /=.
- by apply monotonic.
- specialize (IH H3). move => a [ga [[Hga | Hga] Hgen]]; subst.
exists ga. split => //. left => //.
eapply monotonic; eauto. exists ga.
split. right => //.
apply H3 in Hga. by apply (monotonic H1).
Qed.
Program Instance elementsUnsized {A} {def : A} (l : list A) :
Unsized (elements def l).
Next Obligation.
rewrite ! semElementsSize. by case: l.
Qed.
(* A rather long frequency proof, probably we can do better *)
(* end semFrequencySize *)
(* end semFrequency *)
Instance frequencySizeMonotonic_alt :
forall {A : Type} (g0 : G A) (lg : seq (nat * G A)),
SizeMonotonic g0 ->
lg \subset [set x | SizeMonotonic x.2 ] ->
SizeMonotonic (frequency g0 lg).
(* Lemma pickDrop_length_strong {A} (l1 l2 : seq (nat * G (option A))) (n m : nat) g : *)
(*   pickDrop l1 n = (m, g, l2) -> *)
(*   length l2 < length l1 \/ *)
(*   (length l2 = 0 /\ length l1 = 0) \/ *)
(*   (length l2 = 0 /\ (sum_fst l1 = 0 \/ sum_fst l1 <= n)). *)
(* Proof. *)
(*   revert l2 n m g. induction l1; simpl; intros l2 n m g H. *)
(*   - inv H; eauto. *)
(*   - destruct a as [k x]. *)
(*     destruct (n < k) eqn:heq. *)
(*     + inv H. left. now ssromega. *)
(*     +  *)
(*       destruct (pickDrop l1 (n - k)) as [[k' x'] xs'] eqn:Heq. *)
(*       inv H. eapply IHl1 in Heq. *)
(*       destruct Heq as [Hlt' | [[Heq1 Heq2] | [Heq1 [Heq2 | Heq2]]]]. *)
(*       * left. ssromega. *)
(*       * simpl. rewrite sum_fstE Heq1 Heq2. *)
(*         destruct l1; try discriminate. right. right. rewrite sum_fst_eq0P simpl. Hlt.  *)
(*         rewrite length_sum_lst in Hlt; eauto. ssromega. *)
(*       * rewrite sum_fstE in Hlt. *)
(*         rewrite Heq2 in Hlt. ssromega. *)
(* Qed. *)
(* Corollary pickDrop_length {A} (l1 l2 : seq (nat * G (option A))) (n m : nat) g : *)
(*   pickDrop l1 n = (m, g, l2) -> *)
(*   n < sum_fst l1 -> *)
(*   length l2 < length l1 \/ length l2 = 0. *)
(* Proof. *)
(*   intros H1 H2.  *)
(*   edestruct (@pickDrop_length_strong A); eauto. *)
(*   inv H; inv H0; eauto. *)
(* Qed. *)
*)
Definition genPair {A B : Type} (ga : G A) (gb : G B) : G (A * B) :=
liftGen2 pair ga gb.
Definition curry {A B C : Type} (f : A * B -> C) (a : A) (b : B) := f (a,b).
Definition uncurry {A B C : Type} (f : A -> B -> C) (ab : A * B) :=
match ab with
| (a,b) => f a b
end.

Lemma mergeBinds :
forall A B C (ga : G A) (gb : G B) (f : A -> B -> G C),
semGen (bindGen ga (fun x => bindGen gb (f x))) <-->
semGen (bindGen (genPair ga gb) (uncurry f)).