Set Warnings "-extraction-opaque-accessed,-extraction".
Set Warnings "-notation-overridden,-parsing".
Definition resultSuccessful (r : Result) : bool :=
match r with
| MkResult (Some res) expected _ _ _ _ _ =>
res == expected
| _ => true
end.
Definition successful qp :=
match qp with
| MkProp (MkRose res _) => resultSuccessful res
end.
(* Maps a Checker to a Prop *)
(* begin semCheckerSize *)
Definition semCheckerSize (c : Checker) (s : nat): Prop :=
successful @: semGenSize c s \subset [set true].
(* end semCheckerSize *)
(* ZP: Do we want to define semChecker in terms of semCheckerSize? *)
(* begin semChecker *)
Definition semChecker (c : Checker) : Prop := forall s, semCheckerSize c s.
(* end semChecker *)
(* Maps a Checkable to a Prop i.e. gives an equivalent proposition to the property under test *)
(* begin semCheckableSize *)
Definition semCheckableSize {A} `{Checkable A} (a : A) (s : nat) : Prop :=
semCheckerSize (checker a) s.
(* end semCheckableSize *)
(* begin semCheckable *)
Definition semCheckable {A} `{Checkable A} (a : A) : Prop := semChecker (checker a).
(* end semCheckable *)
Definition genChecker c := fmap successful c.
Class UnsizedChecker (c : Checker) :=
{
unsizedChecker :
forall s1 s2 : nat, semGenSize (genChecker c) s1 <--> semGenSize (genChecker c) s2
}.
Class SizeMonotonicChecker (c : Checker) :=
{
monotonicChecker :
forall s1 s2, s1 <= s2 ->
semGenSize (genChecker c) s1 \subset semGenSize (genChecker c) s2
}.
Program Instance unsizedMonotonicChecker (c : Checker) `{UnsizedChecker c} :
SizeMonotonicChecker c.
Next Obligation.
rewrite unsizedChecker. move => b Hb. by eauto.
Qed.
(* Program Instance shrinkingUnsized {C A} `{Checkable C} *)
(*         (sh : A -> list A) (x : A) (pf : A -> C)  *)
(*         `{UnsizedChecker (checker (pf x))} : UnsizedChecker (shrinking sh x pf). *)
(* Next Obligation.  *)
(* Abort. *)
Open Scope Checker_scope.
(* end semImplication *)
Program Instance implicationUnsized
{C} `{Checkable C} b (c : C) `{UnsizedChecker (checker c)} :
UnsizedChecker (b ==> c).
Next Obligation.
move : H0 => [/(_ s1 s2) H0].
rewrite /genChecker in H0 *. rewrite -> !semFmapSize in H0.
rewrite !semFmapSize.
rewrite /implication. case : b; eauto.
apply imset_eq. rewrite !semReturnSize. reflexivity.
Qed.
Program Instance implicationMonotonic
{C} `{Checkable C} b (c : C) `{SizeMonotonicChecker (checker c)} :
SizeMonotonicChecker (b ==> c).
Next Obligation.
move : H0 => [/(_ s1 s2 H1) H0].
rewrite /genChecker in H0 *. rewrite -> !semFmapSize in H0.
rewrite !semFmapSize.
rewrite /implication. case : b; eauto.
apply imset_incl. rewrite !semReturnSize. by move => ? ?; eauto.
Qed.
(* equivalences for other combinators *)

Lemma semBindGenSizeMonotonic {A} (gen : G A) (f : A -> Checker)
`{SizeMonotonic _ gen}
`{forall a, SizeMonotonicChecker (f a)} :
(semChecker (bindGen gen f) <->
forall a, semGen gen a -> semChecker (f a)).