Require Export Lambda.STLC.Has.

Reserved Notation "'`⟦' τ '⟧'"
         (at level 20, no associativity).

Fixpoint denote_type (τ : type) : Set :=
  match τ with
  | ⊥%ty => Empty_set
  | (τ₁ → τ₂)%ty => (`⟦τ₁⟧ -> `⟦τ₂⟧)%ty
  end
where "'`⟦' τ '⟧'" := (denote_type τ) : ty_scope.

(*Reserved Notation "'⟦' t '⟧'"
         (at level 20, no associativity).*)

Equations denote_term : forall {Γ : list type} {τ : type},
    hlist denote_type Γ -> Γ ⊢ τ -> `⟦ τ ⟧ :=
  denote_term ϵ (Id _ _ hs)    := lookup_has ϵ hs;
  denote_term ϵ (λ τ ⇒ t)%term := fun x : `⟦ τ ⟧ => denote_term (hcons x ϵ) t;
  denote_term ϵ (t₁ ⋅ t₂)%term := (denote_term ϵ t₁) (denote_term ϵ t₂)
(*where "⟦ t ⟧" := (denote_term t) : term_scope*).


Load LFindLoad.
From lfind Require Import LFind.
Require Import Arith.
From adtind Require Import goal49.

Set Printing Depth 1000.
Definition lfind_eval  y n:=
mem n y.

Compute lfind_eval  (Cons (Succ Zero) (Cons (Succ (Succ (Succ Zero))) Nil)) (Zero).

Compute lfind_eval  (Cons (Succ Zero) Nil) (Zero).

Compute lfind_eval  (Cons (Succ (Succ (Succ (Succ Zero)))) Nil) (Zero).

Compute lfind_eval  (Cons (Succ (Succ Zero)) Nil) (Zero).

Compute lfind_eval  (Cons Zero (Cons (Succ (Succ Zero)) Nil)) (Succ Zero).

Compute lfind_eval  (Nil) (Succ (Succ (Succ Zero))).

Compute lfind_eval  (Cons Zero (Cons (Succ Zero) Nil)) (Succ Zero).

Compute lfind_eval  (Nil) (Succ (Succ Zero)).

Compute lfind_eval  (Cons (Succ (Succ (Succ Zero))) Nil) (Zero).

Compute lfind_eval  (Nil) (Succ (Succ (Succ (Succ Zero)))).

Compute lfind_eval  (Cons (Succ (Succ Zero)) (Cons Zero (Cons Zero Nil))) (Zero).

Compute lfind_eval  (Cons Zero Nil) (Zero).

Compute lfind_eval  (Cons (Succ (Succ Zero)) Nil) (Succ (Succ Zero)).

Compute lfind_eval  (Cons (Succ Zero) (Cons (Succ Zero) Nil)) (Succ (Succ Zero)).

Compute lfind_eval  (Nil) (Succ Zero).

Compute lfind_eval  (Nil) (Zero).


Require Import Coq.ZArith.ZArith.
Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.montgomery32_2e521m1_17limbs.Synthesis.
Local Open Scope Z_scope.

