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 *)
Instance forAllMonotonic {A C} {_ : Checkable C} `{Show A} (g : G A) (f : A -> C)
`{SizeMonotonic _ g} `{forall x, SizeMonotonicChecker (checker (f x))} :
SizeMonotonicChecker (forAll g f).
Admitted.
(* end semForAllSizeMonotonic *)
*)
(* CH: We could create a super class UCheckable that includes the unsized assumption. And we could use sections to hide all the type class stuff from the paper. *)
(* CH: This will be affected by upcoming refactoring; proving it like this only because it appears in ITP submission *)
(* end semCheckableBool *)
Program Instance boolUnsized (b : bool) : UnsizedChecker (checker b).
Next Obligation.
rewrite !semFmapSize !semReturnSize. apply imset_eq. reflexivity.
Qed.
Program Instance resultUnsized (r : Result) : UnsizedChecker (checker r).
Next Obligation.
rewrite !semFmapSize !semReturnSize. apply imset_eq. reflexivity.
Qed.
Program Instance unitUnsized : UnsizedChecker (checker tt).
Next Obligation.
rewrite !semFmapSize !semReturnSize. apply imset_eq. reflexivity.
Qed.
Program Instance qpUnsized (qp : QProp) : UnsizedChecker (checker qp).
Next Obligation.
rewrite !semFmapSize !semReturnSize. apply imset_eq. reflexivity.
Qed.

Lemma semCheckableFunSize:
forall {A C} {H1 : Show A} `{H2 : Arbitrary A} {H3 : Checkable C}
(f : A -> C) (size: nat),
semCheckableSize f size <->
forall (a : A), semGenSize arbitrary size a -> semCheckableSize (f a) size.