Set Warnings "-extraction-opaque-accessed,-extraction".
Set Warnings "-notation-overridden,-parsing".
Arith
Basics
List
Recdef
ZArith.
ssrbool
ssreflect
ssrnat.
Classes
GenLow
GenHigh
Sets.
GenLow
ListNotations
QcDefaultNotation.
Set Bullet Behavior "Strict Subproofs".
(** Basic generator instances *)
Global Instance genBoolSized : GenSized bool :=
{| arbitrarySized x := choose (false, true) |}.
Instance genNatSized : GenSized nat :=
{| arbitrarySized x := choose (0,x) |}.
Global Instance genZSized : GenSized Z :=
{| arbitrarySized x := let z := Z.of_nat x in
choose (-z, z)%Z |}.
Global Instance genNSized : GenSized N :=
{| arbitrarySized x := let n := N.of_nat x in
choose (N0, n) |}.
Global Instance genListSized {A : Type} `{GenSized A} : GenSized (list A) :=
{| arbitrarySized x := vectorOf x (arbitrarySized x) |}.
(* [3] is a lower priority than [Classes.GenOfGenSized], avoiding an infinite loop in typeclass resolution. *)
Global Instance genList {A : Type} `{Gen A} : Gen (list A) | 3 :=
{| arbitrary := listOf arbitrary |}.
Global Instance genOption {A : Type} `{Gen A} : Gen (option A) | 3 :=
{| arbitrary := freq [ (1, returnGen None)
; (7, liftGen Some arbitrary)] |}.
Global Instance genPairSized {A B : Type} `{GenSized A} `{GenSized B}
: GenSized (A*B) :=
{| arbitrarySized x :=
liftGen2 pair (arbitrarySized x)
(arbitrarySized x)
|}.
Global Instance genPair {A B : Type} `{Gen A} `{Gen B} : Gen (A * B) :=
{| arbitrary := liftGen2 pair arbitrary arbitrary |}.
(** Shrink Instances *)
Global Instance shrinkBool : Shrink bool :=
{| shrink x :=
match x with
| false => nil
| true  => cons false nil
end
|}.
(** Shrinking of nat starts to become annoying *)
Function shrinkNatAux (x : nat) {measure (fun x => x) x} : list nat :=
match x with
| O => nil
| S n =>
let x' := Nat.div x 2 in
x' :: shrinkNatAux x'
end.
Function shrinkZAux (x : Z) {measure (fun x => Z.abs_nat x) x}: list Z :=
match x with
| Z0 => nil
| Zpos _ => rev (cons (Z.pred x) (cons (Z.div2 x) (shrinkZAux (Z.div2 x))))
| Zneg _ => rev (cons (Z.succ x) (cons (Z.succ (Z.div2 x)) (shrinkZAux (Z.succ (Z.div2 x)))))
end.
Global Instance shrinkZ : Shrink Z :=
{| shrink := shrinkZAux |}.
Open Scope program_scope.
Global Instance shrinkN : Shrink N :=
{| shrink := map Z.to_N ∘ shrink ∘ Z.of_N |}.
Fixpoint shrinkListAux {A : Type} (shr : A -> list A) (l : list A) : list (list A) :=
match l with
| nil => nil
| cons x xs =>
cons xs (map (fun xs' => cons x xs') (shrinkListAux shr xs))
++ (map (fun x'  => cons x' xs) (shr x ))
end.
Global Instance shrinkList {A : Type} `{Shrink A} : Shrink (list A) :=
{| shrink := shrinkListAux shrink |}.
Global Instance shrinkPair {A B} `{Shrink A} `{Shrink B} : Shrink (A * B) :=
{|
shrink := fun (p : A * B) =>
let (a,b) := p in
map (fun a' => (a',b)) (shrink a) ++ map (fun b' => (a,b')) (shrink b)
|}.
Global Instance shrinkOption {A : Type} `{Shrink A} : Shrink (option A) :=
{| shrink m :=
match m with
| None => []
| Some x => None :: (map Some (shrink x))
end
|}.
(** Arbitraries are derived automatically! *)
(** Instance correctness *)
Program Instance arbNatMon : SizeMonotonic (@arbitrary nat _).
Next Obligation.
rewrite !semSizedSize !semChooseSize // => n /andP [/leP H1 /leP H2].
move : H => /leP => Hle. apply/andP. split; apply/leP; omega.
Qed.
(** Correctness proof about built-in generators *)
Instance boolSizeMonotonic : SizeMonotonic (@arbitrary bool _).
Instance boolSizedMonotonic : SizedMonotonic (@arbitrarySized bool _).
Instance boolCorrect : Correct bool arbitrary.
Instance ArbNatGenCorrect : Correct nat arbitrary.

Lemma arbList_correct:
forall {A} `{H : Arbitrary A} (P : nat -> A -> Prop) s,
(semGenSize arbitrary s <--> P s) ->
(semGenSize arbitrary s <-->
(fun (l : list A) => length l <= s /\ (forall x, List.In x l -> P s x))).