(* TODO : change this to field once field isomorphism happens *)
Definition nonzero :
  { nonzero : feBW_small -> BoundedWord.BoundedWord 1 adjusted_bitwidth bound1
  | forall a, (BoundedWord.BoundedWordToZ _ _ _ (nonzero a) =? 0) = (if Decidable.dec (phiM_small a = F.of_Z m 0) then true else false) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_nonzero ().
  Show Ltac Profile.
Time Defined.

Print Assumptions nonzero.


Require Import Coq.ZArith.ZArith.
Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.montgomery32_2e165m25_6limbs.Synthesis.
Local Open Scope Z_scope.

(* TODO : change this to field once field isomorphism happens *)
Definition nonzero :
  { nonzero : feBW_small -> BoundedWord.BoundedWord 1 adjusted_bitwidth bound1
  | forall a, (BoundedWord.BoundedWordToZ _ _ _ (nonzero a) =? 0) = (if Decidable.dec (phiM_small a = F.of_Z m 0) then true else false) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_nonzero ().
  Show Ltac Profile.
Time Defined.

Print Assumptions nonzero.


Require Import Coq.ZArith.ZArith.
Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.montgomery32_2e137m13_5limbs.Synthesis.
Local Open Scope Z_scope.

(* TODO : change this to field once field isomorphism happens *)
Definition nonzero :
  { nonzero : feBW_small -> BoundedWord.BoundedWord 1 adjusted_bitwidth bound1
  | forall a, (BoundedWord.BoundedWordToZ _ _ _ (nonzero a) =? 0) = (if Decidable.dec (phiM_small a = F.of_Z m 0) then true else false) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_nonzero ().
  Show Ltac Profile.
Time Defined.

Print Assumptions nonzero.


Require Import Coq.ZArith.ZArith.
Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.montgomery64_2e129m25_3limbs.Synthesis.
Local Open Scope Z_scope.

(* TODO : change this to field once field isomorphism happens *)
Definition nonzero :
  { nonzero : feBW_small -> BoundedWord.BoundedWord 1 adjusted_bitwidth bound1
  | forall a, (BoundedWord.BoundedWordToZ _ _ _ (nonzero a) =? 0) = (if Decidable.dec (phiM_small a = F.of_Z m 0) then true else false) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_nonzero ().
  Show Ltac Profile.
Time Defined.

Print Assumptions nonzero.


Require Import Coq.ZArith.ZArith.
Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.montgomery64_2e401m31_7limbs.Synthesis.
Local Open Scope Z_scope.

(* TODO : change this to field once field isomorphism happens *)
Definition nonzero :
  { nonzero : feBW_small -> BoundedWord.BoundedWord 1 adjusted_bitwidth bound1
  | forall a, (BoundedWord.BoundedWordToZ _ _ _ (nonzero a) =? 0) = (if Decidable.dec (phiM_small a = F.of_Z m 0) then true else false) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_nonzero ().
  Show Ltac Profile.
Time Defined.

Print Assumptions nonzero.


(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Set Primitive Projections.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Unset Positivity Checking.
Unset Guard Checking.

Inductive nat : Set :=
| O : nat
| S : nat -> nat.

Inductive natural : Set :=
| Zero : natural
| Succ : natural -> natural.

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) {struct plus_arg0}
  : natural :=
  match plus_arg0 with
  | Zero => plus_arg1
  | Succ n => Succ (plus n plus_arg1)
  end.

Fixpoint mult (mult_arg0 : natural) (mult_arg1 : natural) {struct mult_arg0}
  : natural :=
  match mult_arg0 with
  | Zero => Zero
  | Succ n => plus (mult n mult_arg1) mult_arg1
  end.

Definition synth (lf2 : natural) (y : natural) (lf1 : natural) : natural := lf2.


Require Export FunctorCategory NaturalTransformation.Composition.
Require Import Common.

Set Implicit Arguments.
Generalizable All Variables.
Set Asymmetric Patterns.
Set Universe Polymorphism.

Section FunctorialComposition.
  Context `{Funext}.
  Variable C : PreCategory.
  Variable D : PreCategory.
  Variable E : PreCategory.

  Local Open Scope natural_transformation_scope.

  Definition NTWhiskerL_Functorial (F : [D, E]%category)
  : [[C, D], [C, E]]%category
    := Build_Functor
         [C, D] [C, E]
         (fun G => F ∘ G)
         (fun _ _ T => F ∘ T)
         (fun _ _ _ _ _ => NTWhiskerL_CompositionOf _ _ _)
         (fun _ => RightIdentityNaturalTransformationWhisker _ _).

  Definition NTWhiskerR_Functorial (G : [C, D]%category)
  : [[D, E], [C, E]]%category
    := Build_Functor
         [D, E] [C, E]
         (fun F => F ∘ G)
         (fun _ _ T => NTWhiskerR T G)
         (fun _ _ _ _ _ => inverse (NTWhiskerR_CompositionOf _ _ _))
         (fun _ => LeftIdentityNaturalTransformationWhisker _ _).
End FunctorialComposition.


Require Export Coq.Lists.ListSet.
Require Export Coq.Lists.List.
Require Export Coq.Bool.Bool.
Require Export Coq.Classes.RelationClasses.
Require Export formulatheory_def.
Import FormulaTheory.

Theorem not_compat : forall A B : Prop,
  (A = B) -> ((~ A) = (~B)).
Proof.
  intros.
  rewrite H.
  reflexivity.
Qed.

Lemma set_union_elim_not :
   forall (a:Name) (x y:set Name),
     ~(set_In a (set_union name_dec_axiom x y)) ->
        ~(set_In a x) /\ ~(set_In a y).
Proof.
  intros. split.
    + intuition. apply H. apply set_union_intro1. apply H0.
    + intuition. apply H. apply set_union_intro2. apply H0.
Qed.

Lemma set_union_elim_not2 :
   forall (a:Name) (x y:set Name),
     ~(set_In a x) /\ ~(set_In a y) ->
      ~(set_In a (set_union name_dec_axiom x y)).
Proof.
  intros. destruct H.
  intuition. apply H.
  apply set_union_elim in H1.
  generalize H1. tauto.
Qed.

Theorem or_commut : forall P Q : Prop,
  P \/ Q -> Q \/ P.
Proof.
  intros P Q H.
  tauto. Qed.

Lemma set_diff_elim_not:
    forall (n : Name) (f1 f2 : Formula),
    ~ set_In n (set_diff name_dec_axiom (names_func f1) (names_func f2)) ->
    ~ set_In n (names_func f1) \/ set_In n (names_func f2).
Proof.
  intros. left.
  intuition. apply H.
  apply set_diff_intro.
  + apply H0.
  + unfold not. intro.
  apply H. apply set_diff_intro.
  apply H0.
Admitted.


(** * (co)limits assemble into functors *)
Require Import Category.Core Functor.Core.
Require Import KanExtensions.Functors.
Require Import Limits.Core.
Require Import FunctorCategory.Core.
Require Import Adjoint.Core.
Require Import NatCategory.

Set Universe Polymorphism.
Set Implicit Arguments.
Generalizable All Variables.
Set Asymmetric Patterns.

(** (co)limits assemble into functors *)

Local Open Scope category_scope.

Section functors.
  Context `{Funext}.
  Variables C D : PreCategory.

  (** ** Colimit functor, which is left adjoint to Δ *)
  Section colimit.
    Context `(has_colimits
              : forall F : Functor D C,
                  @IsColimit _ C D F (colimits F)).

    (** TODO(jgross): We'll probably want to compose this with the
        functor from [1 → C] to [C], and then compose the adjunctions
        similarly.  This will require turning the equality in the
        exponential laws into an adjunction. Probably not very
        hard. *)

    Definition colimit_functor : Functor (D -> C) (1 -> C)
      := left_kan_extension_functor has_colimits.

    Definition colimit_adjunction
    : colimit_functor -| diagonal_functor _ _
      := left_kan_extension_adjunction has_colimits.
  End colimit.

  Section limit.
    Context `(has_limits
              : forall F : Functor D C,
                  @IsLimit _ C D F (limits F)).

    (** TODO(jgross): We'll probably want to compose this with the
        functor from [1 -> C] to [C], and then compose the adjunctions
        similarly.  This will require turning the equality in the
        exponential laws into an adjunction. Probably not very
        hard. *)

    (** ** Limit functor, which is right adjoint to Δ *)
    Definition limit_functor : Functor (D -> C) (1 -> C)
      := right_kan_extension_functor has_limits.

    Definition limit_adjunction
    : diagonal_functor _ _ -| limit_functor
      := right_kan_extension_adjunction has_limits.
  End limit.
End functors.


Require Import IZF.

Module IZFSetsF (ST: IZF).
  Import ST.

  Notation "A ∧ B" := (prod A B) (at level 80).

  Lemma replacement_prf :
    forall {D} (f: forall x, x ∈ D -> set),
      {P: @formula D & (forall x y (p: x ∈ D), proj1_sig P x y <-> y ≡ f x p) ∧ forall x y, proj1_sig P x y -> x ∈ D}.
  Proof.
    intros.
    simple refine (existT _ _ _).
    unfold formula.
    exists (fun x y => exists p, y ≡ f x p).
    intros.
    exists (f x H). exists H. auto with zf.
    split; simpl; intros.
    split; intros.
    destruct H.
    rewrite (M p x0).
    auto.
    exists p. auto.
    destruct H.
    auto.
  Qed.

  Definition replacement : forall {D}, (forall x, x ∈ D -> set) -> set.
  Proof.
    intros.
    destruct (replacement_prf X).
    destruct p.
    simple refine (collection _).
    exact D.
    exact x.
  Defined.

  Lemma replacement_propH : forall {D f x}, x ∈ replacement f -> exists d (H: d ∈ D), f d H ≡ x.
  Proof.
    unfold replacement.
    intros.
    destruct (replacement_prf f).
    destruct p.
    simpl in *; intros.
    apply collection_propH in H.
    destruct H.
    destruct H.
    exists x1. exists H.
    destruct (i x1 x H).
    apply H1 in H0.
    eauto with zf.
  Qed.

  Lemma replacement_propG : forall {D f x}, (exists d (H: d ∈ D), f d H ≡ x) -> x ∈ replacement f.
  Proof.
    intros.
    destruct H.
    destruct H.
    subst x.
    unfold replacement.
    destruct (replacement_prf f).
    destruct p.
    apply collection_propG.
    exists x0. split. auto.
    destruct (i x0 (f x0 x1) x1).
    assert (f x0 x1 ≡ f x0 x1) by auto.
    apply H0 in H1.
    auto.
  Qed.

  Definition cartesian_product (A B: set) :=
    union (replacement (fun x (_: x ∈ A) => replacement (fun y (_: y ∈ B) => ⟨x,y⟩))).
  Notation "A × B" := (cartesian_product A B) (at level 60).

  Lemma cartesian_product_propG : forall {A B z}, (exists x y, x ∈ A /\ y ∈ B /\ z ≡ ⟨x,y⟩) -> z ∈ A × B.
  Proof.
    intros. unfold cartesian_product.
    repeat destruct H.
    destruct H0.
    subst z.
    apply union_propG.
    exists (replacement (fun y (_: y ∈ B) => ⟨x,y⟩)).
    split. apply replacement_propG.
    exists x. exists H.
    auto.
    apply replacement_propG.
    exists x0. exists H0. auto.
  Qed.

  Lemma cartesian_product_propH : forall {A B z}, z ∈ A × B -> exists x y, x ∈ A /\ y ∈ B /\ z ≡ ⟨x,y⟩.
  Proof.
    intros.
    unfold cartesian_product in H.
    apply union_propH in H.
    destruct H. destruct H.
    apply replacement_propH in H.
    destruct H. destruct H.
    subst x.
    apply replacement_propH in H0.
    destruct H0. destruct H.
    subst z.
    exists x0. exists x. auto.
  Qed.

  Definition disjoint_union {I} (F: forall x, x ∈ I -> set) :=
    union (replacement (fun x (H: x ∈ I) => replacement (fun y (_: y ∈ F x H) => ⟨x,y⟩))).

  Notation "⨆ F" := (disjoint_union F) (at level 60).

  Lemma disjoint_union_propG : forall {I F z}, (exists x (H: x ∈ I) y, y ∈ F x H /\ z ≡ ⟨x,y⟩) -> z ∈ ⨆F.
  Proof.
    intros. unfold disjoint_union.
    repeat destruct H.
    subst z.
    apply union_propG.
    exists (replacement (fun y (_: y ∈ F x x0) => ⟨x,y⟩)).
    split. apply replacement_propG.
    exists x. exists x0. auto.
    apply replacement_propG.
    exists x1. exists H. auto.
  Qed.

  Lemma disjoint_union_propH : forall {I F z}, z ∈ ⨆F -> exists x (H: x ∈ I) y, y ∈ F x H /\ z ≡ ⟨x,y⟩.
  Proof.
    intros. unfold disjoint_union in H.
    apply union_propH in H.
    repeat destruct H.
    apply replacement_propH in H.
    repeat destruct H.
    apply replacement_propH in H0.
    destruct H0. destruct H.
    subst z. exists x0. exists x1. exists x.
    auto.
  Qed.

  Lemma cartesian_product_is_extreme_disjoint_union : forall {A B}, A × B ≡ ⨆(fun x (_: x ∈ A) => B).
  Proof.
    reflexivity.
  Qed.

  Definition union2 (A B: set) := ⋃ (A +> (B +> ∅)).
  Notation "x ∪ y" := (union2 x y) (at level 60).

  Lemma union2_propG : forall {A B x}, (x ∈ A \/ x ∈ B) -> x ∈ A ∪ B.
  Proof.
    intros.
    unfold union2.
    intros.
    destruct H.
    assert (A ∈ A +> (B +> ∅)) by eauto with zf.
    eauto with zf.
    assert (B ∈ A +> (B +> ∅)) by eauto with zf.
    eauto with zf.
  Qed.

  Lemma union2_propH : forall {A B x}, x ∈ A ∪ B -> x ∈ A \/ x ∈ B.
  Proof.
    unfold union2.
    intros.
    apply union_propH in H.
    destruct H.
    destruct H.
    apply insert_propH in H.
    destruct H.
    apply insert_propH in H.
    destruct H.
    apply empty_prop in H.
    contradiction.
    rewrite H in *.
    eauto with zf.
    rewrite H in *.
    eauto with zf.
  Qed.
  Hint Resolve union2_propH union2_propG : zf.

  Definition ϵ_iter Γ := ϵ_rec (fun x f => ⋃ (replacement (fun x H => Γ(f x H)))).

  Lemma ϵ_iter_prop : forall {Γ x},
      ϵ_iter Γ x = ⋃ replacement (fun y (_: y ∈ x) => Γ(ϵ_iter Γ y)).
  Proof.
    intros.
    unfold ϵ_iter.
    rewrite ϵ_rec_prop.
    eauto with zf.
  Qed.

  Definition lfp (Γ: set -> set) := ⋃ replacement (fun x (_: x ∈ ω) => ϵ_iter Γ x).

  Lemma replacement_of_empty : forall {f},
      @replacement ∅ f ≡ ∅.
  Proof.
    intros.
    apply equiv_ext.
    split; intros.
    apply replacement_propH in H.
    destruct H. destruct H.
    apply empty_prop in x0 as H1.
    contradiction.
    apply empty_prop in H.
    contradiction.
  Qed.

  Lemma union_empty : ⋃∅ ≡ ∅.
  Proof.
    apply equiv_ext.
    split; intros.
    apply union_propH in H.
    destruct H. destruct H.
    apply empty_prop in H.
    contradiction.
    apply empty_prop in H.
    contradiction.
  Qed.

  Definition monotone Γ := forall x y, x ⊆ y -> Γ x ⊆ Γ y.

  Lemma union_monotone : monotone union.
  Proof.
    unfold monotone.
    unfold subset.
    intros.
    apply union_propG.
    apply union_propH in H0.
    destruct H0. destruct H0.
    apply H in H0.
    exists x1. eauto.
  Qed.

  Definition monotone_dom {x} (Γ: forall y, y ∈ x -> set) :=
    forall z w (p: z ∈ x) (p0: w ∈ x), z ⊆ w -> Γ z p ⊆ Γ w p0.

  Definition restrict_dom {x y} (p: x ⊆ y) (Γ: forall z, z ∈ y -> set)
    : forall z, z ∈ x -> set.
  Proof.
    intros.
    exact (Γ z (p z H)).
  Defined.

  Lemma replacement_monotone :
    forall {D E Γ} (p: D ⊆ E), replacement (restrict_dom p Γ) ⊆ replacement Γ.
  Proof.
    unfold subset.
    unfold restrict_dom.
    intros.
    apply replacement_propH in H.
    destruct H. destruct H.
    subst x.
    apply replacement_propG.
    exists x0. exists (p x0 x1). auto.
  Qed.

  Lemma ϵ_iter_monotone : forall {Γ}, monotone (ϵ_iter Γ).
  Proof.
    (* by the definition of monotonicities, it suffices to prove: *)
    (* ∀Γ x y, x ⊆ y → ∀x0 x0 ∈ ϵ_iter Γ x → x0 ∈ ϵ_iter Γ y *)
    unfold monotone.
    unfold subset.
    intros.
    rewrite ϵ_iter_prop in H0.
    (* x0 ∈ ϵ_iter Γ x, therefore x0 ∈ ⋃{ Γ(ϵ_iter Γ y) | y ∈ x } *)
    apply union_propH in H0.
    (* therefore ∃x1 ∈ { Γ(ϵ_iter Γ y) | y ∈ x} s.t. x0 ∈ x1 *)
    destruct H0. destruct H0.
    apply replacement_propH in H0.
    (* therefore ∃x2 ∈ x s.t Γ(ϵ_iter Γ x2) ≡ x1 *)
    destruct H0. destruct H0.
    subst x1.
    (* so x0 ∈ Γ(ϵ_iter Γ x2) *)
    rewrite ϵ_iter_prop.
    (* it suffices to prove x0 ∈ ⋃{ Γ(ϵ_iter Γ x) | x ∈ y } *)
    apply union_propG.
    (* so we have to provide a y0 ∈ { Γ(ϵ_iter Γ x) | x ∈ y} s.t. x0 ∈ y0 *)
    exists (Γ (ϵ_iter Γ x2)).
    split.
    apply replacement_propG.
    (* Γ(ϵ_iter Γ x2) ∈ { Γ(ϵ_iter Γ x) | x ∈ y } as x2 ∈ y *)
    exists x2. exists (H x2 x3). auto.
    (* as previously proven, x0 ∈ Γ(ϵ_iter Γ x2) *)
    auto.
  Qed.

  Lemma ϵ_iter_empty : forall {Γ}, ϵ_iter Γ ∅ ≡ ∅.
  Proof.
    intros.
    apply equiv_ext.
    split; intros.
    rewrite ϵ_iter_prop in H.
    rewrite replacement_of_empty in H.
    rewrite union_empty in H.
    auto.
    apply empty_prop in H.
    contradiction.
  Qed.

  Lemma union2_comm : forall {x y}, x ∪ y ≡ y ∪ x.
  Proof.
    intros.
    apply equiv_ext.
    split; intros;
    apply union2_propH in H;
    apply union2_propG;
    destruct H; auto.
  Qed.

  Lemma union2_assoc : forall {x y z}, x ∪ (y ∪ z) ≡ (x ∪ y) ∪ z.
  Proof.
    intros.
    apply equiv_ext.
    split; intros.
    apply union2_propG.
    apply union2_propH in H.
    destruct H.
    left.
    apply union2_propG.
    auto.
    apply union2_propH in H.
    destruct H.
    left.
    apply union2_propG.
    auto.
    auto.
    apply union2_propG.
    apply union2_propH in H.
    destruct H.
    apply union2_propH in H.
    destruct H.
    left.
    auto.
    right.
    apply union2_propG.
    auto.
    right.
    apply union2_propG.
    auto.
  Qed.

  Lemma union2_ident : forall {x}, x ∪ ∅ ≡ x.
  Proof.
    intros.
    apply equiv_ext.
    split; intros.
    apply union2_propH in H.
    destruct H.
    auto.
    apply empty_prop in H.
    contradiction.
    apply union2_propG.
    auto.
  Qed.

  Lemma in_ϵ_iter_sup :
    forall {Γ x y z}, x ∈ ϵ_iter Γ y -> y ⊆ z -> x ∈ ϵ_iter Γ z.
  Proof.
    intros.
    rewrite ϵ_iter_prop in H.
    apply union_propH in H.
    destruct H. destruct H.
    apply replacement_propH in H.
    destruct H. destruct H.
    subst x0.
    rewrite ϵ_iter_prop.
    apply union_propG.
    exists (Γ (ϵ_iter Γ x1)).
    split.
    apply replacement_propG.
    exists x1. exists (H0 _ x2).
    auto.
    auto.
  Qed.

  Lemma union2_insert :
    forall {x y z}, x ∪ (y +> z) ≡ y +> (x ∪ z).
  Proof.
    intros.
    apply equiv_ext.
    split; intros.
    apply union2_propH in H.
    apply insert_propG.
    destruct H.
    left.
    apply union2_propG.
    auto.
    apply insert_propH in H.
    destruct H.
    left.
    apply union2_propG.
    auto.
    auto.
    apply insert_propH in H.
    apply union2_propG.
    destruct H.
    apply union2_propH in H.
    destruct H.
    auto.
    right.
    eauto with zf.
    eauto with zf.
  Qed.

  Lemma empty_subset :
    forall {x}, ∅ ⊆ x.
  Proof.
    unfold subset.
    intros.
    apply empty_prop in H.
    contradiction.
  Qed.

End IZFSetsF.


(** naimonowanai. v *)

Definition aru {T: Type} (x: T) : Prop :=
  exists y, x = y.

Example ex1: aru 1.
Proof.
  unfold aru. exists 1. reflexivity.
Qed.

Definition nai {T: Type} (x: T) : Prop :=
  ~ (aru x).

Theorem nai_nara_nai: forall (T: Type) (x: T),
    nai x -> nai x.
Proof.
  intros T x Hnai. apply Hnai.
Qed.

Theorem nai_monowa_sonzai_sinai: forall (T: Type),
    ~ (exists (x: T), nai x).
Proof.
  intros T contra.
  destruct contra as [x Hnai].
  apply Hnai.
  unfold aru. exists x. reflexivity.
Qed.

Theorem subetewa_aru: forall (T: Type) (x: T),
    aru x.
Proof.
  intros T x. exists x. reflexivity.
Qed.


From AIM Require Export Coqlib.
Require Import Arith.
From AIM Require Export Machine.
From AIM Require Export Assertions.
From AIM Require Export Operations.

Definition ptoNode (Node : Set) (inMem : Label -> Node -> MPred) (l prev next : Label) (node : Node) : MPred :=
  mstar (mstar (ptoW l prev) (ptoW (l+2) next)) (inMem (l+4) node).

(* Queue Node inMemNode head tail head_prev tail_post Q M *)
(* head : head of queue;  tail : tail of queue *)
(* head_prev : prev field in the head node     *)
(* tail_next : next field in the tail node     *)
(* Q : corresponding abstract set of Node      *)

Inductive Queue (Node : Set) (inMemNode : Label -> Node -> MPred) :
  Label -> Label -> Label -> Label -> (Label -> option Node) -> Mem -> Prop :=

  Q_emp       : forall prev next,
            Queue Node inMemNode 0 0 prev next (fun l => None) MemMod.emp

| Q_cons_fst  :  forall l prev next node M ,
  (ptoNode Node inMemNode l prev next node) M
  -> l > 0
  -> Queue Node inMemNode l l prev next
     (fun l' => if eq_nat_dec l l' then Some node else None) M

| Q_cons_more : forall head tail prev Q M1 M2 M l next' node,
  MemMod.disjUnion M1 M2 M
  -> (Queue Node inMemNode head tail prev l Q) M1
  -> (ptoNode Node inMemNode l tail next' node) M2
  -> tail > 0
  -> l > 0
  -> Queue Node inMemNode head l prev next'
  (fun l' => if eq_nat_dec l l' then Some node else Q l') M.

Arguments Q_emp [Node inMemNode].
Arguments Q_cons_fst [Node inMemNode].
Arguments Q_cons_more [Node inMemNode].

Definition ptoQ (Node : Set) (inMemNode : Label -> Node -> MPred) (l : Label) (Q : Label -> option Node) : MPred :=
  fun (M : Mem) =>
  exists head, exists tail, exists prev,
    mstar (mstar (ptoW l head) (ptoW (l+2) tail)) (Queue Node inMemNode head tail prev 0 Q) M.


Require Import ZArith.
Require Import List.
Import ListNotations.

Require Import Instr.
Require Import Lattices.
Require Import Concrete.
Require Import CodeGen.
Require Import CodeTriples.
Require Import CodeSpecs.
Require Import Encodable.

Local Open Scope Z_scope.

(** A [ConcreteLattice] is a way of computing over the elements of some
encodable lattice, as defined in [Encodable.v] and [Lattices.v]. This
is used in the fault handler of the concrete machine to interpret the
plain integer tags as ifc-labels.

This comprises the implementation of three lattice primitives in
machine code, [genBot], [genJoin] and [genFlows]. We also define the
notion of a correct lattice encoding, [WfConcreteLattice], which will
be needed when proving the correctness of the fault handler.
*)

(** The methods of [ConcreteLattice], are pieces of code that should
implement the three lattice methods [bot], [join] and [flows],
operating on integers encoding elements of [T]. Notice that we don't
place any correctness assumptions on these operations; these
requirements are laid out in the [WfConcreteLattice] class, given
later. *)
Class ConcreteLattice (T: Type) :=
{ genBot : list Instr
; genJoin : list Instr
; genFlows : list Instr
}.

(** [TMUHL] is an example showing that we can implement the simple H/L
lattice using the implementation of the corresponding boolean
operations defined in [CodeGen.v] *)
Instance TMUHL : ConcreteLattice Lab :=
{ genBot := genFalse
  ;genJoin := genOr
  ;genFlows := genImpl
}.

(** In order for a lattice implementation to be correct, each piece of
code in [ConcreteLattice] must compute exactly what we expect. We
specify that with the Hoare triples defined in [CodeTriples.v]. *)
Class WfConcreteLattice (T: Type) (L : JoinSemiLattice T) (CL: ConcreteLattice T) (E : Encodable T) :=
{ genBot_spec: forall Q,
   HT genBot
      (fun m s => Q m ((labToZ bot,handlerTag):::s))
      Q
; genJoin_spec: forall Q,
   HT  genJoin
       (fun m s => exists l l' s0, s = (labToZ l, handlerTag) :::
                                       (labToZ l', handlerTag)::: s0 /\
                                   Q m ((labToZ (join l l'), handlerTag) ::: s0))
       Q
; genFlows_spec: forall Q,
   HT  genFlows
       (fun m s => exists l l' s0, s = (labToZ l, handlerTag) :::
                                       (labToZ l', handlerTag)::: s0 /\
                            Q m ((boolToZ (flows l l'), handlerTag) ::: s0))
       Q

}.

(** We can easily show that the encoding [TMUHL] of [Lab] above is correct. We
prove the four required lemmas, and them package them in the [TMUHLwf]
class below. *)
Lemma ZToLab_labToZ_id_HL : forall l, l = ZToLab (labToZ l).
Proof.
  intros.
  destruct l; auto.
Qed.

Lemma genBot_spec_HL : forall Q,
   HT genBot
      (fun m s => Q m ((labToZ bot,handlerTag):::s))
      Q.
Proof.
   intros.
   unfold genBot, TMUHL.
   eapply genFalse_spec; simpl; eauto.
Qed.

Lemma genJoin_spec_HL : forall Q,
   HT  genJoin
       (fun m s => exists l l' s0, s = (labToZ l, handlerTag) :::
                                       (labToZ l', handlerTag)::: s0 /\
                                   Q m ((labToZ (join l l'), handlerTag) ::: s0))
       Q.
Proof.
  intros.
  unfold genJoin, TMUHL.
  eapply HT_strengthen_premise.
  eapply genOr_spec; eauto.
  simpl. intros. destruct H as [l [l' [s0 Hint]]]. intuition.
  destruct l eqn:?; destruct l' eqn:?; subst; unfold labToZ, boolToZ in *.
  exists false; exists false; exists s0 ;
  intuition; eauto.
  exists false; exists true; exists s0 ;
  intuition; eauto.
  exists true; exists false; exists s0 ;
  intuition; eauto.
  exists true; exists true; exists s0 ;
  intuition; eauto.
Qed.

Lemma genFlows_spec_HL: forall Q,
   HT  genFlows
       (fun m s => exists l l' s0, s = (labToZ l, handlerTag) :::
                                       (labToZ l', handlerTag)::: s0 /\
                            Q m ((boolToZ (flows l l'), handlerTag) ::: s0))
       Q.
Proof.
  intros.
  unfold genFlows, TMUHL, genImpl.
  eapply HT_compose_bwd.
  eapply genOr_spec.
  unfold genNot.
  eapply HT_strengthen_premise.
  eapply ifNZ_spec_existential.
  eapply push_spec.
  eapply push_spec.
  split_vc.
  destruct x, x0 ; simpl in *; intuition; subst; unfold boolToZ.
  exists true; exists false; exists x1 ;
  intuition; eauto.
  exists true; exists true; exists x1 ;
  intuition; eauto.
  exists false; exists false; exists x1 ;
  intuition; eauto.
  exists false; exists true; exists x1 ;
  intuition; eauto.
Qed.

Instance TMUHLwf : WfConcreteLattice Lab HL TMUHL EncodableHL :=
{ genBot_spec := genBot_spec_HL
; genJoin_spec := genJoin_spec_HL
; genFlows_spec := genFlows_spec_HL
}.


(**
Each homotopy between functions give rise to a pseudotransformation
 *)
Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.PrecategoryBinProduct.
Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations.
Require Import UniMath.Bicategories.Core.Invertible_2cells.
Require Import UniMath.Bicategories.Core.BicategoryLaws.
Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat.
Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor.
Require Import UniMath.Bicategories.Transformations.PseudoTransformation.
Import PseudoFunctor.Notations.
Require Import UniMath.Bicategories.Core.Examples.TwoType.
Require Import UniMath.Bicategories.PseudoFunctors.Examples.ApFunctor.

Local Open Scope cat.

Definition homotsec_natural
           {X Y : UU}
           {f g : X → Y}
           (e : f ~ g)
           {x y : X}
           (p : x = y)
  : e x @ maponpaths g p = maponpaths f p @ e y.
Proof.
  induction p.
  apply pathscomp0rid.
Defined.

Definition homotsec_natural_natural
           {X Y : UU}
           {f g : X → Y}
           (e : f ~ g)
           {x y : X}
           {p q : x = y}
           (h : p = q)
  : maponpaths
      (λ s : g x = g y, e x @ s)
      (maponpaths (maponpaths g) h)
    @ homotsec_natural e q
    =
    homotsec_natural e p
    @ maponpaths (λ s : f x = f y, s @ e y) (maponpaths (maponpaths f) h).
Proof.
  induction h.
  exact (!(pathscomp0rid _)).
Defined.

Section ApTrans.
  Context {X Y : UU}
          (HX : isofhlevel 4 X)
          (HY : isofhlevel 4 Y)
          {f g : X → Y}
          (e : f ~ g).

  Definition ap_pstrans_data
    : pstrans_data
        (ap_psfunctor HX HY f)
        (ap_psfunctor HX HY g).
  Proof.
    use make_pstrans_data.
    - exact e.
    - intros x y p.
      use make_invertible_2cell.
      + exact (homotsec_natural e p).
      + apply fundamental_groupoid_2cell_iso.
  Defined.

  Definition ap_pstrans_laws
    : is_pstrans ap_pstrans_data.
  Proof.
    repeat split.
    - simpl ; intros x y p q h ; cbn.
      exact (homotsec_natural_natural e h).
    - simpl ; intro x ; cbn.
      exact (!(pathscomp0rid _ @ pathscomp0rid _)).
    - simpl ; intros x y z p q ; cbn.
      induction p, q.
      cbn.
      induction (e x).
      apply idpath.
  Qed.

  Definition ap_pstrans
    : pstrans
        (ap_psfunctor HX HY f)
        (ap_psfunctor HX HY g).
  Proof.
    use make_pstrans.
    - exact ap_pstrans_data.
    - exact ap_pstrans_laws.
  Defined.
End ApTrans.


Require Import Coq.Classes.RelationClasses.
Require Import Coq.Classes.Morphisms.
Require Import Coq.Lists.List.
Require Import Coq.Reals.Rdefinitions.
Require Import Coq.Reals.Rtrigo_def.
Require Import Coq.Reals.Ranalysis1.
Require Export Logic.Syntax.
Require Import Logic.Stream.
Require Export ChargeCore.Logics.ILogic.
Require Import Coq.Reals.R_sqrt.
Require Import Coq.Reals.Ratan.

(* The semantics of our restricted Logic *)

(* A behavior, called a trace *)
Definition flow := R -> state.
Definition trace := stream state.

(* Semantics of real valued terms *)
Fixpoint eval_term (t:Term) (s1 s2:state) : R :=
  (match t with
     | VarNowT x => s1 x
     | VarNextT x => s2 x
     | NatT n => Raxioms.INR n
     | RealT r => r
     | PlusT t1 t2 =>
       (eval_term t1 s1 s2) + (eval_term t2 s1 s2)
     | MinusT t1 t2 =>
       (eval_term t1 s1 s2) - (eval_term t2 s1 s2)
     | MultT t1 t2 =>
       (eval_term t1 s1 s2) * (eval_term t2 s1 s2)
     | InvT t =>
       / (eval_term t s1 s2)
     | CosT t => cos (eval_term t s1 s2)
     | SinT t => sin (eval_term t s1 s2)
     | SqrtT t => sqrt (eval_term t s1 s2)
     | ArctanT t => atan (eval_term t s1 s2)
     | ExpT t => exp (eval_term t s1 s2)
     | MaxT t1 t2 =>
       Rbasic_fun.Rmax (eval_term t1 s1 s2)
                       (eval_term t2 s1 s2)
     | Unop f t => f (eval_term t s1 s2)
     | Binop f t1 t2 => f (eval_term t1 s1 s2)
                          (eval_term t2 s1 s2)
   end)%R.

(* Semantics of comparison operators *)
Definition eval_comp (t1 t2:Term) (op:CompOp) (s1 s2:state) :
  Prop :=
  match op with
  | Gt => Rgt
  | Ge => Rge
  | Lt => Rlt
  | Le => Rle
  | Eq => eq
  end (eval_term t1 s1 s2) (eval_term t2 s1 s2).

Definition subst_state (s : RenameMap) : state -> state :=
  fun st x => eval_term (s x) st st.

Definition subst_flow (s : RenameMap) (f : flow) : flow :=
  fun t => subst_state s (f t).

(* Semantics of temporal formulas *)
Fixpoint eval_formula (F:Formula) (tr:trace) :=
  match F with
    | TRUE => True
    | FALSE => False
    | Comp t1 t2 op =>
      eval_comp t1 t2 op (hd tr) (hd (tl tr))
    | And F1 F2 => eval_formula F1 tr /\
                   eval_formula F2 tr
    | Or F1 F2 => eval_formula F1 tr \/
                  eval_formula F2 tr
    | Imp F1 F2 => eval_formula F1 tr ->
                   eval_formula F2 tr
    | PropF P => P
    | Syntax.Exists _ F => exists x, eval_formula (F x) tr
    | Syntax.Forall _ F => forall x, eval_formula (F x) tr
    | Enabled F => exists tr', eval_formula F (Cons (hd tr) tr')
    | Always F => forall n, eval_formula F (nth_suf n tr)
    | Eventually F => exists n, eval_formula F (nth_suf n tr)
    | Embed P =>
      P (hd tr) (hd (tl tr))
    | Rename s F =>
      eval_formula F (stream_map (subst_state s) tr)
  end.

(*
Notation "|- F" := (forall tr, eval_formula F tr)
                     (at level 100) : HP_scope.
*)

(** Formulas are Logics *)
Definition tlaEntails (P Q : Formula) : Prop :=
  forall tr, eval_formula P tr -> eval_formula Q tr.

Global Instance ILogicOps_Formula : ILogicOps Formula :=
{ lentails := tlaEntails
; ltrue    := TRUE
; lfalse   := FALSE
; land     := And
; lor      := Or
; limpl    := Imp
; lforall  := Syntax.Forall
; lexists  := Syntax.Exists
}.

Global Instance ILogic_Formula : ILogic Formula.
Proof.
  constructor;
  try solve [ cbv beta iota zeta delta - [ eval_formula ];
              simpl; intros; intuition eauto ].
  { unfold lentails. simpl. unfold tlaEntails.
    constructor; intuition. }
  { cbv beta iota zeta delta - [ eval_formula ];
    simpl; intros; intuition eauto.
    destruct H0. eauto. }
Qed.

Definition term_equiv (t1 t2:Term) : Prop :=
  forall st1 st2, eval_term t1 st1 st2 =
                  eval_term t2 st1 st2.

Global Instance Reflexive_term_equiv : Reflexive term_equiv.
Proof. repeat red; reflexivity. Qed.

Global Instance Transitive_term_equiv : Transitive term_equiv.
Proof. repeat red; etransitivity. eapply H. eapply H0. Qed.

Global Instance Reflexive_pointwise_refl {T U} (R : U -> U -> Prop) (ReflR : Reflexive R) : Reflexive (pointwise_relation T R).
Proof. repeat red. reflexivity. Qed.


(** * QC: Core QuickChick *)

Require Import Arith Bool List ZArith. Import ListNotations.
From QuickChick Require Import QuickChick. Import QcNotation.

(* Suppress some annoying warnings: *)
Set Warnings "-extraction-opaque-accessed,-extraction".

Require Export ExtLib.Structures.Monads.
Export MonadNotation. Open Scope monad_scope.

Require Import String. Local Open Scope string.

(* ################################################################# *)
(** * Generators *)

(** The heart of property-based random testing is generation of random
    inputs.  *)

(* ================================================================= *)
(** ** The [G] Monad *)

(** In QuickChick, a generator for elements of some type [A] belongs
    to the type [G A].  Intuitively, this type describes functions
    that take a random seed to an element of [A].  We will see below
    that [G] is actually a bit more than this, but this intuition will
    do for now. *)

(** QuickChick provides a number of primitives for building
    generators.  First, [returnGen] takes a constant value and yields
    a generator that always returns this value. *)

Check returnGen.
(**

     ===> returnGen : ?A -> G ?A
*)

(** We can see how it behaves by using the [Sample] command, which
    supplies its generator argument with several different random
    seeds: *)

(* Sample (returnGen 42). *)
(**

     ===> [42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42]
*)

(** Next, given a random generator for [A] and a _function_ [f] taking
    an [A] and yielding a random generator for [B], we can plumb the
    two together into a generator for [B] that works by internally
    generating a random [A] and applying [f] to it. *)

Check bindGen.
(**

     ===> bindGen : G ?A -> (?A -> G ?B) -> G ?B
*)

(*
Definition foo (n : nat) : G nat := returnGen (S n).
Sample (bindGen (returnGen 42) foo).
*)

(** Naturally, the implementation of [bindGen] must take care
    to pass different random seeds to the two sub-generators! *)

(** With these two primitives in hand, we can make [G] an instance of
    the [Monad] typeclass. *)

Section GMonadDef.

Instance GMonad : `{Monad G} | 3 :=
  {
    ret := @returnGen;
    bind := @bindGen
  }.

End GMonadDef.

(* ================================================================= *)
(** ** Primitive generators *)

(** QuickChick provides several primitive generators for "ordered
    types," accessed via the [choose] combinator. *)

Check @choose.
(**

     ===>
     @choose
     : forall A : Type, ChoosableFromInterval A -> A * A -> G A
*)

(** The [ChoosableFromInterval] typeclass describes primitive types
    [A], like natural numbers and integers ([Z]), for which it makes
    sense to randomly generate elements from a given interval. *)

Print ChoosableFromInterval.
(**

     ===>
     Record ChoosableFromInterval (A : Type) : Type :=
       Build_ChoosableFromInterval
       { super : Ord A;
         randomR : A * A -> RandomSeed -> A * RandomSeed;
         ...
       }.
*)

(* Sample (choose (0,10)). *)
(**

     ===> [ 1, 2, 1, 9, 8, 1, 3, 6, 2, 1, 8, 0, 1, 1, 3, 5, 4, 10, 4, 6 ]
*)

(* ================================================================= *)
(** ** Lists *)

(** Since they are a very commonly used compound datatype, lists have
    special combinators in QuickChick: [listOf] and [vectorOf]. *)

(** The [listOf] combinator takes as input a generator for elements of
    type [A] and returns a generator for lists of [A]s. *)

Check listOf.
(**

     ===> listOf : G ?A -> G (list ?A)
*)

(* Sample (listOf (choose (0,4))). *)
(**

     ===>
      [ [ 0, 3, 2, 0 ],
        [ 1, 3, 4, 1, 0, 3, 0, 2, 2, 3, 2, 2, 2, 0, 4, 2, 3, 0, 1 ],
        [ 3, 4, 3, 1, 2, 4, 4, 1, 0, 3, 4, 3, 2, 2, 4, 4, 1 ],
        [ 0 ],
        [ 4, 2, 3 ],
        [ 3, 3, 4, 0, 1, 4, 3, 2, 4, 1 ],
        [ 0, 4 ],
        [  ],
        [ 1, 0, 1, 3, 1 ],
        [ 0, 0 ],
        [ 1, 4 ],
        [ 4, 3, 2, 0, 2, 2, 4, 0 ],
        [ 1, 1, 0, 0, 1, 4 ],
        [ 2, 0, 2, 1, 3, 3 ],
        [ 4, 3, 3, 0, 1 ],
        [ 3, 3, 3 ],
        [ 3, 2, 4 ],
        [ 1, 2 ],
        [  ],
        [  ] ]
*)

(** The second combinator, [vectorOf], receives an additional numeric
    argument [n], the length of the list to be generated. *)

Check vectorOf.
(**

     ===> vectorOf : nat -> G ?A -> G (list ?A)
*)

(* Sample (vectorOf 3 (choose (0,4))). *)
(**

     ===>
      [ [0, 1, 4],
        [1, 1, 0],
        [3, 3, 3],
        [0, 2, 1],
        [1, 3, 2],
        [3, 3, 0],
        [3, 0, 4],
        [2, 3, 3],
        [3, 2, 4],
        [1, 2, 3],
        [2, 0, 4]  ]
*)

(** This raises a question.  It's clear how [vectorOf] decides how big
    to make its lists (we tell it!), but how does [listOf] do it?  The
    answer is hidden inside [G].

    In addition to handling random-seed plumbing, the [G] monad also
    maintains a "current maximum size" (in the style of a "reader
    monad", if you like that terminology): a natural number that
    can be used as an upper bound on the depth of generated objects. *)

(** Internally, [G A] is just a synonym for [nat -> RandomSeed -> A]. *)

Module DefineG.

Inductive G (A:Type) : Type :=
| MkG : (nat -> RandomSeed -> A) -> G A.

End DefineG.

(** When it is searching for counterexamples, QuickChick progressively
    tries larger and larger values for the size bound [n], to
    gradually explore deeper into the search space.

    Each generator can choose to interpret the size bound however it
    wants, and there is no _enforced_ guarantee that generators pay
    any attention to it at all; however, it is good practice to
    respect this bound when programming generators. *)

(* ================================================================= *)
(** ** Custom Generators *)

(** For complicated ADTs, QuickChick provides more combinators.

    We showcase these using everyone's favorite datatype: trees! *)

(** Our trees are standard polymorphic binary trees; either [Leaf]s or
    [Node]s containing some payload of type [A] and two subtrees. *)

Inductive Tree A :=
| Leaf : Tree A
| Node : A -> Tree A -> Tree A -> Tree A.

Arguments Leaf {A}.
Arguments Node {A} _ _ _.

(** Before getting to generators for trees, we again give a
    straightforward [Show] instance.  (The need for a local [let fix]
    declaration stems from the fact that Coq's typeclasses, unlike
    Haskell's, are not automatically recursive.  We could
    alternatively define [aux] with a separate top-level
    [Fixpoint].) *)

Instance showTree {A} `{_ : Show A} : Show (Tree A) :=
  {| show := let fix aux t :=
       match t with
         | Leaf => "Leaf"
         | Node x l r =>
             "Node (" ++ show x ++ ") ("
                      ++ aux l ++ ") ("
                      ++ aux r ++ ")"
       end
     in aux
  |}.

(** This brings us to our first generator _combinator_, called [oneOf_]. *)

Check oneOf_.
(**

     ===> oneOf_ : G ?A -> list (G ?A) -> G ?A
*)

(** This combinator takes a default generator and a list of
    generators, and it picks one of the generators from the list
    uniformly at random (unless the list is empty, in which case it
    picks from the default generator).  As with [elems_], QuickChick
    introduces a more convenient notation [oneOf] to hide this default
    element. *)

(** Next, Coq's termination checker will save us from shooting
    ourselves in the foot!

    The "obvious" first attempt at a generator is the following
    function [genTree], which generates either a [Leaf] or else a
    [Node] whose subtrees are generated recursively (and whose payload
    is produced by a generator [g] for elements of type [A]).*)

(**

     Fixpoint genTree {A} (g : G A) : G (Tree A) :=
        oneOf [ ret Leaf ;;
                liftM3 Node g (genTree g) (genTree g) ].
*)

(** Of course, this fixpoint will not pass Coq's termination
    checker. Attempting to justify this fixpoint informally, one might
    first say that at some point the random generation will pick a
    [Leaf] so it will eventually terminate.  But the termination
    checker cannot understand this kind of probabilistic reasoning.
    Moreover, even informally, the reasoning is wrong: Every time we
    choose to generate a [Node], we create two separate branches that
    must both be terminated with leaves.  It is not hard to show that
    the _expected_ size of the generated trees is actually
    infinite! *)

(** The solution is to use the standard "fuel" idiom that all Coq
    users know.  We add a natural number [sz] as a parameter.  We
    decrease this size in each recursive call, and when it reaches
    [O], we always generate [Leaf].  Thus, the initial [sz] parameter
    serves as a bound on the depth of the tree. *)

Fixpoint genTreeSized {A} (sz : nat) (g : G A) : G (Tree A) :=
  match sz with
    | O => ret Leaf
    | S sz' =>
        oneOf [
          ret Leaf ;
          liftM3 Node g (genTreeSized sz' g) (genTreeSized sz' g)
        ]
  end.

(* Sample (genTreeSized 3 (choose(0,3))). *)
(**

     ===>
       [ Leaf,
         Leaf,
         Node (3) (Node (0) (Leaf) (Leaf))
                  (Node (2) (Leaf) (Node (3) (Leaf) (Leaf))),
         Leaf,
         Leaf,
         Leaf,
         Node (1) (Leaf) (Node (1) (Leaf) (Node (0) (Leaf) (Leaf))),
         Leaf,
         Node (3) (Leaf) (Leaf),
         Node (1) (Leaf) (Leaf),
         Leaf,
         Leaf,
         Node (0) (Leaf) (Node (0) (Leaf) (Node (2) (Leaf) (Leaf))),
         Node (0) (Node (2) (Node (3) (Leaf) (Leaf)) (Leaf)) (Leaf),
         Node (0) (Leaf) (Leaf),
         Leaf,
         Leaf,
         Leaf,
         Leaf,
         Leaf ]
*)

(** While this generator succeeds in avoiding nontermination, we can
    see just by observing the result of [Sample] that there is a
    problem: it produces way too many [Leaf]s!  This is actually not
    surprising, since half the time we generate a [Leaf] right at the
    outset.  *)

(** We can obtain bigger trees more often if we skew the distribution
    towards [Node]s using a more expressive QuickChick combinator,
    [freq_]. *)

Check freq_.
(**

     ===> freq_ : G ?A -> seq (nat * G ?A) -> G ?A
*)

(** As with [oneOf], we usually use a convenient derived notation,
    called [freq], that takes a list of generators, each tagged with a
    natural number that serves as the weight of that generator.  For
    example, in the following generator, a [Leaf] will be generated 1
    / (sz + 1) of the time and a [Node] the remaining sz / (sz + 1) of
    the time. *)

Fixpoint genTreeSized' {A} (sz : nat) (g : G A) : G (Tree A) :=
  match sz with
    | O => ret Leaf
    | S sz' =>
        freq [ (1,  ret Leaf) ;
               (sz, liftM3 Node g (genTreeSized' sz' g)
                                  (genTreeSized' sz' g))
             ]
  end.

(* Sample (genTreeSized' 3 (choose(0,3))). *)
(**

     ===>
         [ Node (3) (Node (1) (Node (3) (Leaf) (Leaf)) (Leaf))
                    (Node (0) (Leaf) (Node (3) (Leaf) (Leaf))),
           Leaf,
           Node (2) (Node (1) (Leaf) (Leaf)) (Leaf),
           Node (0) (Leaf) (Node (0) (Node (2) (Leaf) (Leaf))
                                     (Node (0) (Leaf) (Leaf))),
           Node (1) (Node (2) (Leaf) (Node (0) (Leaf) (Leaf))) (Leaf),
           Node (0) (Node (0) (Leaf) (Node (3) (Leaf) (Leaf)))
                    (Node (2) (Leaf) (Leaf)),
           Node (1) (Node (3) (Node (2) (Leaf) (Leaf)) (Node (3) (Leaf) (Leaf)))
                    (Node (1) (Leaf) (Node (2) (Leaf) (Leaf))),
           Node (0) (Node (0) (Node (0) (Leaf) (Leaf)) (Node (1) (Leaf) (Leaf)))
                    (Node (2) (Node (3) (Leaf) (Leaf)) (Node (0) (Leaf) (Leaf))),
           Node (2) (Node (2) (Leaf) (Leaf)) (Node (1) (Node (2) (Leaf) (Leaf))
                                                       (Node (2) (Leaf) (Leaf))),
           Node (2) (Node (3) (Node (2) (Leaf) (Leaf)) (Leaf))
                    (Node (0) (Node (2) (Leaf) (Leaf)) (Leaf)),
           Leaf,
           Node (2) (Node (3) (Node (3) (Leaf) (Leaf)) (Leaf)) (Leaf),
           Leaf,
           Node (1) (Leaf) (Leaf),
           Leaf,
           Node (1) (Node (2) (Leaf) (Node (3) (Leaf) (Leaf)))
                    (Node (0) (Leaf) (Node (1) (Leaf) (Leaf))),
           Leaf,
           Node (3) (Node (0) (Node (0) (Leaf) (Leaf)) (Leaf))
                    (Node (0) (Leaf) (Node (2) (Leaf) (Leaf))),
           Node (2) (Node (2) (Node (0) (Leaf) (Leaf)) (Leaf))
                    (Node (1) (Leaf) (Node (2) (Leaf) (Leaf))),
           Leaf ]
*)

(** This looks better. *)

(* ================================================================= *)
(** ** Checkers *)

(** Now we want to use our generator to create a lot of random trees
    and, for each one, check whether some predicate returns [true] or
    [false].

    Another way to say this is that we want to use a predicate to build
    a _generator for test results_.

    Let's see how this works. *)

(** (Let's open a playground module so we can show simplified
    versions of the actual QuickChick definitions.) *)

Module CheckerPlayground1.

(** First, we need a type of test results -- let's call it [Result].
    For the moment, think of [Result] as just an enumerated type with
    constructors [Success] and [Failure].  *)

Inductive Result := Success | Failure.

Instance showResult : Show Result :=
  {
    show r := match r with Success => "Success" | Failure => "Failure" end
  }.

(** Then we can define the type [Checker] to be [G Result]. *)

Definition Checker := G Result.

(** That is, a [Checker] embodies some way of performing a randomized
    test of the truth of some proposition, which, when applied to a
    random seed, will yield either [Success] (meaning that the
    proposition survived this test) or [Failure] (meaning that this
    test demonstrates that the proposition was false).

    Sampling a [Checker] many times with different seeds will cause
    many different tests to be performed. *)

(** To check a tree predicate, we'll need a way to build a [Checker]
    out of a function from trees to booleans.

    Actually, we will be wanting to build [Checker]s based on many
    different types.  So let's begin by defining a typeclass
    [Checkable], where an instance for [Checkable A] will provide a
    way of converting an [A] into a [Checker]. *)

Class Checkable A :=
  {
    checker : A -> Checker
  }.

(** It is easy to give a [bool] instance for [Checkable]. *)

Instance checkableBool : Checkable bool :=
  {
    checker b := if b then ret Success else ret Failure
  }.

(** That is, the boolean value [true] passes every test we might
    subject it to (i.e., the result of [checker] is a [G] that returns
    [true] for every seed), while [false] fails all tests. *)

(** Let's see what happens if we sample checkers for our favorite
    booleans, [true] and [false].  *)

(** (We need to exit the playground so that we can do [Sample]:
    because [Sample] is implemented internally via extraction to
    OCaml, which usually does not work from inside a [Module].) *)

End CheckerPlayground1.

(* Sample (CheckerPlayground1.checker true). *)
(**

     ===>
      [Success, Success, Success, Success, Success, Success, Success,
       Success, Success, Success, Success]
*)

(* Sample (CheckerPlayground1.checker false). *)
(**

     ===>
      [Failure, Failure, Failure, Failure, Failure, Failure, Failure,
       Failure, Failure, Failure, Failure]
*)

(** What we've done so far may look a a bit strange, since these
    checkers always generate the same results.  We'll make things more
    interesting in a bit, but first let's pause to define one more
    basic instance of [Checkable]. *)

(** A decidable [Prop] is not too different from a boolean, so we
    should be able to build a checker from that too. *)

Module CheckerPlayground2.
Export CheckerPlayground1.

Instance checkableDec `{P : Prop} `{Dec P} : Checkable P :=
  {
    checker p := if P? then ret Success else ret Failure
  }.

(** (The definition looks a bit strange since it doesn't use its
    argument [p].  The intuition is that all the information in [p] is
    already encoded in [P]!) *)

(** Now suppose we pose a couple of (decidable) conjectures: *)

Conjecture c1 : 0 = 42.
Conjecture c2 : 41 + 1 = 42.

End CheckerPlayground2.

(** The somewhat astononishing thing about the [Checkable] instance
    for decidable [Prop]s is that, even though these are
    _conjectures_ (we haven't proved them, so the "evidence" that Coq
    has for them internally is just an uninstantiated "evar"), we can
    still build checkers from them and sample from these
    checkers! (Why?  Technically, it is because the [Checkable]
    instance for decidable properties does not look at its
    argument.) *)

(*  Sample (CheckerPlayground1.checker CheckerPlayground2.c1). *)
(**

     ===>
      [Failure, Failure, Failure, Failure, Failure, Failure, Failure,
       Failure, Failure, Failure, Failure]
*)

(* Sample (CheckerPlayground1.checker CheckerPlayground2.c2). *)
(**

     ===>
      [Success, Success, Success, Success, Success, Success, Success,
       Success, Success, Success, Success]
*)

(** Again, the intuition is that, although we didn't present
    proofs (and could not have, in the first case!), Coq already
    "knows" either a proof or a disproof of each of these conjectures
    because they are decidable. *)

(** To showcase how such generators can be used to find
    counterexamples, suppose we define a function for "mirroring" a
    tree -- swapping its left and right subtrees recursively. *)

Fixpoint mirror {A : Type} (t : Tree A) : Tree A :=
  match t with
    | Leaf => Leaf
    | Node x l r => Node x (mirror r) (mirror l)
  end.

(** To formulate a property about [mirror], we need a structural
    equality test on trees.  We can obtain that with minimal effort
    using the [Dec] typeclass and the [dec_eq] tactic. *)

Instance eq_dec_tree (t1 t2 : Tree nat) : Dec (t1 = t2) := {}.
Proof. dec_eq. Defined.

(** We expect that mirroring a tree twice should yield the original
    tree.  *)

Definition mirrorP (t : Tree nat) := (mirror (mirror t)) = t?.

(** We have seen that the result of [mirrorP] is [Checkable].  What we
    need is a way to take a function returning a checkable thing and
    make the function itself checkable.

    We can easily do this, as long as the argument type of the
    function is something we know how to generate! *)
Module CheckerPlayground3.
Import CheckerPlayground2.

Definition forAll {A B : Type} `{Checkable B}
             (g : G A) (f : A -> B)
           : Checker :=
  a <- g ;;
  checker (f a).

End CheckerPlayground3.

(** Now, what about [mirrorP]? *)

(*
Sample (CheckerPlayground3.forAll
          (genTreeSized' 3 (choose(0,3)))
          mirrorP).
*)
(**

     ===>
      [Success, Success, Success, Success, Success, Success, Success,
       Success, Success, Success, Success]
*)

(** Excellent: It looks like many tests are succeeding -- maybe the
    property is true. *)

(** Let's instead try defining a bad property and see if we can detect
    that it's bad... *)

Definition faultyMirrorP (t : Tree nat) := (mirror t) = t ?.

(*
Sample (CheckerPlayground3.forAll
          (genTreeSized' 3 (choose(0,3)))
          faultyMirrorP).
*)
(**

     ===>
      [Failure, Success, Failure, Success, Success, Success, Failure,
       Success, Failure, Failure, Success]
*)

(** Great -- looks like a good number of tests are failing now, as
    expected. *)

(** There's only one little issue: What _are_ the tests that are
    failing?  We can tell by looking at the samples that the property
    is bad, but we can't see the counterexamples!

    We can fix this by going back to the beginning and enriching the
    [Result] type to keep track of failing counterexamples. *)

Module CheckerPlayground4.

Inductive Result :=
  | Success : Result
  | Failure : forall {A} `{Show A}, A -> Result.

Instance showResult : Show Result :=
  {
    show r := match r with
              | Success => "Success"
              | Failure A showA a => "Failure: " ++ show a
              end
  }.

Definition Checker := G Result.

Class Checkable A :=
  {
    checker : A -> Checker
  }.

Instance showUnit : Show unit :=
  {
    show u := "tt"
  }.

(** The failure cases in the [bool] and [Dec] checkers don't need to
    record anything except the [Failure], so we put [tt] (the sole
    value of type [unit]) as the "failure reason." *)

Instance checkableBool : Checkable bool :=
  {
    checker b := if b then ret Success else ret (Failure tt)
  }.

Instance checkableDec `{P : Prop} `{Dec P} : Checkable P :=
  {
    checker p := if P? then ret Success else ret (Failure tt)
  }.

(** The interesting case is the [forAll] combinator.  Here, we _do_
    have some useful information to record in the failure case --
    namely, the argument that caused the failure. *)

Definition forAll {A B : Type} `{Show A} `{Checkable B}
                  (g : G A) (f : A -> B)
                : Checker :=
  a <- g ;;
  r <- checker (f a) ;;
  match r with
    Success => ret Success
  | Failure B showB b => ret (Failure (a,b))
  end.

(** Note that, rather than just returning [Failure a], we package up
    [a] together with [b], which explains the reason for the failure
    of [f a].  This allows us to write several [forAll]s in sequence
    and capture all of their results in a nested tuple. *)

End CheckerPlayground4.

(*
Sample (CheckerPlayground4.forAll
          (genTreeSized' 3 (choose(0,3)))
          faultyMirrorP).
*)
(**

     ===>
      [Failure: (Node (2) (Node (3) (Node (2) (Leaf) (Leaf)) (Leaf))
                          (Node (0) (Node (2) (Leaf) (Leaf)) (Leaf)), tt),
      Success,
      Failure: (Node (2) (Node (3) (Node (3) (Leaf) (Leaf)) (Leaf)) (Leaf), tt),
      Success, Success, Success,
      Failure: (Node (1) (Node (2) (Leaf) (Node (3) (Leaf) (Leaf)))
                         (Node (0) (Leaf) (Node (1) (Leaf) (Leaf))), tt),
      Success,
      Failure: (Node (3) (Node (0) (Node (0) (Leaf) (Leaf)) (Leaf))
                         (Node (0) (Leaf) (Node (2) (Leaf) (Leaf))), tt),
      Failure: (Node (2) (Node (2) (Node (0) (Leaf) (Leaf)) (Leaf))
                         (Node (1) (Leaf) (Node (2) (Leaf) (Leaf))), tt),
      Success]
*)

(** The bug is found several times and actual counterexamples are
    reported: nice! *)

(** Sampling repeatedly from a generator is just what the [QuickChick]
    command does, except that, instead of running a fixed number of
    tests and returning their results in a list, it runs tests only
    until the first counterexample is found. *)

(*
QuickChick
  (forAll
     (genTreeSized' 3 (choose(0,3)))
     faultyMirrorP).
*)
(**

     ===>
     QuickChecking (forAll (genTreeSized' 3 (choose (0, 3))) faultyMirrorP)

     Node (0) (Node (0) (Node (2) (Leaf) (Leaf))
                        (Node (1) (Leaf) (Leaf)))
              (Node (1) (Node (0) (Leaf) (Leaf)) (Leaf))

     *** Failed after 1 tests and 0 shrinks. (0 discards)
*)

(** However, these counterexamples themselves still leave something to
    be desired: they are all _much_ larger than is really needed to
    illustrate the bad behavior of [faultyMirrorP].

    This is where _shrinking_ comes in. *)

(* ################################################################# *)
(** * Shrinking *)

Derive Shrink for Tree.

(* ################################################################# *)
(** * Automation *)

(** Writing [Show] and [Arbitrary] instances is usually not hard, but
    it can get tedious when we are testing code that involves many new
    [Inductive] type declarations.  To streamline this process,
    [QuickChick] provides some automation for deriving such instances
    for "plain datatypes" automatically! *)

Derive Arbitrary for Tree.
(**

     ===> GenSizedree is defined
     ===> ShrinkTree is defined
*)
Print GenSizedTree.
Print ShrinkTree.

Derive Show for Tree.
(**
     ===> ShowTree is defined
*)
Print ShowTree.

(* ################################################################# *)
(** * Collecting Statistics *)

(** Earlier in this tutorial we observed that our first definition of
    [genTreeSized] seemed to be producing too many [Leaf]
    constructors.

    In that case, just eyeballing at a few results from [Sample] gave
    us an idea that something was wrong with the distribution of test
    cases, but it's often useful to collect more extensive statistics
    from larger sets of samples.

    This is where [collect], another property combinator, comes in. *)

Check @collect.
(**

     ===>
     @collect
       : forall A prop : Type, Show A -> Checkable prop ->
           A -> prop -> Checker
*)

(** That is, [collect] takes a checkable proposition and returns a new
    [Checker] (for the same proposition).

    On the side, it takes a value from some [Show]able type [A], which
    it remembers internally (in an enriched variant of the [Result]
    structure that we saw above) so that it can be collated and
    displayed at the end. *)

(** For example, suppose we measure the [size] of [Tree]s like this: *)

Fixpoint size {A} (t : Tree A) : nat :=
  match t with
    | Leaf => O
    | Node _ l r => 1 + size l + size r
  end.

(** We can write a dummy property [treeProp] to collect the sizes of
    the trees we are generating. *)

Definition treeProp (g : nat -> G nat -> G (Tree nat)) n :=
  forAll (g n (choose (0,n))) (fun t => collect (size t) true).

(* QuickChick (treeProp genTreeSized 5). *)
(**

     ===>
       4947 : 0
       1258 : 1
       673 : 2
       464 : 6
       427 : 5
       393 : 3
       361 : 7
       302 : 4
       296 : 8
       220 : 9
       181 : 10
       127 : 11
       104 : 12
       83 : 13
       64 : 14
       32 : 15
       25 : 16
       16 : 17
       13 : 18
       6 : 19
       5 : 20
       2 : 21
       1 : 23

       +++ OK, passed 10000 tests
*)

(** We see that 62.5%% of the tests (4947 + 1258 / 10000) are either
    [Leaf]s or empty [Node]s, while rather few tests have larger
    sizes.  *)

(** Compare this with [genTreeSized'].  *)

(* QuickChick (treeProp genTreeSized' 5). *)
(**

     ===>
       1624 : 0
       571 : 10
       564 : 12
       562 : 11
       559 : 9
       545 : 8
       539 : 14
       534 : 13
       487 : 7
       487 : 15
       437 : 16
       413 : 6
       390 : 17
       337 : 5
       334 : 1
       332 : 18
       286 : 19
       185 : 4
       179 : 20
       179 : 2
       138 : 21
       132 : 3
       87 : 22
       62 : 23
       19 : 24
       10 : 25
       6 : 26
       2 : 27

       +++ OK, passed 10000 tests
*)

(** This generates far fewer tiny examples, likely leading to more
    efficient testing of interesting properties. *)

(* ################################################################# *)
(** * Dealing with Preconditions *)

(** A large class of properties that are commonly encountered in
    property-based testing are _properties with preconditions_.  The
    default QuickChick approach of generating inputs based on type
    information can be inefficient for such properties, especially for
    those with sparse preconditions (i.e. ones that are satisfied
    rarely with respect to their input domain). *)

Open Scope bool.

(** Consider a function that inserts a natural number into a sorted list. *)

Fixpoint sorted (l : list nat) :=
  match l with
  | [] => true
  | x::xs => match xs with
             | [] => true
             | y :: ys => (x <=? y) && (sorted xs)
             end
  end.

Fixpoint insert (x : nat) (l : list nat) :=
  match l with
  | [] => [x]
  | y::ys => if x <=? y then x :: l
             else y :: insert x ys
  end.

(** We could test [insert] using the following _conditional_ property: *)

Definition insert_spec (x : nat) (l : list nat) :=
  sorted l ==> sorted (insert x l).

(* QuickChick insert_spec. *)
(**

     ===>
       QuickChecking insert_spec
       +++ Passed 10000 tests (17319 discards)
*)

(** To test this property, QuickChick will try to generate random
    integers [x] and lists [l], _check_ whether the generated [l] is
    sorted, and, if it is, proceed to check the conclusion. If it is
    not, it will discard the generated inputs and try again.

    As we can see, this can lead to many discarded tests (in this
    case, about twice as many as successful ones), which wastes a
    lot of CPU and leads to inefficient testing. *)

(** But the wasted effort is the least of our problems! Let's take a
    peek at the distribution of the lengths of generated lists using
    [collect]. *)

Definition insert_spec' (x : nat) (l : list nat) :=
  collect (List.length l) (insert_spec x l).

QuickChick insert_spec'. *)
(**

     ===>
   QuickChecking insert_spec'
   3550 : 1
   3454 : (Discarded) 6
   3448 : (Discarded) 5
   3438 : 0
   3416 : (Discarded) 7
   3157 : (Discarded) 4
   2778 : (Discarded) 3
   1838 : 2
   1535 : (Discarded) 2
   772 : 3
   275 : 4
   103 : 5
   17 : 6
   7 : 7
*)
(** The vast majority of inputs have length 2 or less!

    (This explains something you might have found suspicious in the
    previous statistics: that 1/3 of the randomly generated lists were
    already sorted!) *)

(** When dealing with properties with preconditions, it is common
    practice to write custom generators for well-distributed random
    data that satisfy the property. *)

(** For example, we can generate sorted lists with elements between
    [low] and [high] like this... *)

Fixpoint genSortedList (low high : nat) (size : nat)
             : G (list nat) :=
  match size with
  | O =>
    ret []
  | S size' =>
    if high <? low then
      ret []
    else
      freq [ (1, ret []) ;
             (size, x <- choose (low, high);;
                    xs <- genSortedList x high size';;
                    ret (x :: xs)) ] end.

(** We use a [size] parameter as usual to control the length of generated
    lists. *)

(** If [size] is zero, we can only return the empty list which
    is always sorted. If [size] is nonzero, we need to perform an
    additional check whether [high] is less than [low] (in which case
    we also return the empty list).  If it is not, we can proceed to
    choose to generate a cons cell, with its head generated between
    [low] and [high] and its tail generated recursively. *)

(* Sample (genSortedList 0 10 10). *)

(** Finally, we can use [forAllShrink] to define a property using the
    new generator: *)

Definition insert_spec_sorted (x : nat) :=
  forAllShrink
    (genSortedList 0 10 10)
    shrink
    (fun l => insert_spec' x l).

(** Now the distribution of lengths looks much better, and we don't
    discard any tests! *)

QuickChick insert_spec_sorted.
(**

     ===>
       QuickChecking insert_spec_sorted
       947 : 0
       946 : 4
       946 : 10
       938 : 6
       922 : 9
       916 : 2
       900 : 7
       899 : 3
       885 : 8
       854 : 5
       847 : 1
       +++ Passed 10000 tests (0 discards)
*)
(** Does this mean we are happy? *)

(** **** Exercise: 5 stars, optional (uniform_sorted)  *)
(** Using "collect", find out whether generating a sorted list of
    numbers between 0 and 5 is uniform in the frequencies with which
    different _numbers_ are found in the generated lists.

    If not, figure out why.  Then write a different generator that
    achieves a more uniform distribution (preserving uniformity in the
    lengths). *)

(* FILL IN HERE *)
(** [] *)

(* ================================================================= *)
(** ** Another Precondition: Binary Search Trees *)

(** To conclude this chapter, let's look at _binary search trees_.

    The [isBST] predicate characterizes trees with elements between
    [low] and [high]. *)

Fixpoint isBST (low high: nat) (t : Tree nat) :=
  match t with
  | Leaf => true
  | Node x l r => (low <? x) && (x <? high)
                  && (isBST low x l) && (isBST x high r)
  end.

(** Here is a (faulty?) insertion function for binary search trees. *)

Fixpoint insertBST (x : nat) (t : Tree nat) :=
  match t with
  | Leaf => Node x Leaf Leaf
  | Node x' l r => if x <? x' then Node x' (insertBST x l) r
                   else Node x' l (insertBST x r)
  end.

(** We would expect that if we insert an element that is within
    the bounds [low] and [high] into a binary search tree, then
    the result is also a binary search tree. *)

Definition insertBST_spec (low high : nat) (x : nat) (t : Tree nat) :=
  (low <? x) ==>
  (x <? high) ==>
  (isBST low high t) ==>
  isBST low high (insertBST x t).

(* QuickChick insertBST_spec. *)
(**

    ===>
      QuickChecking insertBST_spec
      0
      5
      4
      Node (4) (Leaf) (Leaf)
      *** Failed after 85 tests and 1 shrinks. (1274 discards)
*)

(** We can see that a bug exists when inserting an element into a
    [Node] with the same payload: if the element already exists in the
    binary search tree, we should not change it. *)

(** However we are wasting too much testing effort.  Indeed, if we fix the
    bug ... *)

Fixpoint insertBST' (x : nat) (t : Tree nat) :=
  match t with
  | Leaf => Node x Leaf Leaf
  | Node x' l r => if x <? x' then Node x' (insertBST' x l) r
                   else if x' <? x then Node x' l (insertBST' x r)
                   else t
  end.

Definition insertBST_spec' (low high : nat) (x : nat) (t : Tree nat) :=
  (low <? x) ==> (x <? high) ==> (isBST low high t) ==>
  isBST low high (insertBST' x t).

(** ... and try again... *)

(* QuickChick insertBST_spec'. *)
(**

     ===>
     QuickChecking insertBST_spec'
     *** Gave up! Passed only 1281 tests
     Discarded: 20000
*)
(** ... we see that 90%% of tests are being discarded. *)

(** **** Exercise: 4 stars (gen_bst)  *)
(** Write a generator that produces binary search trees directly, so
    that you run 10000 tests with 0 discards. *)

(* FILL IN HERE *)
(** [] *)


Require Import input9.
Require Import NArith.BinNat.
Require Import NArith.BinNatDef.

Fixpoint make_pairs_with n l : list (N*N) :=
  match l with
  | nil => nil
  | x :: xs => (x, n) :: make_pairs_with n xs
  end.

Fixpoint make_pairs l : list (N*N) :=
  match l with
  | nil => nil
  | x :: xs => make_pairs_with x xs ++ make_pairs xs
  end.

Fixpoint contains {X:Type} (f:X -> bool) (l:list X) : bool :=
  match l with
  | nil => false
  | x :: xs => if f x then true else contains f xs
  end.

Definition contains_by_pair (f:(N*N) -> bool) (l:list N) : bool :=
  contains f (make_pairs l).

Definition pair_sum p : N :=
  N.add (fst p) (snd p).

Definition contains_pair_sum (n:N) (l:list N) : bool :=
  contains (fun p => N.eqb (pair_sum p) n)  (make_pairs l).

Fixpoint take {X:Type} (n:nat) (l:list X) : list X :=
  match l, n with
  | nil, _ => nil
  | x :: xs, O => nil
  | x :: xs, S n' => x :: take n' xs
  end.

Fixpoint slice {X:Type} (n m:nat) (l:list X) : list X :=
  match l, n, m with
  | nil, _, _ => nil
  | l', O, m => take (m + 1) l'
  | x :: xs, S n', m => slice n' m xs
  end.

Fixpoint rev {X:Type} (l:list X) : list X :=
  match l with
  | nil => nil
  | x :: xs => rev xs ++ [x]
  end.

Fixpoint filter_by_next_n {X:Type}
  (f:X -> list X -> bool) (n:nat) (l: list X) : list X :=
  match l with
  | nil => nil
  | x :: xs => if f x (slice 0 (n - 1) xs)
       then x :: filter_by_next_n f n xs
       else filter_by_next_n f n xs
  end.

Definition filter_by_prev_n {X:Type} f n l : list X :=
  rev (filter_by_next_n f n (rev l)).

Definition head {X:Type} l : option X :=
  match l with
  | nil => None
  | x :: xs => Some x
  end.

Example filter_pair_sum:
  filter_by_prev_n contains_pair_sum 2 [1%N;2%N;3%N;4%N;7%N] = [3%N;7%N].
Proof. reflexivity. Qed.

Fixpoint filter_by_next_n_first_m {X:Type}
  (f:X -> list X -> bool) (n m:nat) (l: list X) : list X :=
  match l, m with
  | nil, _ => nil
  | x :: xs, O => nil
  | x :: xs, S m' => if f x (slice 0 (n - 1) xs)
       then x :: filter_by_next_n_first_m  f n m' xs
       else filter_by_next_n_first_m f n m' xs
  end.

Definition tautologi_1 {X:Type} (x:X) (l:list X) : bool :=
  true.
Lemma tautologi_1_true: forall (X:Type) (x:X) (l:list X),
  tautologi_1 x l = true.
Proof. intros. reflexivity. Qed.

Lemma filter_by_next_n_first_m_nil:
  forall (X:Type) (l:list X) (n m:nat),
  l = [] -> filter_by_next_n_first_m tautologi_1 n m l = [].
Proof.
  intros. rewrite H. destruct m.
  - reflexivity.
  - reflexivity.
Qed.

Lemma filter_by_next_n_first_m_with_tautologi_head:
  forall (X:Type) (x:X) (xs: list X) (n m:nat),
  filter_by_next_n_first_m tautologi_1 n (S m) (x::xs) =
  x :: filter_by_next_n_first_m tautologi_1 n m xs.
Proof.
  intros. reflexivity.
Qed.

Lemma filter_by_next_n_first_m_with_tautologi_is_take:
  forall (X:Type) (l: list X) (n m:nat),
  filter_by_next_n_first_m tautologi_1 n m l = take m l.
Proof.
  intros X l. induction l.
  - intros. destruct m.
    + reflexivity.
    + reflexivity.
  - intros. destruct m.
    + simpl. reflexivity.
    + rewrite filter_by_next_n_first_m_with_tautologi_head.
      rewrite IHl. simpl. reflexivity.
Qed.

Definition filter_by_next_n_skip_m {X:Type}
  (f:X -> list X -> bool) (n m:nat) (l: list X) : list X :=
  filter_by_next_n_first_m f n (length l - m) l.

Definition filter_by_prev_n_skip_m {X:Type} f n m l : list X :=
  rev (filter_by_next_n_skip_m f n m (rev l)).

Example foo:
  filter_by_prev_n_skip_m contains_pair_sum 2 3 [1%N;2%N;3%N;4%N;7%N] = [7%N].
Proof. reflexivity. Qed.

Definition part1 (slice_length:nat) input : option N :=
  head (
    filter_by_prev_n_skip_m
    (fun x l => negb (contains_pair_sum x l))
    slice_length slice_length input
  ).

Example test_part1: part1 5 test_input = Some 127%N.
Proof. reflexivity. Qed.

Fixpoint sum (l: list N) : N :=
  match l with
  | nil => 0%N
  | x :: xs => N.add x (sum xs)
  end.

Fixpoint sublists_by_helper {X:Type} (f:list X -> bool) (h l:list X)
  : list (list X) :=
  match l with
  | nil => nil
  | x :: xs => if f (x :: h)
      then (x :: h) :: sublists_by_helper f (x :: h) xs
      else sublists_by_helper f (x :: h) xs
  end.

Fixpoint sublists_by {X:Type} (f:list X -> bool) (l:list X) : list (list X) :=
  match l with
  | nil => nil
  | x :: xs => sublists_by_helper f [x] xs ++ sublists_by f xs
  end.

Fixpoint _helper_max_elem (n:option N) (l:list N) : option N :=
  match l, n with
  | nil, _ => n
  | x :: xs, None => _helper_max_elem (Some x) xs
  | x :: xs, Some y => if N.ltb x y
        then _helper_max_elem (Some y) xs
        else _helper_max_elem (Some x) xs
  end.

Fixpoint max_elem (l:list N) : option N :=
  _helper_max_elem None l.

Fixpoint _helper_min_elem (n:option N) (l:list N) : option N :=
  match l, n with
  | nil, _ => n
  | x :: xs, None => _helper_min_elem (Some x) xs
  | x :: xs, Some y => if N.ltb x y
        then _helper_min_elem (Some x) xs
        else _helper_min_elem (Some y) xs
  end.

Fixpoint min_elem (l:list N) : option N :=
  _helper_min_elem None l.

Definition add_min_max (l:list N) :=
  match max_elem l, min_elem l with
  | None, _ => None
  | _, None => None
  | Some max, Some min => Some (N.add max min)
  end.

Definition map {X Y:Type} (f:X -> Y) (opt:option X) : option Y :=
  match opt with
  | None => None
  | Some x => Some (f x)
  end.

Definition flat_map {X Y:Type} (f:X -> option Y) (opt:option X) : option Y :=
  match opt with
  | None => None
  | Some x => f x
  end.

Definition compose {X Y Z:Type} (g: Y -> Z) (h: X -> Y) :=
  fun x => g (h x).

Notation "g · f" := (compose g f) (at level 70, only parsing).

Definition part2 (n:nat) (input:list N) :=
  (flat_map add_min_max ·
    (flat_map head ·
      map (fun x => sublists_by (fun l => N.eqb (sum l) x) input)
    )
  ) (part1 n input).

Compute part1 25 input.
Compute part2 25 input.


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)

(* $Id: Setoid_ring_theory.v 14641 2011-11-06 11:59:10Z herbelin $ *)

Require Export Bool.
Require Export Setoid.

Set Implicit Arguments.

Section Setoid_rings.

Variable A : Type.
Variable Aequiv : A -> A -> Prop.

Infix Local "==" := Aequiv (at level 70, no associativity).

Variable S : Setoid_Theory A Aequiv.

Add Setoid A Aequiv S as Asetoid.

Variable Aplus : A -> A -> A.
Variable Amult : A -> A -> A.
Variable Aone : A.
Variable Azero : A.
Variable Aopp : A -> A.
Variable Aeq : A -> A -> bool.

Infix "+" := Aplus (at level 50, left associativity).
Infix "*" := Amult (at level 40, left associativity).
Notation "0" := Azero.
Notation "1" := Aone.
Notation "- x" := (Aopp x).

Variable plus_morph :
 forall a a0:A, a == a0 -> forall a1 a2:A, a1 == a2 -> a + a1 == a0 + a2.
Variable mult_morph :
  forall a a0:A, a == a0 -> forall a1 a2:A, a1 == a2 -> a * a1 == a0 * a2.
Variable opp_morph : forall a a0:A, a == a0 -> - a == - a0.

Add Morphism Aplus : Aplus_ext.
intros; apply plus_morph; assumption.
Qed.

Add Morphism Amult : Amult_ext.
intros; apply mult_morph; assumption.
Qed.

Add Morphism Aopp : Aopp_ext.
exact opp_morph.
Qed.

Section Theory_of_semi_setoid_rings.

Record Semi_Setoid_Ring_Theory : Prop :=
  {SSR_plus_comm : forall n m:A, n + m == m + n;
   SSR_plus_assoc : forall n m p:A, n + (m + p) == n + m + p;
   SSR_mult_comm : forall n m:A, n * m == m * n;
   SSR_mult_assoc : forall n m p:A, n * (m * p) == n * m * p;
   SSR_plus_zero_left : forall n:A, 0 + n == n;
   SSR_mult_one_left : forall n:A, 1 * n == n;
   SSR_mult_zero_left : forall n:A, 0 * n == 0;
   SSR_distr_left : forall n m p:A, (n + m) * p == n * p + m * p;
   SSR_plus_reg_left : forall n m p:A, n + m == n + p -> m == p;
   SSR_eq_prop : forall x y:A, Is_true (Aeq x y) -> x == y}.

Variable T : Semi_Setoid_Ring_Theory.

Let plus_comm := SSR_plus_comm T.
Let plus_assoc := SSR_plus_assoc T.
Let mult_comm := SSR_mult_comm T.
Let mult_assoc := SSR_mult_assoc T.
Let plus_zero_left := SSR_plus_zero_left T.
Let mult_one_left := SSR_mult_one_left T.
Let mult_zero_left := SSR_mult_zero_left T.
Let distr_left := SSR_distr_left T.
Let plus_reg_left := SSR_plus_reg_left T.
Let equiv_refl := Seq_refl A Aequiv S.
Let equiv_sym := Seq_sym A Aequiv S.
Let equiv_trans := Seq_trans A Aequiv S.

Hint Resolve plus_comm plus_assoc mult_comm mult_assoc plus_zero_left
  mult_one_left mult_zero_left distr_left plus_reg_left
  equiv_refl (*equiv_sym*).
Hint Immediate equiv_sym.

(* Lemmas whose form is x=y are also provided in form y=x because
  Auto does not symmetry *)
Lemma SSR_mult_assoc2 : forall n m p:A, n * m * p == n * (m * p).
auto. Qed.

Lemma SSR_plus_assoc2 : forall n m p:A, n + m + p == n + (m + p).
auto. Qed.

Lemma SSR_plus_zero_left2 : forall n:A, n == 0 + n.
auto. Qed.

Lemma SSR_mult_one_left2 : forall n:A, n == 1 * n.
auto. Qed.

Lemma SSR_mult_zero_left2 : forall n:A, 0 == 0 * n.
auto. Qed.

Lemma SSR_distr_left2 : forall n m p:A, n * p + m * p == (n + m) * p.
auto. Qed.

Lemma SSR_plus_permute : forall n m p:A, n + (m + p) == m + (n + p).
intros.
rewrite (plus_assoc n m p).
rewrite (plus_comm n m).
rewrite <- (plus_assoc m n p).
trivial.
Qed.

Lemma SSR_mult_permute : forall n m p:A, n * (m * p) == m * (n * p).
intros.
rewrite (mult_assoc n m p).
rewrite (mult_comm n m).
rewrite <- (mult_assoc m n p).
trivial.
Qed.

Hint Resolve SSR_plus_permute SSR_mult_permute.

Lemma SSR_distr_right : forall n m p:A, n * (m + p) == n * m + n * p.
intros.
rewrite (mult_comm n (m + p)).
rewrite (mult_comm n m).
rewrite (mult_comm n p).
auto.
Qed.

Lemma SSR_distr_right2 : forall n m p:A, n * m + n * p == n * (m + p).
intros.
apply equiv_sym.
apply SSR_distr_right.
Qed.

Lemma SSR_mult_zero_right : forall n:A, n * 0 == 0.
intro; rewrite (mult_comm n 0); auto.
Qed.

Lemma SSR_mult_zero_right2 : forall n:A, 0 == n * 0.
intro; rewrite (mult_comm n 0); auto.
Qed.

Lemma SSR_plus_zero_right : forall n:A, n + 0 == n.
intro; rewrite (plus_comm n 0); auto.
Qed.

Lemma SSR_plus_zero_right2 : forall n:A, n == n + 0.
intro; rewrite (plus_comm n 0); auto.
Qed.

Lemma SSR_mult_one_right : forall n:A, n * 1 == n.
intro; rewrite (mult_comm n 1); auto.
Qed.

Lemma SSR_mult_one_right2 : forall n:A, n == n * 1.
intro; rewrite (mult_comm n 1); auto.
Qed.

Lemma SSR_plus_reg_right : forall n m p:A, m + n == p + n -> m == p.
intros n m p; rewrite (plus_comm m n); rewrite (plus_comm p n).
intro; apply plus_reg_left with n; trivial.
Qed.

End Theory_of_semi_setoid_rings.

Section Theory_of_setoid_rings.

Record Setoid_Ring_Theory : Prop :=
  {STh_plus_comm : forall n m:A, n + m == m + n;
   STh_plus_assoc : forall n m p:A, n + (m + p) == n + m + p;
   STh_mult_comm : forall n m:A, n * m == m * n;
   STh_mult_assoc : forall n m p:A, n * (m * p) == n * m * p;
   STh_plus_zero_left : forall n:A, 0 + n == n;
   STh_mult_one_left : forall n:A, 1 * n == n;
   STh_opp_def : forall n:A, n + - n == 0;
   STh_distr_left : forall n m p:A, (n + m) * p == n * p + m * p;
   STh_eq_prop : forall x y:A, Is_true (Aeq x y) -> x == y}.

Variable T : Setoid_Ring_Theory.

Let plus_comm := STh_plus_comm T.
Let plus_assoc := STh_plus_assoc T.
Let mult_comm := STh_mult_comm T.
Let mult_assoc := STh_mult_assoc T.
Let plus_zero_left := STh_plus_zero_left T.
Let mult_one_left := STh_mult_one_left T.
Let opp_def := STh_opp_def T.
Let distr_left := STh_distr_left T.
Let equiv_refl := Seq_refl A Aequiv S.
Let equiv_sym := Seq_sym A Aequiv S.
Let equiv_trans := Seq_trans A Aequiv S.

Hint Resolve plus_comm plus_assoc mult_comm mult_assoc plus_zero_left
  mult_one_left opp_def distr_left equiv_refl equiv_sym.

(* Lemmas whose form is x=y are also provided in form y=x because Auto does
  not symmetry *)

Lemma STh_mult_assoc2 : forall n m p:A, n * m * p == n * (m * p).
auto. Qed.

Lemma STh_plus_assoc2 : forall n m p:A, n + m + p == n + (m + p).
auto. Qed.

Lemma STh_plus_zero_left2 : forall n:A, n == 0 + n.
auto. Qed.

Lemma STh_mult_one_left2 : forall n:A, n == 1 * n.
auto. Qed.

Lemma STh_distr_left2 : forall n m p:A, n * p + m * p == (n + m) * p.
auto. Qed.

Lemma STh_opp_def2 : forall n:A, 0 == n + - n.
auto. Qed.

Lemma STh_plus_permute : forall n m p:A, n + (m + p) == m + (n + p).
intros.
rewrite (plus_assoc n m p).
rewrite (plus_comm n m).
rewrite <- (plus_assoc m n p).
trivial.
Qed.

Lemma STh_mult_permute : forall n m p:A, n * (m * p) == m * (n * p).
intros.
rewrite (mult_assoc n m p).
rewrite (mult_comm n m).
rewrite <- (mult_assoc m n p).
trivial.
Qed.

Hint Resolve STh_plus_permute STh_mult_permute.

Lemma Saux1 : forall a:A, a + a == a -> a == 0.
intros.
rewrite <- (plus_zero_left a).
rewrite (plus_comm 0 a).
setoid_replace (a + 0) with (a + (a + - a)) by auto.
rewrite (plus_assoc a a (- a)).
rewrite H.
apply opp_def.
Qed.

Lemma STh_mult_zero_left : forall n:A, 0 * n == 0.
intros.
apply Saux1.
rewrite <- (distr_left 0 0 n).
rewrite (plus_zero_left 0).
trivial.
Qed.
Hint Resolve STh_mult_zero_left.

Lemma STh_mult_zero_left2 : forall n:A, 0 == 0 * n.
auto.
Qed.

Lemma Saux2 : forall x y z:A, x + y == 0 -> x + z == 0 -> y == z.
intros.
rewrite <- (plus_zero_left y).
rewrite <- H0.
rewrite <- (plus_assoc x z y).
rewrite (plus_comm z y).
rewrite (plus_assoc x y z).
rewrite H.
auto.
Qed.

Lemma STh_opp_mult_left : forall x y:A, - (x * y) == - x * y.
intros.
apply Saux2 with (x * y); auto.
rewrite <- (distr_left x (- x) y).
rewrite (opp_def x).
auto.
Qed.
Hint Resolve STh_opp_mult_left.

Lemma STh_opp_mult_left2 : forall x y:A, - x * y == - (x * y).
auto.
Qed.

Lemma STh_mult_zero_right : forall n:A, n * 0 == 0.
intro; rewrite (mult_comm n 0); auto.
Qed.

Lemma STh_mult_zero_right2 : forall n:A, 0 == n * 0.
intro; rewrite (mult_comm n 0); auto.
Qed.

Lemma STh_plus_zero_right : forall n:A, n + 0 == n.
intro; rewrite (plus_comm n 0); auto.
Qed.

Lemma STh_plus_zero_right2 : forall n:A, n == n + 0.
intro; rewrite (plus_comm n 0); auto.
Qed.

Lemma STh_mult_one_right : forall n:A, n * 1 == n.
intro; rewrite (mult_comm n 1); auto.
Qed.

Lemma STh_mult_one_right2 : forall n:A, n == n * 1.
intro; rewrite (mult_comm n 1); auto.
Qed.

Lemma STh_opp_mult_right : forall x y:A, - (x * y) == x * - y.
intros.
rewrite (mult_comm x y).
rewrite (mult_comm x (- y)).
auto.
Qed.

Lemma STh_opp_mult_right2 : forall x y:A, x * - y == - (x * y).
intros.
rewrite (mult_comm x y).
rewrite (mult_comm x (- y)).
auto.
Qed.

Lemma STh_plus_opp_opp : forall x y:A, - x + - y == - (x + y).
intros.
apply Saux2 with (x + y); auto.
rewrite (STh_plus_permute (x + y) (- x) (- y)).
rewrite <- (plus_assoc x y (- y)).
rewrite (opp_def y); rewrite (STh_plus_zero_right x).
rewrite (STh_opp_def2 x); trivial.
Qed.

Lemma STh_plus_permute_opp : forall n m p:A, - m + (n + p) == n + (- m + p).
auto.
Qed.

Lemma STh_opp_opp : forall n:A, - - n == n.
intro.
apply Saux2 with (- n); auto.
rewrite (plus_comm (- n) n); auto.
Qed.
Hint Resolve STh_opp_opp.

Lemma STh_opp_opp2 : forall n:A, n == - - n.
auto.
Qed.

Lemma STh_mult_opp_opp : forall x y:A, - x * - y == x * y.
intros.
rewrite (STh_opp_mult_left2 x (- y)).
rewrite (STh_opp_mult_right2 x y).
trivial.
Qed.

Lemma STh_mult_opp_opp2 : forall x y:A, x * y == - x * - y.
intros.
apply equiv_sym.
apply STh_mult_opp_opp.
Qed.

Lemma STh_opp_zero : - 0 == 0.
rewrite <- (plus_zero_left (- 0)).
trivial.
Qed.

Lemma STh_plus_reg_left : forall n m p:A, n + m == n + p -> m == p.
intros.
rewrite <- (plus_zero_left m).
rewrite <- (plus_zero_left p).
rewrite <- (opp_def n).
rewrite (plus_comm n (- n)).
rewrite <- (plus_assoc (- n) n m).
rewrite <- (plus_assoc (- n) n p).
auto.
Qed.

Lemma STh_plus_reg_right : forall n m p:A, m + n == p + n -> m == p.
intros.
apply STh_plus_reg_left with n.
rewrite (plus_comm n m); rewrite (plus_comm n p); assumption.
Qed.

Lemma STh_distr_right : forall n m p:A, n * (m + p) == n * m + n * p.
intros.
rewrite (mult_comm n (m + p)).
rewrite (mult_comm n m).
rewrite (mult_comm n p).
trivial.
Qed.

Lemma STh_distr_right2 : forall n m p:A, n * m + n * p == n * (m + p).
intros.
apply equiv_sym.
apply STh_distr_right.
Qed.

End Theory_of_setoid_rings.

Hint Resolve STh_mult_zero_left STh_plus_reg_left: core.

Unset Implicit Arguments.

Definition Semi_Setoid_Ring_Theory_of :
  Setoid_Ring_Theory -> Semi_Setoid_Ring_Theory.
intros until 1; case H.
split; intros; simpl in |- *; eauto.
Defined.

Coercion Semi_Setoid_Ring_Theory_of : Setoid_Ring_Theory >->
 Semi_Setoid_Ring_Theory.

Section product_ring.

End product_ring.

Section power_ring.

End power_ring.

End Setoid_rings.