(**********************************************************************

 Enriched slice categories

 In this file, we define enriched slice categories. The approach that
 we take, is based on the fact that slice categories can be defined
 using dialgebras. As such, we can reuse the fact that we already
 showed that the category of dialgebras has an enrichment, and we can
 specialize that to obtain an enrichment for slice categories.

 Let's be more specific. Suppose that we have a category `C` and an
 object `x` in `C`. To construct the slice category `C/x` we take the
 category of dialgebras between the identity and the functor that is
 constantly `x`. As such, the objects of this category are pairs of an
 object `a` in `C` together with a morphism `a --> x`. As such, this
 corresponds to objects in the slice category `C/x`. The same can be
 said for morphisms.

 Note that we assume that the monoidal category `V` has equalizers and
 that the unit is terminal. The reason for that, is because of how
 morphisms in the slice category are defined. If we have two objects
 `f : a --> x` and `g : b --> x` in the slice `C/x`, then a morphism
 from `f` to `g` consists of a morphism `h : a --> b` such that we have
 `f = g · h`. Equalizers are used to o encode the commutativity
 requirement. If one were to define it concretely, one would take the
 equalizer of the following diagram
 ```
               h ↦ h · g
             ------------>
    a --> b                a --> x
             ----> 𝟙 ---->
                      f
 ```
 Instead of this concrete definition, we reuse that we already defined
 the enriched category of dialgebras.

 Contents
 1. Enrichment for slice categories
 2. An equivalence between dialgebras and the slice

 **********************************************************************)
Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Core.Univalence.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.
Require Import UniMath.CategoryTheory.categories.Dialgebras.
Require Import UniMath.CategoryTheory.slicecat.
Require Import UniMath.CategoryTheory.Adjunctions.Core.
Require Import UniMath.CategoryTheory.Equivalences.Core.
Require Import UniMath.CategoryTheory.EnrichedCats.Enrichment.
Require Import UniMath.CategoryTheory.EnrichedCats.EnrichmentFunctor.
Require Import UniMath.CategoryTheory.EnrichedCats.EnrichmentTransformation.
Require Import UniMath.CategoryTheory.EnrichedCats.Examples.DialgebraEnriched.
Require Import UniMath.CategoryTheory.Monoidal.Categories.
Require Import UniMath.CategoryTheory.limits.equalizers.
Require Import UniMath.CategoryTheory.limits.terminal.

Import MonoidalNotations.

Local Open Scope cat.
Local Open Scope moncat.

Section EnrichedSlice.
  Context (V : monoidal_cat)
          (HV𝟙 : isTerminal V (I_{V}))
          (HV : Equalizers V)
          {C : category}
          (E : enrichment C V)
          (x : C).

  (**
   1. Enrichment for slice categories
   *)
  Definition slice_cat_enrichment
    : enrichment
        (dialgebra (functor_identity C) (constant_functor C C x))
        V
    := dialgebra_enrichment
         V HV
         (functor_id_enrichment E)
         (functor_constant_enrichment HV𝟙 x E E).

  (**
   2. An equivalence between dialgebras and the slice
   *)
  Definition dialgebra_to_slice_data
    : functor_data
        (dialgebra (functor_identity C) (constant_functor C C x))
        (slice_cat C x).
  Proof.
    use make_functor_data.
    - exact (λ x, x).
    - refine (λ x y f, pr1 f ,, _) ; cbn.
      abstract
        (exact (!(id_right _) @ pr2 f)).
  Defined.

  Definition dialgebra_to_slice_is_functor
    : is_functor dialgebra_to_slice_data.
  Proof.
    repeat split.
    - intro ; intros.
      use subtypePath ; [ intro ; apply homset_property | ] ; cbn.
      apply idpath.
    - intro ; intros.
      use subtypePath ; [ intro ; apply homset_property | ] ; cbn.
      apply idpath.
  Qed.

  Definition dialgebra_to_slice
    : dialgebra (functor_identity C) (constant_functor C C x) ⟶ slice_cat C x.
  Proof.
    use make_functor.
    - exact dialgebra_to_slice_data.
    - exact dialgebra_to_slice_is_functor.
  Defined.

  Definition slice_to_dialgebra_data
    : functor_data
        (slice_cat C x)
        (dialgebra (functor_identity C) (constant_functor C C x)).
  Proof.
    use make_functor_data.
    - exact (λ x, x).
    - refine (λ x y f, pr1 f ,, _) ; cbn.
      abstract
        (exact (id_right _ @ pr2 f)).
  Defined.

  Definition slice_to_dialgebra_is_functor
    : is_functor slice_to_dialgebra_data.
  Proof.
    repeat split.
    - intro ; intros.
      use subtypePath ; [ intro ; apply homset_property | ] ; cbn.
      apply idpath.
    - intro ; intros.
      use subtypePath ; [ intro ; apply homset_property | ] ; cbn.
      apply idpath.
  Qed.

  Definition slice_to_dialgebra
    : slice_cat C x ⟶ dialgebra (functor_identity C) (constant_functor C C x).
  Proof.
    use make_functor.
    - exact slice_to_dialgebra_data.
    - exact slice_to_dialgebra_is_functor.
  Defined.

  Definition dialgebra_to_slice_unit
    : functor_identity _ ⟹ dialgebra_to_slice ∙ slice_to_dialgebra.
  Proof.
    use make_nat_trans.
    - refine (λ f, identity _ ,, _).
      abstract
        (cbn ;
         exact (id_right _ @ !(id_left _))).
    - abstract
        (intros f₁ f₂ τ ;
         use subtypePath ; [ intro ; apply homset_property | ] ; cbn ;
         exact (id_right _ @ !(id_left _))).
  Defined.

  Definition dialgebra_to_slice_counit
    : slice_to_dialgebra ∙ dialgebra_to_slice ⟹ functor_identity _.
  Proof.
    use make_nat_trans.
    - refine (λ f, identity _ ,, _).
      abstract
        (cbn ;
         exact (!(id_left _))).
    - abstract
        (intros f₁ f₂ τ ;
         use subtypePath ; [ intro ; apply homset_property | ] ; cbn ;
         exact (id_right _ @ !(id_left _))).
  Defined.

  Definition dialgebra_to_slice_adj_equiv
    : adj_equivalence_of_cats dialgebra_to_slice.
  Proof.
    simple refine ((_ ,, ((_ ,, _) ,, _ ,, _)) ,, _ ,, _).
    - exact slice_to_dialgebra.
    - exact dialgebra_to_slice_unit.
    - exact dialgebra_to_slice_counit.
    - abstract
        (intros f ;
         use subtypePath ; [ intro ; apply homset_property | ] ; cbn ;
         apply id_left).
    - abstract
        (intros f ;
         use subtypePath ; [ intro ; apply homset_property | ] ; cbn ;
         apply id_left).
    - intro f.
      use is_z_iso_dialgebra.
      cbn.
      apply is_z_isomorphism_identity.
    - intro f.
      use z_iso_to_slice_precat_z_iso.
      cbn.
      apply is_z_isomorphism_identity.
  Defined.
End EnrichedSlice.


Coq < Section Club.

Coq < Require Import Classical.

Coq < Variables A B C D E : Prop.
A is assumed
B is assumed
C is assumed
D is assumed
E is assumed

Coq < Hypothesis rule1 : ~A -> B.
rule1 is assumed

Coq < Hypothesis rule2 : C \/ ~B.
rule2 is assumed

Coq < Hypothesis rule3 : D -> ~E.
rule3 is assumed

Coq < Hypothesis rule4 : E <-> A.
rule4 is assumed

Coq < Hypothesis rule5 : C -> A /\ D.
rule5 is assumed

Coq < Hypothesis rule6 : A -> C.
rule6 is assumed

Coq < Lemma NoMember : False.
1 subgoal

  A : Prop
  B : Prop
  C : Prop
  D : Prop
  E : Prop
  rule1 : ~ A -> B
  rule2 : C \/ ~ B
  rule3 : D -> ~ E
  rule4 : E <-> A
  rule5 : C -> A /\ D
  rule6 : A -> C
  ============================
   False

NoMember < tauto.
No more subgoals.

NoMember < Qed.
tauto.

NoMember is defined


Require Coq.Bool.Bool.

Module BoolNotation.
  Infix "||" := orb.
  Infix "&&" := andb.
End BoolNotation.
Import BoolNotation.

Definition consider_bool (b:bool) : {b=true}+{b=false}.
Proof. destruct (Bool.bool_dec b true) as [H | H] ; eauto.
  apply Bool.not_true_is_false in H ; eauto.
Qed.

Definition orf {A} (f:A -> bool) (g:A -> bool) (a:A) : bool := f a || g a.
Definition andf {A} (f:A -> bool) (g:A -> bool) (a:A) : bool := f a && g a.

Lemma bool_conj_true : forall b1 b2, (b1 && b2) = true <-> b1 = true /\ b2 = true.
Proof.
  intros ; constructor ; intros.
  - destruct b1,b2 ; auto.
  - destruct b1,b2 ; auto.
    destruct H as [H1 H2] ; discriminate H2.
    destruct H as [H1 H2] ; discriminate H1.
    destruct H as [H1 H2] ; discriminate H1.
Qed.


(* week_35.v *)
(* dIFP 2014-2015, Q1 *)
(* Olivier Danvy <danvy@cs.au.dk> *)

(* **********

   (0) download and install on your computer:
       - Coq
       - Emacs with Proof General (tick "3 Windows mode layout" in the Coq top menu;
         use the hybrid mode if your screen is not wide enough)

   (1) edit the present file, and step through it with Coq,
       proving the lemmas as you go

   ********** *)

Check O.

Check 0.

Check 1.

Check S O.

Check S 1.

Check S (S (S O)).

Check (fun x => S x).

Check S.

Check (fun x => S (S x)).

Check (fun f => fun x => S (f (S x))).

Check (fun f x => S (f (S x))).

Check 1 + 2.

Compute 1 + 2.

Check
  (fun (P : Prop) (p : P) => p).

Check
  (fun (P Q : Prop) (p : P) (q : Q) => p).

Check
  (fun (P Q : Prop) (p : P) (q : Q) => q).

(* ********** *)

(* Propositional logic:

   P ::= X
       | P -> P
       | P /\ P
       | P \/ P

   X ::= A | B | C | D | E | ...

   forall A B C ... : Prop, p
*)

(*
   intro and apply
*)

Lemma La :
  forall P : Prop,
    P -> P.
Proof.
  intro P.
  intro H_P.
  apply H_P.
Qed.

(*
   intros
*)

Lemma La' :
  forall P : Prop,
    P -> P.
Proof.
  intros P H_P.
  apply H_P.
Qed.

Lemma Lb :
  forall P Q : Prop,
    P -> Q -> P.
Proof.
  intro P.
  intro Q.
  intro H_P.
  intro H_Q.
  apply H_P.
Qed.

Lemma Lb' :
  forall P Q : Prop,
    P -> Q -> P.
Proof.
  intros P Q.
  intros H_P H_Q.
  apply H_P.
Qed.

Lemma Lb'' :
  forall P Q : Prop,
    P -> Q -> P.
Proof.
  intros P Q H_P H_Q.
  apply H_P.
Qed.

Lemma Lc :
  forall P Q : Prop,
    P -> Q -> Q.
Proof.
  intros P Q H_P H_Q.
  apply H_Q.
  Qed.

Lemma Ld :
  forall P1 P2 P3 P4 P5 : Prop,
    P1 -> P2 -> P3 -> P4 -> P5 -> P3.
Proof.
  intros P1 P2 P3 P4 P5.
  intros H_P1 H_P2 H_P3 H_P4 H_P5.
  apply H_P3.
  Qed.

(* ********** *)

(* conjunction in an assumption: use destruct *)

Lemma Ca :
  forall P1 P2 : Prop,
    P1 /\ P2 -> P2.
Proof.
  intros P1 P2.
  intros H_P1_and_P2.
  destruct H_P1_and_P2 as [H_P1 H_P2].
  apply H_P2.
Qed.

Lemma Ca' :
  forall P1 P2 : Prop,
    P1 /\ P2 -> P2.
Proof.
  intros P1 P2.
  intros [H_P1 H_P2].
  apply H_P2.
Qed.

Lemma Ca'' :
  forall P1 P2 : Prop,
    P1 /\ P2 -> P1.
Proof.
  intros P1 P2 [H_P1 H_P2].
  apply H_P1.
  Qed.

Lemma Cb :
  forall P1 P2 P3 : Prop,
    P1 /\ (P2 /\ P3) -> P3.
Proof.
  intros P1 P2 P3.
  intros [H_P1 [H_P2 H_P3]].
  apply H_P3.
Qed.

Lemma Cb' :
  forall P1 P2 P3 : Prop,
    P1 /\ P2 /\ P3 -> P3.
Proof.
  intros P1 P2 P3.
  intros [H_P1 [H_P2 H_P3]].
  apply H_P3.
Qed.

Lemma Cc :
  forall P1 P2 P3 P4 : Prop,
    (P1 /\ P2) /\ (P3 /\ P4) -> P3.
Proof.
  intros P1 P2 P3 P4.
  intros [[H_P1 H_P2] [H_P3 H_P4]].
  apply H_P3.
  Qed.

(* ********** *)

(* conjunction in the goal: use split *)

Lemma conjunction_is_commutative :
  forall P Q : Prop,
    P /\ Q -> Q /\ P.
Proof.
  intros P Q.
  intros [H_P H_Q].
  split.
    apply H_Q.
    apply H_P.
Qed.

Lemma conjunction_is_commutative' :
  forall P Q : Prop,
    P /\ Q -> Q /\ P.
Proof.
  intros P Q [H_P H_Q].
  split.
    apply H_Q.
    apply H_P.
Qed.

(*
   Notation: "X <-> Y" is the same as "(X -> Y) /\ (Y -> X)"
*)

Lemma conjunction_is_commutative_either_way :
  forall P Q : Prop,
    P /\ Q <-> Q /\ P.
Proof.
  intros P Q.
  split.
    intros [H_P H_Q].
    split.
    apply H_Q.
    apply H_P.

    intros [H_Q H_P].
    split.
    apply H_P.
    apply H_Q.
Qed.

(* Simpler: apply conjunction_is_commutative instead of repeating its proof *)

Lemma conjunction_is_commutative_either_way' :
  forall P Q : Prop,
    P /\ Q <-> Q /\ P.
Proof.
  intros P Q.
  split.
  apply (conjunction_is_commutative P Q).
  apply (conjunction_is_commutative Q P).
Qed.

Lemma conjunction_is_associative_from_left_to_right :
  forall P1 P2 P3 : Prop,
    (P1 /\ P2) /\ P3 -> P1 /\ (P2 /\ P3).
Proof.
  intros P1 P2 P3.
  intros [[H_P1 H_P2] H_P3].
  split.
    apply H_P1.
    split.
      apply H_P2.
      apply H_P3.
Qed.

Lemma conjunction_is_associative_from_right_to_left :
  forall P1 P2 P3 : Prop,
    P1 /\ (P2 /\ P3) -> (P1 /\ P2) /\ P3.
Proof.
  intros P1 P2 P3.
  intros [H_P1 [H_P2 H_P3]].
  split. split.
  apply H_P1. apply H_P2. apply H_P3.
  Qed.
(* Exercise: replace "Admitted." by a proof, if there is one. *)

Lemma conjunction_is_associative_either_way :
  forall P1 P2 P3 : Prop,
    P1 /\ (P2 /\ P3) <-> (P1 /\ P2) /\ P3.
Proof.
  intros P1 P2 P3.
  split.
  apply (conjunction_is_associative_from_right_to_left).
  apply (conjunction_is_associative_from_left_to_right).
  Qed.
(* Exercise: replace "Admitted." by a proof, if there is one. *)

Lemma conjunction_is_associative_4_from_left_to_right :
  forall P1 P2 P3 P4 : Prop,
    P1 /\ (P2 /\ (P3 /\ P4)) -> ((P1 /\ P2) /\ P3) /\ P4.
Proof.
  intros P1 P2 P3 P4.
  intros [H_P1 [H_P2 [H_P3 H_P4]]].
  split. split. split.
  apply H_P1. apply H_P2. apply H_P3. apply H_P4.
  Qed.
(* Exercise: replace "Admitted." by a proof, if there is one. *)

Lemma conjunction_is_associative_4_from_right_to_left :
  forall P1 P2 P3 P4 : Prop,
    ((P1 /\ P2) /\ P3) /\ P4 -> P1 /\ (P2 /\ (P3 /\ P4)).
Proof.
  intros P1 P2 P3 P4.
  intros [[[H_P1 H_P2] H_P3] H_P4].
  split. apply H_P1.
  split. apply H_P2.
  split. apply H_P3.
  apply H_P4.
  Qed.

(* Exercise: replace "Admitted." by a proof, if there is one. *)

Lemma conjunction_is_associative_4_either_way :
  forall P1 P2 P3 P4 : Prop,
    P1 /\ (P2 /\ (P3 /\ P4)) <-> ((P1 /\ P2) /\ P3) /\ P4.
Proof.
  intros P1 P2 P3 P4.
  split.
  apply (conjunction_is_associative_4_from_left_to_right).
  apply (conjunction_is_associative_4_from_right_to_left).
  Qed.
(* Exercise: replace "Admitted." by a proof, if there is one. *)

(* ********** *)

(* disjunction in the goal: use left or right *)

Lemma whatever_1 :
  forall P Q : Prop,
    P -> Q -> P \/ Q.
Proof.
  intros P Q.
  intros H_P H_Q.
  left.
  apply H_P.
Qed.

Lemma whatever_1' :
  forall P Q : Prop,
    P -> Q -> P \/ Q.
Proof.
  intros P Q.
  intros H_P H_Q.
  right.
  apply H_Q.
Qed.

(* ********** *)

(* disjunction in an assumption: use destruct *)

Lemma disjunction_is_commutative :
  forall P Q : Prop,
    P \/ Q -> Q \/ P.
Proof.
  intros P Q.
  intro H_P_or_Q.
  destruct H_P_or_Q as [H_P | H_Q].
  right.
  apply H_P.
  left.
  apply H_Q.
Qed.

Lemma disjunction_is_commutative' :
  forall P Q : Prop,
    P \/ Q -> Q \/ P.
Proof.
  intros P Q.
  intros [H_P| H_Q].
  right.
  apply H_P.
  left.
  apply H_Q.
Qed.

Lemma disjunction_is_commutative'' :
  forall P Q : Prop,
    P \/ Q -> Q \/ P.
Proof.
  intros P Q [H_P | H_Q].
  right.
  apply H_P.
  left.
  apply H_Q.
Qed.

Lemma disjunction_is_commutative_either_way :
  forall P Q : Prop,
    P \/ Q <-> Q \/ P.
Proof.
  intros P Q.
  split.
  apply (disjunction_is_commutative).
  apply (disjunction_is_commutative).
  Qed.

(* Exercise: replace "Admitted." by a proof, if there is one. *)

Lemma disjunction_is_associative_from_left_to_right :
  forall P1 P2 P3 : Prop,
    (P1 \/ P2) \/ P3 -> P1 \/ (P2 \/ P3).
Proof.
  intros P1 P2 P3 [[H_P1 | H_P2] | H_P3].
  left. apply H_P1.
  right. left. apply H_P2.
  right. right. apply H_P3.
Qed.

Lemma disjunction_is_associative_from_right_to_left :
  forall P1 P2 P3 : Prop,
    P1 \/ (P2 \/ P3) -> (P1 \/ P2) \/ P3.
Proof.
  intros P1 P2 P3 [H_P1 | [H_P2 | H_P3]].
  left. left. apply H_P1.
  left. right. apply H_P2.
  right. apply H_P3.
  Qed.

(* Exercise: replace "Admitted." by a proof, if there is one. *)

Lemma disjunction_is_associative_either_way :
  forall P1 P2 P3 : Prop,
    P1 \/ (P2 \/ P3) <-> (P1 \/ P2) \/ P3.
Proof.
  intros P1 P2 P3.
  split.
  apply (disjunction_is_associative_from_right_to_left).
  apply (disjunction_is_associative_from_left_to_right).
  Qed.
(* Exercise: replace "Admitted." by a proof, if there is one. *)

Lemma disjunction_is_associative_4_from_left_to_right :
  forall P1 P2 P3 P4 : Prop,
    P1 \/ (P2 \/ (P3 \/ P4)) -> ((P1 \/ P2) \/ P3) \/ P4.
Proof.
  intros P1 P2 P3 P4.
  intros H.
  apply (disjunction_is_associative_from_right_to_left).
  apply (disjunction_is_associative_from_right_to_left).
  apply H.
  Qed.

(* Exercise: replace "Admitted." by a proof, if there is one. *)

Lemma disjunction_is_associative_4_from_right_to_left :
  forall P1 P2 P3 P4 : Prop,
    ((P1 \/ P2) \/ P3) \/ P4 -> P1 \/ (P2 \/ (P3 \/ P4)).
Proof.
  intros P1 P2 P3 P4 H.
  apply (disjunction_is_associative_from_left_to_right).
  apply (disjunction_is_associative_from_left_to_right).
  apply H.
  Qed.
(* Exercise: replace "Admitted." by a proof, if there is one. *)

Lemma disjunction_is_associative_4_either_way :
  forall P1 P2 P3 P4 : Prop,
    P1 \/ (P2 \/ (P3 \/ P4)) <-> ((P1 \/ P2) \/ P3) \/ P4.
Proof.
  intros P1 P2 P3 P4.
  split.
  apply (disjunction_is_associative_4_from_left_to_right).
  apply (disjunction_is_associative_4_from_right_to_left).
  Qed.
(* Exercise: replace "Admitted." by a proof, if there is one. *)

(* ********** *)

Lemma transitivity_of_implication :
  forall A B C : Prop,
    (A -> B) -> (B -> C) -> (A -> C).
Proof.
  intros A B C.
  intro H_A_implies_B.
  intro H_B_implies_C.
  intro H_A.
  apply H_B_implies_C.
  apply H_A_implies_B.
  apply H_A.
Qed.

Lemma transitivity_of_implication' :
  forall A B C : Prop,
    (B -> C) -> (A -> B) -> (A -> C).
Proof.
  intros A B C.
  intro H_B_imp_C.
  intro H_A_imp_B.
  intro H_A.
  apply H_B_imp_C.
  apply H_A_imp_B.
  apply H_A.
  Qed.
(* Exercise: replace "Admitted." by a proof, if there is one. *)

Lemma Le :
  forall A B C: Prop,
    (A \/ B -> C) -> (A -> C) \/ (B -> C).
Proof.
  intros A B C.
  intro H_A_or_B_implies_C.
  left.
  intro H_A.
  apply H_A_or_B_implies_C.
  left.
  apply H_A.

  Restart.

  intros A B C.
  intro H_A_or_B_implies_C.
  right.
  intro H_B.
  apply H_A_or_B_implies_C.
  right.
  apply H_B.
Qed.
(* Exercise: replace "Admitted." by a proof, if there is one. *)

Lemma Le' :
  forall A B C: Prop,
    (A -> C) \/ (B -> C) -> (A \/ B -> C).
Proof.
(*  intros A B C.
  intros [H_A_imp_C | H_B_imp_C].
  intros H_A_or_B.
  apply H_A_imp_C.
  destruct H_A_or_B as [H_A | H_B].
  apply H_A.
  Abort. *)
  Admitted.
(* Exercise: replace "Admitted." by a proof, if there is one. *)

Lemma Lf :
  forall A B C: Prop,
    (A \/ B -> C) -> (A -> C) /\ (B -> C).
Proof.
  (* intros A B C.
  intros H_A_or_B_imp_C. *)
  Admitted.
(* Exercise: replace "Admitted." by a proof, if there is one. *)

Lemma Lf' :
  forall A B C: Prop,
    (A -> C) /\ (B -> C) -> (A \/ B -> C).
Proof.
  intros A B C.
  intros [H_A_imp_C H_B_imp_C].
  intros [H_A | H_B].
  apply H_A_imp_C. apply H_A.
  apply H_B_imp_C. apply H_B.
  Qed.
(* Exercise: replace "Admitted." by a proof, if there is one. *)

Lemma Lg :
  forall A B C: Prop,
    (A /\ B -> C) -> (A -> C) \/ (B -> C).
Proof.
  (*intros A B C.
  intros H_A_or_B_imp_C.
  left.
  intros H_A.
  apply H_A_or_B_imp_C.*) Admitted.
(* Exercise: replace "Admitted." by a proof, if there is one. *)

Lemma Lg' :
  forall A B C: Prop,
    (A -> C) \/ (B -> C) -> (A /\ B -> C).
Proof.
  intros A B C.
  intros [H_A_imp_C | H_B_imp_C].
  intros [H_A H_B].
  apply H_A_imp_C.
  apply H_A.
  intros [H_A H_B].
  apply H_B_imp_C.
  apply H_B.
  Qed.
(* Exercise: replace "Admitted." by a proof, if there is one. *)

Lemma Lh :
  forall A B C: Prop,
    (A /\ B -> C) -> (A -> C) /\ (B -> C).
Proof.
  (* intros A B C.
  intros H_A_and_B_imp_C.
  intros *)Admitted.
(* Exercise: replace "Admitted." by a proof, if there is one. *)

Lemma Lh' :
  forall A B C: Prop,
    (A -> C) /\ (B -> C) -> (A /\ B -> C).
Proof.
  intros A B C.
  intros [H_A_imp_C H_B_imp_C].
  intros [H_A H_B].
  apply H_A_imp_C. apply H_A. Qed.
(* Exercise: replace "Admitted." by a proof, if there is one. *)

(* ********** *)

Lemma distributivity_of_disjunction_over_conjunction:
  forall A B C : Prop,
    A \/ (B /\ C) <-> (A \/ B) /\ (A \/ C).
Proof.
Admitted.
(* Exercise: replace "Admitted." by a proof, if there is one. *)

Lemma distributivity_of_conjunction_over_disjunction:
  forall A B C : Prop,
    A /\ (B \/ C) <-> (A /\ B) \/ (A /\ C).
Proof.
Admitted.
(* Exercise: replace "Admitted." by a proof, if there is one. *)

(* ********** *)

Lemma Curry :
  forall P Q R : Prop,
    (P /\ Q -> R) -> (P -> Q -> R).
Proof.
Admitted.
(* Exercise: replace "Admitted." by a proof, if there is one. *)

Lemma unCurry :
  forall P Q R : Prop,
    (P -> Q -> R) -> (P /\ Q -> R).
Proof.
Admitted.
(* Exercise: replace "Admitted." by a proof, if there is one. *)

Lemma Curry_and_unCurry :
  forall P Q R : Prop,
    (P /\ Q -> R) <-> P -> Q -> R.
Proof.
Admitted.
(* Exercise: replace "Admitted." by a proof, if there is one. *)

(* ********** *)

(* Here is how to import a Coq library about arithmetic expressions: *)

Require Import Arith.

Check plus_comm.

(*
plus_comm
     : forall n m : nat, n + m = m + n
*)

Lemma comm_a :
  forall a b c : nat,
    (a + b) + c = c + (b + a).
Proof.
Admitted.
(* Exercise: replace "Admitted." by a proof, if there is one. *)

Lemma comm_b :
  forall x y z : nat,
    (x + y) + z = z + (y + x).
Proof.
Admitted.
(* Exercise: replace "Admitted." by a proof, if there is one. *)

(* symmetry *)

Lemma comm_c :
  forall a b c : nat,
    c + (b + a) = (a + b) + c.
Proof.
Admitted.
(* Exercise: replace "Admitted." by a proof, if there is one. *)

(* ********** *)

Check plus_assoc.

(*
plus_assoc
     : forall n m p : nat, n + (m + p) = n + m + p
*)

Lemma assoc_a :
  forall a b c d : nat,
    ((a + b) + c) + d = a + (b + (c + d)).
Proof.
Admitted.
(* Exercise: replace "Admitted." by a proof, if there is one. *)

(* ********** *)

Lemma mixed_a :
forall a b c d : nat,
    (c + (a + b)) + d = (b + (d + c)) + a.
Proof.
Admitted.
(* Exercise: replace "Admitted." by a proof, if there is one. *)

(* ********** *)

(* end of week_35.v *)


Require Import
  Coq.Lists.List
  MathClasses.interfaces.abstract_algebra
  MathClasses.theory.rings
  Ring.
Import ListNotations.

Section contents.
  Context R `{Ring R}.
  Add Ring R: (stdlib_ring_theory R).

  Definition poly := list R.

  Coercion poly_constant (c : R) : poly := [c].

  Global Instance poly_zero: Zero poly := [].
  Global Instance poly_one: One poly := poly_constant 1.

  Definition all (l: list Prop): Prop := fold_left and l True.
  Lemma all_cons P Ps: all (P::Ps) ↔ P ∧ all Ps.
  Proof.
    unfold all.
    revert P; generalize True as Q.
    induction Ps as [|P' Ps IH]; intros.
    { cbn; tauto. }
    change (fold_left and (P' :: Ps) (Q ∧ P) ↔ P ∧ fold_left and (P'::Ps) Q).
    rewrite !IH.
    transitivity (P' ∧ (P ∧ fold_left and Ps Q)); try tauto.
    now rewrite <- (IH Q P).
  Qed.
  Arguments all: simpl never.

  Definition poly_eq_zero: poly → Prop := all ∘ map ((=) 0).
  Corollary poly_eq_zero_cons x p: poly_eq_zero (x::p) ↔ x = 0 ∧ poly_eq_zero p.
  Proof.
    unfold poly_eq_zero, compose; cbn; rewrite all_cons.
    intuition now symmetry.
  Qed.

  Lemma poly_eq_zero_ind (P: poly → Prop) (case_nil: P [])
        (casecons: ∀ x p, x = 0 → poly_eq_zero p → P p → P (x::p))
        p: poly_eq_zero p → P p.
  Proof.
    induction p as [|x p IH]; auto.
    intros [??]%poly_eq_zero_cons.
    eauto.
  Qed.

  Global Instance poly_eq: Equiv poly :=
    fix F p q :=
    match p, q with
    | [], _ => poly_eq_zero q
    | _, [] => poly_eq_zero p
    | h :: t, h' :: t' => h = h' ∧ F t t'
    end.

  Lemma poly_eq_p_zero p: (p = 0) ↔ poly_eq_zero p.
  Proof. now destruct p. Qed.

  Instance: Reflexive poly_eq.
  Proof with intuition. repeat intro. induction x... split... Qed.

  Lemma poly_eq_cons :
    ∀ (a b : R) (p q : poly), (a = b /\ poly_eq p q) <-> poly_eq (a :: p) (b :: q).
  Proof. easy. Qed.

  Lemma poly_eq_ind (P: poly → poly → Prop)
        (case_0: ∀ p p', poly_eq_zero p → poly_eq_zero p' → P p p')
        (case_cons: ∀ x x' p p', x = x' → p = p' → P p p' → P (x::p) (x'::p'))
        p: ∀ p', p = p' → P p p'.
  Proof.
    induction p as [|x p IH]; intros [|x' p'] eqxy.
    1,2,3: now apply case_0.
    destruct eqxy.
    apply case_cons; auto.
  Qed.

  Lemma poly_eq_zero_trans p q: poly_eq_zero p → poly_eq_zero q → p = q.
  Proof.
    revert q.
    induction p as [|x p IH]; intros ? eqp eqq; auto.
    destruct q as [|y q]; auto.
    rewrite poly_eq_zero_cons in *.
    rewrite <- poly_eq_cons.
    destruct eqp as [-> ?], eqq as [-> ?]; split; eauto.
    now apply IH.
  Qed.

  Instance: Symmetric poly_eq.
  Proof.
    intros p p' eqp.
    pattern p, p'; apply poly_eq_ind; auto; clear p p' eqp.
    - now intros; apply poly_eq_zero_trans.
    - intros ???? eqx eqp IH.
      rewrite <- poly_eq_cons; auto.
  Qed.

  Instance poly_eq_zero_proper: Proper (poly_eq ==> iff) poly_eq_zero.
  Proof.
    apply proper_sym_impl_iff.
    { apply _. }
    red; refine (poly_eq_ind _ _ _).
    - intros; hnf; auto.
    - unfold impl; intros ???? eqx eqp IH.
      rewrite !poly_eq_zero_cons, eqx; tauto.
  Qed.

  Instance: Transitive poly_eq.
  Proof.
    intros ??? eqxy; revert z.
    pattern x, y; refine (poly_eq_ind _ _ _ x y eqxy); clear x y eqxy.
    { intros x y x0 y0 z eqz.
      apply poly_eq_zero_trans; auto.
      now rewrite <- eqz. }
    intros ???? eqx eqp IH z eqz.
    destruct z as [|x'' p''].
    { eapply poly_eq_zero_proper; eauto.
      now split. }
    destruct eqz as [eqx' eqp']; split; eauto.
  Qed.

  Global Instance: Setoid poly.
  Proof. split; try apply _. Qed.

  Global Instance: Plus poly := fix F p q :=
    match p, q with
    | [], _ => q
    | _, [] => p
    | h :: t, h' :: t' => h + h' :: F t t'
    end.

  Lemma poly_eq_zero_plus_l p q: poly_eq_zero p → p + q = q.
  Proof.
    intro eqp; revert q.
    induction eqp as [|x p eqx eqp IH] using poly_eq_zero_ind.
    { easy. }
    intros [|y q].
    { cbn -[poly_eq_zero].
      rewrite poly_eq_zero_cons; auto. }
    cbn; split; auto.
    ring [eqx].
  Qed.

  Instance plus_commutative: Commutative (+).
  Proof with (try easy); cbn.
    intro.
    induction x as [|x p IH]; intros [|y q]...
    split; auto; ring.
  Qed.

  Corollary poly_eq_zero_plus_r p q: poly_eq_zero q → p + q = p.
  Proof.
    rewrite commutativity.
    apply poly_eq_zero_plus_l.
  Qed.

  Corollary poly_eq_zero_plus p q: poly_eq_zero p → poly_eq_zero q → poly_eq_zero (p+q).
  Proof.
    intro.
    rewrite <- !poly_eq_p_zero; intro.
    now rewrite poly_eq_zero_plus_l.
  Qed.

  Global Instance poly_plus_proper: Proper (poly_eq ==> poly_eq ==> poly_eq) (+).
  Proof.
    unfold Proper, respectful.
    refine (poly_eq_ind _ _ _).
    { intros p p' zp zp' q q' eqq.
      rewrite !poly_eq_zero_plus_l; auto. }
    intros ???? eqx eqp IH.
    refine (poly_eq_ind _ _ _).
    { intros q q' zq zq'.
      rewrite !poly_eq_zero_plus_r; auto.
      cbn; auto. }
    intros y y' q q' eqy eqq _.
    cbn; split; eauto.
    ring [eqx eqy].
  Qed.

  Instance plus_associative: Associative (+).
  Proof with try easy.
    do 2 red; induction x as [|x p IH]...
    intros [|y q]...
    intros [|z r]...
    cbn; split; auto.
    ring.
  Qed.

  Instance plus_left_id: LeftIdentity (+) 0.
  Proof. now intro; rewrite poly_eq_zero_plus_l. Qed.
  Instance plus_right_id: RightIdentity (+) 0.
  Proof. now intro; rewrite poly_eq_zero_plus_r. Qed.

  Instance poly_plus_monoid: Monoid poly.
  Proof. repeat (split; try apply _). Qed.

  Global Instance: Negate poly := map (-).

  Lemma poly_negate_zero p: poly_eq_zero p ↔ poly_eq_zero (-p).
  Proof.
    induction p as [|x p IH].
    { easy. }
    cbn.
    rewrite !poly_eq_zero_cons, IH.
    enough (x = 0 ↔ -x = 0) by tauto.
    split; intro eq0; ring [eq0].
  Qed.

  Instance poly_negate_proper: Proper (poly_eq ==> poly_eq) (-).
  Proof.
    refine (poly_eq_ind _ _ _).
    { now intros ?? ->%poly_negate_zero%poly_eq_p_zero ->%poly_negate_zero%poly_eq_p_zero. }
    intros ???? eqx eqp IH.
    cbn; split; eauto.
  Qed.

  Instance poly_negate_l: LeftInverse (+) (-) 0.
  Proof.
    intro; rewrite poly_eq_p_zero.
    induction x as [|x p IH]; cbn.
    { easy. }
    rewrite poly_eq_zero_cons; split; auto.
    ring.
  Qed.

  Instance poly_negate_r: RightInverse (+) (-) 0.
  Proof. now intro; rewrite commutativity, left_inverse. Qed.

  Instance poly_plus_abgroup: AbGroup poly.
  Proof. repeat (split; try apply _). Qed.

  Fixpoint poly_mult_cr (q: poly) (c: R): poly :=
    match q with
    | [] => 0
    | d :: q1 => c*d :: poly_mult_cr q1 c
    end.

  Lemma poly_mult_cr_0_l q c: poly_eq_zero q → poly_eq_zero (poly_mult_cr q c).
  Proof.
    induction q as [|x q IH].
    { easy. }
    cbn.
    rewrite !poly_eq_zero_cons.
    intros [-> ?]; split; auto.
    ring.
  Qed.

  Instance poly_mult_cr_proper: Proper ((=) ==> (=) ==> (=)) poly_mult_cr.
  Proof.
    intros p p' eqp c c' eqc.
    revert p p' eqp; refine (poly_eq_ind _ _ _).
    { now intros; apply poly_eq_zero_trans; apply poly_mult_cr_0_l. }
    intros ???? eqx eqp IH.
    split; auto; cbn.
    ring [eqx eqc].
  Qed.

  Lemma poly_mult_cr_1_l x: poly_mult_cr 1 x = [x].
  Proof. cbn; split; [ring|easy]. Qed.
  Instance poly_mult_cr_1_r: RightIdentity poly_mult_cr 1.
  Proof.
    red; induction x as [|x p IH]; [easy|cbn].
    split; auto; ring.
  Qed.

  Instance poly_mult_cr_dist_l: LeftHeteroDistribute poly_mult_cr (+) (+).
  Proof.
    intros x a b.
    induction x as [|x p IH]; [easy|cbn].
    split; auto; ring.
  Qed.
  Instance poly_mult_cr_dist_r: RightHeteroDistribute poly_mult_cr (+) (+).
  Proof.
    intros p q a.
    revert q.
    induction p as [|x p IH]; intros [|y q]; [easy..|cbn].
    split; auto; ring.
  Qed.
  Instance poly_mult_cr_assoc: HeteroAssociative poly_mult_cr (.*.) poly_mult_cr poly_mult_cr.
  Proof.
    intros x a b.
    induction x as [|p x IH]; [easy|cbn].
    split; auto; ring.
  Qed.

  Lemma poly_mult_cr_0_r q c: c = 0 → poly_eq_zero (poly_mult_cr q c).
  Proof.
    intros ->.
    induction q as [|x q IH]; [easy|cbn].
    rewrite poly_eq_zero_cons; split; auto.
    ring.
  Qed.

  Global Instance: Mult poly := fix F p q :=
    match p with
    | [] => 0
    | c :: p1 => poly_mult_cr q c + (0 :: F p1 q)
    end.

  Lemma poly_mult_0_l p q: poly_eq_zero p → poly_eq_zero (p * q).
  Proof.
    induction 1 using poly_eq_zero_ind; [easy|cbn].
    apply poly_eq_zero_plus.
    - now apply poly_mult_cr_0_r.
    - rewrite poly_eq_zero_cons; auto.
  Qed.

  Lemma poly_mult_0_r p q: poly_eq_zero q → poly_eq_zero (p * q).
  Proof.
    induction p as [|x p IH]; [easy|cbn].
    intro eq0.
    apply poly_eq_zero_plus.
    - now apply poly_mult_cr_0_l.
    - rewrite poly_eq_zero_cons; auto.
  Qed.

  Instance poly_mult_proper: Proper ((=) ==> (=) ==> (=)) (.*.).
  Proof.
    refine (poly_eq_ind _ _ _).
    { intros ?? zp zp' q q' eqq.
      now apply poly_eq_zero_trans; apply poly_mult_0_l. }
    intros ???? eqx eqp IH q q' eqq.
    cbn.
    apply poly_plus_proper.
    { now rewrite eqx, eqq. }
    split; auto.
    now apply IH.
  Qed.

  Instance poly_mult_left_distr: LeftDistribute (.*.) (+).
  Proof.
    intros p q r.
    induction p as [|x p IH]; [easy|cbn].
    rewrite (distribute_r q r x).
    rewrite <- !associativity; apply poly_plus_proper; [easy|].
    rewrite associativity, (commutativity (0::p*q)), <- associativity.
    apply poly_plus_proper; [easy|].
    cbn; split; [ring|easy].
  Qed.

  Lemma poly_mult_cons_r p q x: p * (x::q) = poly_mult_cr p x + (0 :: p * q).
  Proof.
    induction p as [|y p IH]; cbn; auto.
    split; auto.
    rewrite IH, !associativity, (commutativity (poly_mult_cr _ _)).
    split; try easy.
    ring.
  Qed.

  Instance poly_mult_comm: Commutative (.*.).
  Proof.
    intros p.
    induction p as [|x p IH].
    { cbn; intro.
      now apply poly_mult_0_r. }
    intros [|y q]; cbn.
    { rewrite poly_eq_zero_cons; split; auto.
      now apply poly_mult_0_r. }
    split. 1: ring.
    rewrite !poly_mult_cons_r, !associativity.
    apply poly_plus_proper.
    { apply commutativity. }
    rewrite <- poly_eq_cons; split; auto.
    apply IH.
  Qed.

  Instance poly_mult_right_distr: RightDistribute (.*.) (+).
  Proof.
    intros p q r.
    now rewrite commutativity, distribute_l, !(commutativity r).
  Qed.

  Instance poly_mult_1_l: LeftIdentity (.*.) 1.
  Proof.
    intro; cbn.
    rewrite poly_mult_cr_1_r, poly_eq_zero_plus_r; auto.
    now split.
  Qed.

  Instance poly_mult_1_r: RightIdentity (.*.) 1.
  Proof.
    intro; rewrite commutativity; apply left_identity.
  Qed.

  Instance poly_mult_assoc: Associative (.*.).
  Proof with (try easy); cbn.
    intros x.
    induction x as [|x p IH]...
    intros q r; cbn.
    rewrite distribute_r.
    apply poly_plus_proper; cbn -[poly_eq].
    { clear IH.
      induction q as [|y q IH]...
      rewrite distribute_r, <- associativity, (commutativity x y).
      apply poly_plus_proper...
      split; auto.
      ring. }
    assert (poly_mult_cr r 0 = 0) as ->.
    { now rewrite poly_eq_p_zero; apply poly_mult_cr_0_r. }
    cbn; split; eauto.
    now rewrite IH.
  Qed.

  Global Instance poly_ring: Ring poly.
  Proof. repeat (split; try apply _). Qed.
End contents.

(*

Section test.

  Context `{Ring R} (x y: poly (poly (poly (poly R)))).

  Goal x + y == x * y.
    set (d := Plus_instance_0 ).
    set (u := Mult_instance_0).
    set (t := poly (poly R)).
    unfold poly_zero.

*)


Fixpoint eqb (n m : nat) : bool :=
  match n, m with
  | O, S m' => false
  | S n', O => false
  | O, O => true
  | S n', S m' => eqb n' m'
  end.

Notation "x =? y" := (eqb x y) (at level 70) : nat_scope.

Theorem zero_nbeq_plus_q : forall n : nat,
    0 =? (n + 1) = false.
Proof.
  intros [| n'].
  - simpl. reflexivity.
  - simpl. reflexivity.
Qed.


(******************************************************************************)
(* Chapter 1.4: Functors                                                      *)
(******************************************************************************)
(* @suharahiromichi *)

(*
(0)
同じディレクトリにある Categories.v を使う。

(1) ベースライン
http://www.megacz.com/berkeley/coq-categories/
これをもとに改変。Instance ... Proper を使うようにした。
 *)

From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Require Import Morphisms.
Require Import Aw_0_Notations.
Require Import Aw_1_3_Categories.

Class Functor `(C1 : Category) `(C2 : Category) (fobj : C1 -> C2) : Type :=
  {
    functor_fobj := fobj;
    fmor                : forall {a b : C1}, a ~> b -> (fobj a) ~> (fobj b);
    fmor_respects       : forall {a b : C1} {f f' : a ~> b},
                            f === f' -> fmor f === fmor f';
    fmor_preserves_id   : forall {a : C1}, @fmor a a iid === iid;
(* forall a, fmor (id a) === iid (fobj a); *)
    fmor_preserves_comp : forall {a b c : C1} {f : a ~> b} {g : b ~> c},
                            (fmor g) \\o (fmor f) === fmor (g \\o f)
  }.
Coercion functor_fobj : Functor >-> Funclass.

Check functor_fobj : ∀Obj Hom C1 Obj0 Hom0 C2 fobj _ _, C2.
(* ,の前の最後の「_」は、普通の引数で、C1（の対象） *)
Check @fmor        : ∀Obj Hom C1 Obj0 Hom0 C2 fobj _ a b _, fobj a ~> fobj b.
(* ,の前の最後の「_」は、普通の引数で、a ~> b の型を持つ。 *)

(* fobj と fmor の意味：
カテゴリ1 C1 = (Obj, Hom)
カテゴリ2 C2 = (Obj0, Hom0)

fobj : C1 -> C2、カテゴリC1（の対象）からC2（の対象）への写像
ファンクタからのコアーションが効く。

fmor : (a ~> b) -> (fobj a ~> fobj b)
カテゴリC1（の射）からC2（の射）への写像、
ただし fobj が与えられないと、意味をなさないことに注意！
 *)

Check @fmor : ∀Obj Hom C1 Obj0 Hom0 C2 fobj _ a b _, fobj a ~> fobj b.
Check fmor : _ ~> _ -> _ ~> _.
About fmor.                       (* Set Implicit Arguments の所為で、
                                     fobj は implicit になっている。 *)
Arguments fmor {Obj Hom Obj0 Hom0 C1 C2} fobj {_ a b} _ : rename.
Check fmor.                          (* fobj を指定するようにする。 *)

Notation "F \ f" := (fmor F f) : category_scope.
Open Scope category_scope.

(* parametric_morphism_fmor *)
(* これの証明に、Classの公理に Proper (eqv ==> eqv) fmor が必要なわけではない。 *)
(* また、(@fmor _ _ .... a b) は fmor と略せない。  *)
Instance functor_fmor_Proper `(C1 : Category) `(C2 : Category)
         (Fobj : C1 -> C2) (F : Functor Fobj) (a b : C1) :
  Proper (@eqv (a ~> b) ==> @eqv (Fobj a ~> Fobj b)) (@fmor _ _ _ _ _ _ _ _ a b).
Proof.
  move=> x y.                               (* これが肝 *)
  Check (@fmor_respects _ _ C1 _ _ C2 Fobj F a b x y).
  by apply (@fmor_respects _ _ C1 _ _ C2 Fobj F a b x y).
Qed.

(* 恒等関手 *)
(* the identity functor *)
Program Instance functor_id `(C : Category) : Functor (fun (x : C) => x) :=
  {|
    fmor := fun (a b : C) (f : a ~> b) => f
  |}.
Obligation 2.                               (* iid === iid *)
Proof.
  Check (fun (x : C) => C).                 (* カテゴリC(の対象)から、カテゴリC(の対象)の写像 *)
  Check (fun (a b : C) (f : a ~> b) => f).  (* カテゴリC(の射)から、カテゴリC(の射)の写像 *)
  reflexivity.                              (* fmor_preserves_id *)
Defined.
Obligation 3.                               (* g \\o f === g \\o f *)
Proof.
  reflexivity.                              (* fmor_preserves_comp *)
Defined.

(* 定数関手 *)
(* the constant functor *)
Program Instance functor_const `(C : Category) `{D : Category} (d : D) :
  Functor (fun (x : C) => d) :=
  {|
    fmor := fun (a b : C) (f : a ~> b) => iid
  |}.
Obligation 1.
Proof.
  Check (fun (x : C) => d). (* カテゴリC(の対象)から、カテゴリD(の対象)の写像 *)
  Check (fun (a b : C) (f : a ~> b) => iid). (* カテゴリC(の射)から、カテゴリD(の射)の写像 *)
  reflexivity.
Defined.
Obligation 2.
Proof.
  reflexivity.
Defined.
Obligation 3.
Proof.
  by apply left_identity.
Defined.

Generalizable Variables Fobj Gobj.

Locate "_ ○ _".                            (* "f ○ g" := fun x => f (g x) *)
Locate "_ \o _".                            (* SSReflect では、こっちを使う。 *)
Locate "_ \\o _".                           (* "f \\o g" := comp f g *)

(* 関手の合成 *)
(* functors compose *)
Program Instance functor_comp `(C1 : Category) `(C2 : Category) `(C3 : Category)
        `(F : @Functor _ _ C1 _ _ C2 Fobj) `(G : @Functor _ _ C2 _ _ C3 Gobj) :
  Functor (Gobj \o Fobj) :=
  {|
    fmor := fun a b m => G \ (F \ m)
  |}.
Obligation 1.
Proof.
  Check F : C1 -> C2.              (* C1の対象からC2の対象への写像  *)
  Check Fobj : C1 -> C2.           (* C1の対象からC2の対象への写像  *)
  Check fmor F.                    (* C1の射からC2の射への写像 *)
  Check G : C2 -> C3.              (* C2の対象からC3の対象への写像  *)
  Check Gobj : C2 -> C3.           (* C2の対象からC3の対象への写像  *)
  Check fmor G.                    (* C2の射からC3の射への写像 *)
  rewrite H.
  reflexivity.
Defined.
Obligation 2.
Proof.
  repeat setoid_rewrite fmor_preserves_id.
  reflexivity.
Defined.
Obligation 3.
Proof.
  repeat setoid_rewrite fmor_preserves_comp.
  reflexivity.
Defined.

Notation "f >>>> g" := (@functor_comp _ _ _ _ _ _ _ _ _ _ f _ g)   : category_scope.
Open Scope category_scope.

Generalizable Variables Xobj Yobj Zobj a b.

(*
Lemma functor_comp_assoc `{C : Category} `{D : Category} `{E : Category} `{F : Category}
      `(F1 : @Functor _ _ C _ _ D Xobj)
      `(F2 : @Functor _ _ D _ _ E Yobj)
      `(F3 : @Functor _ _ E _ _ F Zobj) :
  forall (a b : C) (f : a ~> b),
    ((F1 >>>> F2) >>>> F3) \ f === (F1 >>>> (F2 >>>> F3)) \ f.

Lemma functor_comp_assoc `{C':Category}`{D:Category}`{E:Category}`{F:Category}
  {F1obj}(F1:Functor C' D F1obj)
  {F2obj}(F2:Functor D E F2obj)
  {F3obj}(F3:Functor E F F3obj)
  `(f:a~>b) :
  ((F1 >>>> F2) >>>> F3) \ f ~~ (F1 >>>> (F2 >>>> F3)) \ f.
  intros; simpl.
  reflexivity.
  Qed.
*)

(* this is like JMEq, but for the particular case of ~~; note it does not require any axioms! *)

Inductive heq_morphisms `{C : Category} {a b : C} (f : a ~> b) :
  forall {a' b' : C}, a' ~> b' -> Prop :=
| heq_morphisms_intro {f' : a ~> b} :
    eqv f f' -> @heq_morphisms _ _ C a b f a b f'.

Definition heq_morphisms_refl `{C : Category} a b f :
  @heq_morphisms _ _ C a b f a  b  f.
Proof.
  apply heq_morphisms_intro.
  reflexivity.
Qed.
Check heq_morphisms_refl.
Check @heq_morphisms_refl :
  forall {Obj Hom C} {a b : Obj} {f : a ~> b},
    heq_morphisms f f.

Definition heq_morphisms_symm `{C : Category} a b f a' b' f' :
  @heq_morphisms _ _ C a b f a' b' f' -> @heq_morphisms _ _ C a' b' f' a b f.
Proof.
  case=> f'' H.
  apply: heq_morphisms_intro.
  rewrite H.
  reflexivity.
Qed.
Check heq_morphisms_symm.
Check @heq_morphisms_symm :
  forall {Obj Hom C}
         {a b : Obj} {f : a ~> b}
         {a' b' : Obj} {f' : a' ~> b'},
    heq_morphisms f f' -> heq_morphisms f' f.

Definition heq_morphisms_tran `{C : Category} a b f a' b' f' a'' b'' f'' :
  @heq_morphisms _ _ C a b f a' b' f' ->
  @heq_morphisms _ _ C a' b' f' a'' b'' f'' ->
  @heq_morphisms _ _ C a b f a'' b'' f''.
Proof.
  case=> f''' H.
  case=> f'''' H'.
  apply: heq_morphisms_intro.
  rewrite -H'.
  by apply: H.
Qed.
Check heq_morphisms_tran.
Check @heq_morphisms_tran :
  forall {Obj Hom C}
         {a b : Obj} {f : a ~> b}
         {a' b' : Obj} {f' : a' ~> b'}
         {a'' b'' : Obj} {f'' : a'' ~> b''},
    heq_morphisms f f' -> heq_morphisms f' f'' -> heq_morphisms f f''.

(*
Add Parametric Relation  (Ob:Type)(Hom:Ob->Ob->Type)(C:Category Ob Hom)(a b:Ob) : (hom a b) (eqv a b)
  reflexivity proved by  heq_morphisms_refl
  symmetry proved by     heq_morphisms_symm
  transitivity proved by heq_morphisms_tran
  as parametric_relation_heq_morphisms.
  Add Parametric Morphism `(c:Category Ob Hom)(a b c:Ob) : (comp a b c)
  with signature (eqv _ _ ==> eqv _ _ ==> eqv _ _) as parametric_morphism_comp.
  auto.
  Defined.
*)

Implicit Arguments heq_morphisms [ Obj Hom C a b a' b' ].
Hint Constructors heq_morphisms.

Definition EqualFunctors `{C1 : Category} `{C2 : Category}
           {F1obj} (F1 : Functor F1obj)
           {F2obj} (F2 : Functor F2obj) :=
  forall a b (f f' : hom a b),
    f === f' -> heq_morphisms (fmor F1 f) (fmor F2 f').
(* f f' : a~~{C1}~~>b *)

Notation "f ~~~~ g" := (EqualFunctors f g) (at level 45).

Class IsomorphicCategories `(C : Category) `(D : Category) : Type :=
  {
    ic_f_obj    : C -> D;
    ic_g_obj    : D -> C;
    ic_f        : Functor ic_f_obj;
    ic_g        : Functor ic_g_obj;

    ic_forward  : ic_f >>>> ic_g ~~~~ functor_id C;
    ic_backward : ic_g >>>> ic_f ~~~~ functor_id D
  }.

(* this causes Coq to die: *)
(* Definition IsomorphicCategories := Isomorphic (CategoryOfCategories). *)


Require Import coqutil.Datatypes.Inhabited.
Require Coq.Lists.List coqutil.Datatypes.List.
Require Import Coq.ZArith.ZArith. Local Open Scope Z_scope.
Require Import Coq.micromega.Lia.

Module List.
  Section WithA.
    Import List.ListNotations.
    Local Notation len l := (Z.of_nat (List.length l)) (only parsing).

    Context [A: Type].

    Definition get{inh: inhabited A}(l: list A)(z: Z): A :=
      if Z.ltb z 0 then default
      else List.nth (Z.to_nat z) l default.

    Definition from(z: Z): list A -> list A := List.skipn (Z.to_nat z).

    Definition upto(z: Z): list A -> list A := List.firstn (Z.to_nat z).

    (* length-preserving update seems to create too many additional terms,
       so we prefer non-length-preserving update
    Definition zupds(l: list A)(i: Z)(xs: list A): list A :=
      upto i l ++ from (-i) (upto (zlen l - i) xs) ++ from (i + zlen xs) l. *)

    Definition set(l: list A)(i: Z)(x: A): list A :=
      upto i l ++ [x] ++ from (i + 1) l.

    Definition repeatz(x: A)(n: Z): list A := List.repeat x (Z.to_nat n).

    Lemma len_from: forall (l: list A) i,
        0 <= i <= len l ->
        len (from i l) = len l - i.
    Proof. intros. unfold from. rewrite List.skipn_length. lia. Qed.

    Lemma len_upto: forall (l: list A) i,
        0 <= i <= len l ->
        len (upto i l) = i.
    Proof. intros. unfold upto. rewrite List.firstn_length. lia. Qed.

    Lemma len_set: forall (l: list A) i x,
        0 <= i < len l ->
        len (set l i x) = len l.
    Proof.
      intros. unfold set, upto, from.
      rewrite 2List.app_length, List.skipn_length, List.firstn_length. cbn. lia.
    Qed.

    Lemma len_app: forall (l1 l2: list A), len (l1 ++ l2) = len l1 + len l2.
    Proof. intros. rewrite List.app_length. lia. Qed.

    Lemma repeatz_0: forall (x: A), repeatz x 0 = nil.
    Proof. intros. reflexivity. Qed.

    Lemma len_repeatz: forall (x: A) (n: Z), 0 <= n -> len (repeatz x n) = n.
    Proof. intros. unfold repeatz. rewrite List.repeat_length. lia. Qed.

    Lemma from_beginning: forall (l: list A) i, i <= 0 -> from i l = l.
    Proof. intros. unfold from. replace (Z.to_nat i) with O by lia. reflexivity. Qed.

    Lemma upto_beginning: forall (l: list A) i, i <= 0 -> upto i l = nil.
    Proof. intros. unfold upto. replace (Z.to_nat i) with O by lia. reflexivity. Qed.

    Lemma from_pastend: forall (l: list A) i, len l <= i -> from i l = nil.
    Proof. intros. unfold from. apply List.skipn_all2. lia. Qed.

    Lemma upto_pastend: forall (l: list A) i, len l <= i -> upto i l = l.
    Proof. intros. unfold upto. apply List.firstn_all2. lia. Qed.

  End WithA.

  Module ZIndexNotations.
    Declare Scope zlist_scope.

    (* Notation instead of Definition so that lia sees the Z.of_nat and
       knows it's nonnegative.
       Separate notations for parsing/printing because we can't put the parsing
       notation in a scope: https://github.com/coq/coq/issues/16464 *)
    Notation len l := (Z.of_nat (List.length l)) (only parsing).
    Notation "'len' l" := (Z.of_nat (List.length l))
      (at level 10, only printing) : zlist_scope.

    Notation "a [ i ]" := (List.get a i)
      (at level 8, i at level 99, left associativity, format "a [ i ]") : zlist_scope.

    Notation "l [ i := x ]" := (List.set l i x)
      (at level 8, i at level 99, left associativity,
       format "l [ i  :=  x ]") : zlist_scope.

    Notation "a [: i ]" := (List.upto i a)
      (at level 8, i at level 99, left associativity, format "a [: i ]")
    : zlist_scope.

    Notation "a [ i :]" := (List.from i a)
      (at level 8, i at level 99, left associativity, format "a [ i :]")
    : zlist_scope.

    (* Note: i needs to be at level <= 99 to avoid conflict with type annotation, and all
       other notations starting with `_ [ _` must therefore also put i at that same level. *)
    Notation "a [ i : j ]" := (List.from i (List.upto j a))
      (at level 8, i at level 99, left associativity, format "a [ i  :  j ]")
    : zlist_scope.

    (* Now, `f [x]` means "list f at index x", so it can't mean "function f applied to
       singleton list x" any more, so we need to use a different notation for list liteals.
       Note, though, that this breaks parsing of Ltac like `tac1; [tac2|]`, and separating
       the bracket and bar into two tokens would bring the notation in conflict with
       index notations again. *)
    Notation "[| x |]" := (cons x nil) (format "[| x |]"): zlist_scope.
    Notation "[| x ; y ; .. ; z |]" :=
      (cons x (cons y .. (cons z nil) .. )) (format "[| x ;  y ;  .. ;  z |]") : zlist_scope.

    (* Redefined common list notations that we leave unchanged, but don't want to import
       from standard library because that one also gives us [ _ ; _ ; .. ; _ ] *)
    Notation "h :: t" := (cons h t) : zlist_scope.
    Notation "a ++ b" := (app a b) : zlist_scope.
  End ZIndexNotations.

  Section WithAAndZNotations.
    Import ZIndexNotations. Open Scope zlist_scope.

    Context [A: Type].

    (* Merging adjacent list slices:
       1) Turn all slices into the canonical format a[i:j]
       2) Apply merge_adjacent_slices *)

    Lemma from_upto_comm: forall (l: list A) (i j: Z),
        0 <= i ->
        0 <= j ->
        l[i:][:j] = l[i : i+j].
    Proof.
      intros. unfold List.from, List.upto.
      rewrite List.firstn_skipn_comm. f_equal. f_equal. lia.
    Qed.

    Lemma from_from: forall (l: list A) (i j: Z),
        0 <= i ->
        0 <= j ->
        l[i:][j:] = l[i+j:].
    Proof.
      intros. unfold List.from, List.upto.
      rewrite List.skipn_skipn. f_equal. lia.
    Qed.

    Lemma from_canon: forall (l: list A) (i: Z),
        l[i:] = l[i:len(l)].
    Proof.
      unfold List.from, List.upto. intros.
      replace (Z.to_nat (Z.of_nat (List.length l))) with (List.length l) by lia.
      rewrite List.firstn_all.
      reflexivity.
    Qed.

    Lemma upto_canon: forall (l: list A) (i: Z),
        l[:i] = l[0:i].
    Proof.
      unfold List.from, List.upto. intros.
      replace (Z.to_nat (Z.of_nat (List.length l))) with (List.length l) by lia.
      reflexivity.
    Qed.

    Lemma merge_adjacent_slices: forall (l: list A) (i j k: Z),
        i <= j <= k ->
        l[i:j] ++ l[j:k] = l[i:k].
    Proof.
      intros. unfold List.from, List.upto.
      rewrite <- (List.firstn_skipn (Z.to_nat j - Z.to_nat i)
                    (List.skipn (Z.to_nat i) (List.firstn (Z.to_nat k) l))).
      rewrite List.firstn_skipn_comm.
      rewrite List.skipn_skipn.
      rewrite List.firstn_firstn.
      repeat match goal with
             | |- @eq (list _) _ _ => f_equal
             end.
      all: lia.
    Qed.

    Lemma upto_app_discard_r: forall (xs ys: list A) i,
        i <= len xs ->
        (xs ++ ys)[:i] = xs[:i].
    Proof.
      unfold upto. intros. rewrite List.firstn_app.
      replace (Z.to_nat i - length xs)%nat with O by lia.
      change (List.firstn 0 ys) with (@nil A).
      apply List.app_nil_r.
    Qed.

    Lemma from_app_discard_l: forall (xs ys: list A) i,
        len xs <= i ->
        (xs ++ ys)[i:] = ys[i - len xs :].
    Proof.
      unfold from. intros. rewrite List.skipn_app.
      rewrite List.skipn_all2 by lia. simpl.
      f_equal. lia.
    Qed.

    Lemma from_upto_get: forall {inh: inhabited A} (xs : list A) i,
        0 <= i < len xs ->
        xs[i:i+1] = [| xs[i] |].
    Proof.
      unfold get, from, upto.
      induction xs; intros;
        [ destruct H; simpl in H0; lia | ].
      simpl in H.
      rewrite Zpos_P_of_succ_nat in H.
      destruct (Z_dec i 0) as [[Hi | Hi] | Hi].
      - exfalso. lia.
      - replace (Z.to_nat (i+1)) with (S (Z.to_nat ((i-1)+1))) by lia.
        rewrite List.firstn_cons.
        replace (Z.to_nat i) with (S (Z.to_nat (i-1))) by lia.
        rewrite List.skipn_cons.
        rewrite IHxs; [ | lia].
        destruct (i-1 <? 0) eqn:E; [lia | clear E].
        destruct (i <? 0) eqn:E; [lia | clear E].
        simpl. reflexivity.
      - subst. simpl. reflexivity.
    Qed.

    Lemma split_at_index: forall (xs : list A) i,
        0 <= i <= len xs ->
        xs = xs[:i] ++ xs[i:].
    Proof.
      intros.
      rewrite from_canon, upto_canon.
      rewrite merge_adjacent_slices by auto.
      rewrite from_beginning by easy.
      rewrite upto_pastend; easy.
    Qed.

    Lemma expose_nth: forall {inh: inhabited A} (xs : list A) i,
        0 <= i < len xs ->
        xs = xs[:i] ++ [| xs[i] |] ++ xs[i+1:].
    Proof.
      intros.
      rewrite <- from_upto_get by auto.
      rewrite (from_canon xs (i+1)).
      rewrite merge_adjacent_slices by lia.
      rewrite <- from_canon.
      apply split_at_index.
      lia.
    Qed.

    Lemma len_sized_slice: forall (xs : list A) i size,
        0 <= size /\ 0 <= i /\ i + size <= len xs ->
        len xs[i:][:size] = size.
    Proof.
      intros.
      rewrite len_upto; auto.
      unfold from. rewrite List.length_skipn. lia.
    Qed.

    Lemma len_add_sized_slice: forall (xs : list A) i size,
        0 <= size /\ 0 <= i /\ i + size <= len xs ->
        len xs[i : i+size] = size.
    Proof.
      intros. rewrite <- from_upto_comm by lia. apply len_sized_slice; lia.
    Qed.

    Lemma len_indexed_slice: forall (xs : list A) i j,
        0 <= i /\ i <= j /\ j <= len xs ->
        len xs[i : j] = j-i.
    Proof.
      intros.
      replace j with (i + (j-i)) by lia.
      rewrite <- from_upto_comm by lia.
      rewrite len_sized_slice; lia.
    Qed.

  End WithAAndZNotations.
End List.


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

Require Import BinPos BinNat BinInt Zbool Zcompare Zorder Zabs Znat Ndiv_def.
Local Open Scope Z_scope.

(** * Definitions of divisions for binary integers *)

(** Concerning the many possible variants of integer divisions, see:

    R. Boute, "The Euclidean definition of the functions div and mod",
    ACM Transactions on Programming Languages and Systems,
    Vol. 14, No.2, pp. 127-144, April 1992.

   We provide here two flavours:

    - convention Floor (F) : [Zdiv_eucl], [Zdiv], [Zmod]
    - convention Trunc (T) : [Zquotrem], [Zquot], [Zrem]

   A third one, the Euclid (E) convention, can be found in file
   Zeuclid.v

   For non-zero b, they all satisfy [a = b*(a/b) + (a mod b)]
   and [ |a mod b| < |b| ], but the sign of the modulo will differ
   when [a<0] and/or [b<0].

*)

(** * Floor *)

(** [Zdiv_eucl] provides a Truncated-Toward-Bottom (a.k.a Floor)
  Euclidean division. Its projections are named [Zdiv] and [Zmod].
  These functions correspond to the `div` and `mod` of Haskell.
  This is the historical convention of Coq.

  The main properties of this convention are :
    - we have [sgn (a mod b) = sgn (b)]
    - [div a b] is the greatest integer smaller or equal to the exact
      fraction [a/b].
    - there is no easy sign rule.

  In addition, note that we arbitrary take [a/0 = 0] and [a mod 0 = 0].
*)

(** First, a division for positive numbers. Even if the second
   argument is a Z, the answer is arbitrary is it isn't a Zpos. *)

Fixpoint Zdiv_eucl_POS (a:positive) (b:Z) : Z * Z :=
  match a with
    | xH => if Zge_bool b 2 then (0, 1) else (1, 0)
    | xO a' =>
      let (q, r) := Zdiv_eucl_POS a' b in
	let r' := 2 * r in
	  if Zgt_bool b r' then (2 * q, r') else (2 * q + 1, r' - b)
    | xI a' =>
      let (q, r) := Zdiv_eucl_POS a' b in
	let r' := 2 * r + 1 in
	  if Zgt_bool b r' then (2 * q, r') else (2 * q + 1, r' - b)
  end.

(** Then the general euclidean division *)

Definition Zdiv_eucl (a b:Z) : Z * Z :=
  match a, b with
    | 0, _ => (0, 0)
    | _, 0 => (0, 0)
    | Zpos a', Zpos _ => Zdiv_eucl_POS a' b
    | Zneg a', Zpos _ =>
      let (q, r) := Zdiv_eucl_POS a' b in
	match r with
	  | 0 => (- q, 0)
	  | _ => (- (q + 1), b - r)
	end
    | Zneg a', Zneg b' =>
      let (q, r) := Zdiv_eucl_POS a' (Zpos b') in (q, - r)
    | Zpos a', Zneg b' =>
      let (q, r) := Zdiv_eucl_POS a' (Zpos b') in
	match r with
	  | 0 => (- q, 0)
	  | _ => (- (q + 1), b + r)
	end
  end.

Definition Zdiv (a b:Z) : Z := let (q, _) := Zdiv_eucl a b in q.
Definition Zmod (a b:Z) : Z := let (_, r) := Zdiv_eucl a b in r.

Infix "/" := Zdiv : Z_scope.
Infix "mod" := Zmod (at level 40, no associativity) : Z_scope.

(** * Trunc *)

(** [Zquotrem] provides a Truncated-Toward-Zero Euclidean division.
  Its projections are named [Zquot] and [Zrem]. These functions
  correspond to the `quot` and `rem` of Haskell, and this division
  convention is used in most programming languages, e.g. Ocaml.

  With this convention:
   - we have [sgn(a rem b) = sgn(a)]
   - sign rule for division: [quot (-a) b = quot a (-b) = -(quot a b)]
   - and for modulo: [a rem (-b) = a rem b] and [(-a) rem b = -(a rem b)]

 Note that we arbitrary take here [quot a 0 = 0] and [a rem 0 = a].
*)

Definition Zquotrem (a b:Z) : Z * Z :=
  match a, b with
   | 0,  _ => (0, 0)
   | _, 0  => (0, a)
   | Zpos a, Zpos b =>
     let (q, r) := Pdiv_eucl a b in (Z_of_N q, Z_of_N r)
   | Zneg a, Zpos b =>
     let (q, r) := Pdiv_eucl a b in (- Z_of_N q, - Z_of_N r)
   | Zpos a, Zneg b =>
     let (q, r) := Pdiv_eucl a b in (- Z_of_N q, Z_of_N r)
   | Zneg a, Zneg b =>
     let (q, r) := Pdiv_eucl a b in (Z_of_N q, - Z_of_N r)
  end.

Definition Zquot a b := fst (Zquotrem a b).
Definition Zrem a b := snd (Zquotrem a b).

Infix "÷" := Zquot (at level 40, left associativity) : Z_scope.
(** No infix notation for rem, otherwise it becomes a keyword *)

(** * Correctness proofs *)

(** Correctness proofs for Trunc *)

Lemma Zdiv_eucl_POS_eq : forall a b, 0 < b ->
  let (q, r) := Zdiv_eucl_POS a b in Zpos a = b * q + r.
Proof.
 intros a b Hb.
 induction a; cbv beta iota delta [Zdiv_eucl_POS]; fold Zdiv_eucl_POS.
 (* ~1 *)
 destruct Zdiv_eucl_POS as (q,r); cbv zeta.
 rewrite Zpos_xI, IHa, Zmult_plus_distr_r, Zmult_permute.
 destruct Zgt_bool.
 now rewrite Zplus_assoc.
 now rewrite Zmult_plus_distr_r, Zmult_1_r, <- !Zplus_assoc, Zplus_minus.
 (* ~0 *)
 destruct Zdiv_eucl_POS as (q,r); cbv zeta.
 rewrite (Zpos_xO a), IHa, Zmult_plus_distr_r, Zmult_permute.
 destruct Zgt_bool; trivial.
 now rewrite Zmult_plus_distr_r, Zmult_1_r, <- !Zplus_assoc, Zplus_minus.
 (* ~1 *)
 generalize (Zge_cases b 2); destruct Zge_bool; intros Hb'.
 now rewrite Zmult_0_r.
 replace b with 1. reflexivity.
 apply Zle_antisym. now apply Zlt_le_succ in Hb. now apply Zlt_succ_le.
Qed.

Lemma Zdiv_eucl_eq : forall a b, b<>0 ->
 let (q, r) := Zdiv_eucl a b in a = b * q + r.
Proof.
 intros [ |a|a] [ |b|b]; unfold Zdiv_eucl; trivial;
  (now destruct 1) || intros _;
  generalize (Zdiv_eucl_POS_eq a (Zpos b) (eq_refl _));
  destruct Zdiv_eucl_POS as (q,r); try change (Zneg a) with (-Zpos a);
  intros ->.
 (* Zpos Zpos *)
 reflexivity.
 (* Zpos Zneg *)
 rewrite <- (Zopp_neg b), Zmult_opp_comm.
 destruct r as [ |r|r]; trivial.
 rewrite Zopp_plus_distr, Zmult_plus_distr_r, <- Zplus_assoc. f_equal.
 now rewrite <- Zmult_opp_comm, Zmult_1_r, Zplus_assoc, Zplus_opp_l.
 rewrite Zopp_plus_distr, Zmult_plus_distr_r, <- Zplus_assoc. f_equal.
 now rewrite <- Zmult_opp_comm, Zmult_1_r, Zplus_assoc, Zplus_opp_l.
 (* Zneg Zpos *)
 rewrite (Zopp_plus_distr _ r), Zopp_mult_distr_r.
 destruct r as [ |r|r]; trivial; unfold Zminus.
 rewrite Zopp_plus_distr, Zmult_plus_distr_r, <- Zplus_assoc. f_equal.
 now rewrite <- Zmult_opp_comm, Zmult_1_r, Zplus_assoc, Zplus_opp_l.
 rewrite Zopp_plus_distr, Zmult_plus_distr_r, <- Zplus_assoc. f_equal.
 now rewrite <- Zmult_opp_comm, Zmult_1_r, Zplus_assoc, Zplus_opp_l.
 (* Zneg Zneg *)
 now rewrite (Zopp_plus_distr _ r), Zopp_mult_distr_l.
Qed.

Lemma Z_div_mod_eq_full : forall a b, b<>0 -> a = b*(a/b) + (a mod b).
Proof.
 intros a b Hb. generalize (Zdiv_eucl_eq a b Hb).
 unfold Zdiv, Zmod. now destruct Zdiv_eucl.
Qed.

Lemma Zmod_POS_bound : forall a b, 0<b -> 0 <= snd (Zdiv_eucl_POS a b) < b.
Proof.
 assert (AUX : forall a p, a < Zpos (p~0) -> a - Zpos p < Zpos p).
  intros. unfold Zminus. apply Zlt_plus_swap. unfold Zminus.
  now rewrite Zopp_involutive, Zplus_diag_eq_mult_2, Zmult_comm.
 intros a [|b|b] Hb; discriminate Hb || clear Hb.
 induction a; cbv beta iota delta [Zdiv_eucl_POS]; fold Zdiv_eucl_POS.
 (* ~1 *)
 destruct Zdiv_eucl_POS as (q,r). cbv zeta.
 simpl in IHa; destruct IHa as (Hr,Hr').
 generalize (Zgt_cases (Zpos b) (2*r+1)). destruct Zgt_bool.
 unfold snd in *.
 split. apply Zplus_le_0_compat. now apply Zmult_le_0_compat. easy.
  now apply Zgt_lt.
 unfold snd in *.
 split. now apply Zle_minus_le_0.
  apply AUX.
  destruct r as [|r|r]; try (now destruct Hr); try easy.
  red. simpl. apply Pcompare_eq_Lt. exact Hr'.
 (* ~0 *)
 destruct Zdiv_eucl_POS as (q,r). cbv zeta.
 simpl in IHa; destruct IHa as (Hr,Hr').
 generalize (Zgt_cases (Zpos b) (2*r)). destruct Zgt_bool.
 unfold snd in *.
 split. now apply Zmult_le_0_compat.
  now apply Zgt_lt.
 unfold snd in *.
 split. now apply Zle_minus_le_0.
  apply AUX.
  destruct r as [|r|r]; try (now destruct Hr); try easy.
 (* 1 *)
 generalize (Zge_cases (Zpos b) 2). destruct Zge_bool; simpl.
 split. easy. now apply Zle_succ_l, Zge_le.
 now split.
Qed.

Lemma Zmod_pos_bound : forall a b, 0 < b -> 0 <= a mod b < b.
Proof.
 intros a [|b|b] Hb; discriminate Hb || clear Hb.
 destruct a as [|a|a]; unfold Zmod, Zdiv_eucl.
 now split.
 now apply Zmod_POS_bound.
 generalize (Zmod_POS_bound a (Zpos b) (eq_refl _)).
 destruct Zdiv_eucl_POS as (q,r). unfold snd. intros (Hr,Hr').
 destruct r as [|r|r]; (now destruct Hr) || clear Hr.
 now split.
 split. now apply Zlt_le_weak, Zlt_plus_swap.
 now apply Zlt_minus_simpl_swap.
Qed.

Lemma Zmod_neg_bound : forall a b, b < 0 -> b < a mod b <= 0.
Proof.
 intros a [|b|b] Hb; discriminate Hb || clear Hb.
 destruct a as [|a|a]; unfold Zmod, Zdiv_eucl.
 now split.
 generalize (Zmod_POS_bound a (Zpos b) (eq_refl _)).
 destruct Zdiv_eucl_POS as (q,r). unfold snd. intros (Hr,Hr').
 destruct r as [|r|r]; (now destruct Hr) || clear Hr.
 now split.
 split. rewrite Zplus_comm. now apply (Zplus_lt_compat_r 0).
 rewrite Zplus_comm. apply Zle_plus_swap. simpl. now apply Zlt_le_weak.
 generalize (Zmod_POS_bound a (Zpos b) (eq_refl _)).
 destruct Zdiv_eucl_POS as (q,r). unfold snd. intros (Hr,Hr').
 split. red in Hr'. now rewrite Zcompare_opp in Hr'. now destruct r.
Qed.

(** Correctness proofs for Floor *)

Theorem Zquotrem_eq: forall a b,
  let (q,r) := Zquotrem a b in a = q * b + r.
Proof.
 destruct a, b; simpl; trivial;
 generalize (Pdiv_eucl_correct p p0); case Pdiv_eucl; trivial;
  intros q r H; try change (Zneg p) with (-Zpos p);
  rewrite <- (Z_of_N_pos p), H, Z_of_N_plus, Z_of_N_mult; f_equal.
 now rewrite Zmult_opp_comm.
 now rewrite Zopp_plus_distr, Zopp_mult_distr_l.
 now rewrite Zopp_plus_distr, Zopp_mult_distr_r.
Qed.

Lemma Z_quot_rem_eq : forall a b, a = b*(a÷b) + Zrem a b.
Proof.
 intros a b. rewrite Zmult_comm. generalize (Zquotrem_eq a b).
 unfold Zquot, Zrem. now destruct Zquotrem.
Qed.

Lemma Zrem_bound : forall a b, 0<=a -> 0<b -> 0 <= Zrem a b < b.
Proof.
 intros a [|b|b] Ha Hb; discriminate Hb || clear Hb.
 destruct a as [|a|a]; (now destruct Ha) || clear Ha.
 compute. now split.
 unfold Zrem, Zquotrem.
 generalize (Pdiv_eucl_remainder a b). destruct Pdiv_eucl as (q,r).
 simpl. split. apply Z_of_N_le_0.
 destruct r; red; simpl; trivial.
Qed.

Lemma Zrem_opp_l : forall a b, Zrem (-a) b = - (Zrem a b).
Proof.
 intros [|a|a] [|b|b]; trivial; unfold Zrem;
  simpl; destruct Pdiv_eucl; simpl; try rewrite Zopp_involutive; trivial.
Qed.

Lemma Zrem_opp_r : forall a b, Zrem a (-b) = Zrem a b.
Proof.
 intros [|a|a] [|b|b]; trivial; unfold Zrem; simpl;
  destruct Pdiv_eucl; simpl; try rewrite Zopp_involutive; trivial.
Qed.


(************************************************************************)
(*  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        *)
(************************************************************************)

(*i $Id$ i*)

(** This file formalizes Berardi's paradox which says that in
   the calculus of constructions, excluded middle (EM) and axiom of
   choice (AC) imply proof irrelevance (PI).
   Here, the axiom of choice is not necessary because of the use
   of inductive types.
<<
@article{Barbanera-Berardi:JFP96,
   author    = {F. Barbanera and S. Berardi},
   title     = {Proof-irrelevance out of Excluded-middle and Choice
                in the Calculus of Constructions},
   journal   = {Journal of Functional Programming},
   year      = {1996},
   volume    = {6},
   number    = {3},
   pages     = {519-525}
}
>> *)

Set Implicit Arguments.

Section Berardis_paradox.

(** Excluded middle *)
Hypothesis EM : forall P:Prop, P \/ ~ P.

(** Conditional on any proposition. *)
Definition IFProp (P B:Prop) (e1 e2:P) :=
  match EM B with
  | or_introl _ => e1
  | or_intror _ => e2
  end.

(** Axiom of choice applied to disjunction.
    Provable in Coq because of dependent elimination. *)
Lemma AC_IF :
 forall (P B:Prop) (e1 e2:P) (Q:P -> Prop),
   (B -> Q e1) -> (~ B -> Q e2) -> Q (IFProp B e1 e2).
Proof.
intros P B e1 e2 Q p1 p2.
unfold IFProp in |- *.
case (EM B); assumption.
Qed.

(** We assume a type with two elements. They play the role of booleans.
    The main theorem under the current assumptions is that [T=F] *)
Variable Bool : Prop.
Variable T : Bool.
Variable F : Bool.

(** The powerset operator *)
Definition pow (P:Prop) := P -> Bool.

(** A piece of theory about retracts *)
Section Retracts.

Variables A B : Prop.

Record retract : Prop :=
  {i : A -> B; j : B -> A; inv : forall a:A, j (i a) = a}.

Record retract_cond : Prop :=
  {i2 : A -> B; j2 : B -> A; inv2 : retract -> forall a:A, j2 (i2 a) = a}.

(** The dependent elimination above implies the axiom of choice: *)
Lemma AC : forall r:retract_cond, retract -> forall a:A, j2 r (i2 r a) = a.
Proof.
intros r.
case r; simpl in |- *.
trivial.
Qed.

End Retracts.

(** This lemma is basically a commutation of implication and existential
    quantification:  (EX x | A -> P(x))  <=> (A -> EX x | P(x))
    which is provable in classical logic ( => is already provable in
    intuitionnistic logic). *)

Lemma L1 : forall A B:Prop, retract_cond (pow A) (pow B).
Proof.
intros A B.
destruct (EM (retract (pow A) (pow B))) as [(f0,g0,e) | hf].
  exists f0 g0; trivial.
  exists (fun (x:pow A) (y:B) => F) (fun (x:pow B) (y:A) => F); intros;
    destruct hf; auto.
Qed.

(** The paradoxical set *)
Definition U := forall P:Prop, pow P.

(** Bijection between [U] and [(pow U)] *)
Definition f (u:U) : pow U := u U.

Definition g (h:pow U) : U :=
  fun X => let lX := j2 (L1 X U) in let rU := i2 (L1 U U) in lX (rU h).

(** We deduce that the powerset of [U] is a retract of [U].
    This lemma is stated in Berardi's article, but is not used
    afterwards. *)
Lemma retract_pow_U_U : retract (pow U) U.
Proof.
exists g f.
intro a.
unfold f, g in |- *; simpl in |- *.
apply AC.
exists (fun x:pow U => x) (fun x:pow U => x).
trivial.
Qed.

(** Encoding of Russel's paradox *)

(** The boolean negation. *)
Definition Not_b (b:Bool) := IFProp (b = T) F T.

(** the set of elements not belonging to itself *)
Definition R : U := g (fun u:U => Not_b (u U u)).

Lemma not_has_fixpoint : R R = Not_b (R R).
Proof.
unfold R at 1 in |- *.
unfold g in |- *.
rewrite AC with (r := L1 U U) (a := fun u:U => Not_b (u U u)).
trivial.
exists (fun x:pow U => x) (fun x:pow U => x); trivial.
Qed.

Theorem classical_proof_irrelevence : T = F.
Proof.
generalize not_has_fixpoint.
unfold Not_b in |- *.
apply AC_IF.
intros is_true is_false.
elim is_true; elim is_false; trivial.

intros not_true is_true.
elim not_true; trivial.
Qed.

End Berardis_paradox.


Section on_ex.
  Variables
   (A:Type)
   (P Q:A -> Prop).

 Lemma ex_or : (exists x:A, P x \/ Q x) -> ex P \/ ex Q.
 Proof.
  intro H; elim H; intros x [H1|H1].
  left ; exists x; trivial.
  right ; exists x; trivial.
 Qed.

 Lemma ex_or_R : ex P \/ ex Q -> (exists x:A, P x \/ Q x).
 Proof.
  intros [H | H]; case H; intros x Hx; exists x; auto.
 Qed.

 Lemma two_is_three : (exists x:A, forall R : A->Prop, R x) -> 2 = 3.
 Proof.
  intro H; elim H; intros x Hx.
  elim (Hx (fun y:A => False)).
 Qed.

 Lemma forall_no_ex : (forall x:A, P x) -> ~(exists y:A, ~ P y).
 Proof.
  intros H H0; elim H0.
  intros x Hx; apply Hx ; apply H.
 Qed.

End on_ex.


(*********************************************)
(* This file is part of the 'Higman' contrib *)
(* file : tree.v                             *)
(* contains : tree definition and its        *)
(*  associated induction principle           *)
(* author : W.Delobel                        *)
(*********************************************)

Set Implicit Arguments.
Require Export Arith.
Require Export List.

Section Wrap.

    Unset Elimination Schemes.

    Variable A : Set.
    Variable leA : A -> A -> Prop.

    Inductive tree : Set :=
      | node : A -> list tree -> tree.

Section definitions.

    Fixpoint tree_size (t : tree) : nat :=
      match t with
	| node _ l => S ((fix l_size (l : list tree) : nat :=
			    match l with
			      | nil => 0
			      | t' :: l' => (tree_size t') + (l_size l')
			    end) l)
      end.

   Definition root (t : tree) : A :=
	match t with
	| node a l => a
	end.

   Definition subtrees (t : tree) : list tree :=
	match t with
	| node _ l => l
	end.

Inductive tree_in_forest : tree -> list tree -> Prop :=
| tif0 : forall t t' l, In t' l -> subtree t t' -> tree_in_forest t l
with subtree : tree -> tree -> Prop :=
| sub0 : forall t, subtree t t
| sub1 : forall t l ts, tree_in_forest t ts -> subtree t (node l ts).

End definitions.

Section tree_rect.

    Variables
      (P : tree -> Type)
      (Q : list tree -> Type).

    Hypotheses
      (H1 : forall x, P (node x nil))
      (H2 : forall f v, Q v -> P (node f v))
      (H3 : Q nil)
      (H4 : forall t v, P t -> Q v -> Q (t :: v)).

    Fixpoint tree_rect_aux t : P t :=
      match t as t return P t with
	| node f v => H2 f
	  ((fix vt_rect (v : list tree) : Q v :=
	    match v as v return Q v with
	      | nil => H3
	      | cons t' v' => H4 (tree_rect_aux t') (vt_rect v')
	    end) v)
      end.

End tree_rect.

Set Elimination Schemes.

Inductive lforall (P : tree -> Type) : list tree -> Type :=
| lforall_nil : lforall P nil
| lforall_cons : forall a l, lforall P l -> P a -> lforall P (a::l).

Lemma tree_rect : forall P : tree -> Type,
      (forall x, P (node x nil)) -> (forall f v, lforall P v -> P (node f v)) ->
      forall t, P t.
Proof.
	intros P H1 H2.
	apply tree_rect_aux with (Q := fun l => lforall P l); trivial.
	constructor.
	intros; constructor; trivial.
Qed.

Lemma tree_ind : forall P : tree -> Prop,
	(forall x, P (node x nil)) -> (forall f v, (forall u, In u v -> P u) -> P (node f v)) ->
	forall t, P t.
Proof.
	intros P H1 H2.
	apply tree_rect; trivial.
	intros f v H; apply H2.
	induction H; intros u Hu.
	inversion Hu.
	elim Hu; clear Hu; intro Hu.
	subst; trivial.
	apply IHlforall; trivial.
Qed.

Fact im_sub_tree_size : forall a l t, In t l -> (tree_size t) < (tree_size (node a l)).
Proof.
	intros a l; induction l as [| u l IHl]; intros t Hin.
	inversion Hin.
	elim Hin; clear Hin; intro Hin.
	subst; simpl in |- *.
	apply lt_le_trans with (S (tree_size t)); auto with arith.
	apply lt_le_trans with (tree_size (node a l)); auto with arith.
	simpl; auto with arith.
Qed.

Fact subtree_trans : forall t t' t'', subtree t t' -> subtree t' t'' -> subtree t t''.
Proof.
assert (H : forall t'' t', subtree t' t'' -> forall t, subtree t t' -> subtree t t'').
intro t; induction t as [a | a f IHt]; intros t' H1 t'' H2.
inversion H1; subst; trivial.
inversion H3; subst; trivial.
inversion H.
inversion H1; subst; trivial.
constructor 2.
inversion H3; subst.
constructor 1 with t'0; trivial.
apply IHt with t'; trivial.
intros t t' t'' H1 H2; apply H with t'; trivial.
Qed.

Fact eq_tree_dec : (forall (a a' : A), {a = a'} + {a <> a'}) ->
forall (t t' : tree), {t = t'} + {t <> t'}.
Proof.
intro eq_A_dec; apply (tree_rect (P:=fun t => forall (t' : tree), {t = t'} + {t <> t'})).
intros a t'; destruct t' as [a' ts'].
destruct ts'; [idtac | right; intro HF; inversion HF].
elim (eq_A_dec a a'); intro case_a_a'; [left | right; intro HF; apply case_a_a']; subst; trivial.
inversion HF; trivial.
intros a ts IHt t'; destruct t' as [a' ts'].
elim (eq_A_dec a a'); intro case_a_a'; [subst a'|right;intro HF;inversion HF;apply case_a_a'; trivial].
assert (H : {ts = ts'} + {ts <> ts'}).
generalize ts'; clear ts'; induction IHt; intro ts'.
destruct ts' as [| t' ts']; [left | right]; trivial.
intro HF; inversion HF.
destruct ts' as [| t' ts']; [right | idtac]; trivial.
intro HF; inversion HF.
elim (IHIHt ts'); intro case_ts'.
subst; elim (p t'); intro case_t'; subst; [left | right]; trivial.
intro HF; inversion HF; apply case_t'; trivial.
right; intro HF; inversion HF; apply case_ts'; trivial.
elim H; clear H; intro H; [left; subst | right]; trivial.
intro HF; inversion HF; apply H; trivial.
Qed.

End Wrap.


Require Import Shor.
Require Import euler.Primes.
Require Import euler.AltPrimes.
Require Import SQIR.ExtractionGateSet.
Require Import ExtrShor Reduction.
Require Import QuantumLib.DiscreteProb.

(* The end-to-end definition of Shor's algorithm, combining the facts from
   Shor.v and ShorAux.v into a digestable form. *)

(** Coq definitions that will be extracted to OCaml **)

(* given r = ord(a,N), try to find a factor of N (based on Shor.Factor_post) *)
Definition factor (a N r : nat) :=
  let cand1 := Nat.gcd (a ^ (r / 2) - 1) N in
  let cand2 := Nat.gcd (a ^ (r / 2) + 1) N in
  if (1 <? cand1) && (cand1 <? N) then Some cand1      (* candidate #1 is a factor *)
  else if (1 <? cand2) && (cand2 <? N) then Some cand2 (* candidate #2 is a factor *)
  else None.                                           (* failed to find factor *)

(* End-to-end definition of Shor's algorithm.

   Inputs:
     N = number to factor
     rnds = stream of random real values
     i = index into rnds
     niter = max number of iterations

   Output:
     None or Some x where x is a nontrivial factor of N.

   Algorithm: Up to a maximum number of iterations, select "a" uniformly from
   [1,n-1] and
     1. Run the circuit generated by (shor_circuit a N) on input  ∣0⟩_{n + k}.
     2. Measure the first n qubits, resulting in the n-bit number x.
     3. Run continued fraction expansion (= OF_post) to get r, which is a
        candidate for the order (ord a N).
     4. Use r to try to factor N.

  The probability of success (returning Some) and the resources (aka qubits and
  gates) used is a function of N and niter (see proofs below). *)

(* We will customize the extraction of this function to avoid extracting our
   uc_eval function, which relies on an inefficient representation of matrices. *)
Definition run n (c : ucom U) rnd : nat :=
  sample (apply_u (UnitarySem.uc_eval (to_base_ucom n c))) rnd.

(* N   : number to factor
   rnd : source of randomness for sampling *)
Definition shor_body N rnd :=
  let n := shor_output_nqs N in
  let k := modmult_nqs N in
  (* create a uniform distribution *)
  let adist := uniform 1 N in
  (* use rnd to sample from adist *)
  let a := sample adist rnd in
  (* do a and N share a factor? *)
  if Nat.gcd a N =? 1%nat
  (* if not, use a to construct a quantum circuit*)
  then let c := shor_circuit a N in
       (* get the leftover randomness to sample from the circuit's output *)
       let rnd' := compute_new_rnd rnd adist a in
       (* run the circuit *)
       let x := run (shor_nqs N) c rnd' in
       (* try to factor *)
       factor a N (OF_post a N (fst k x) n)
  else Some (Nat.gcd a N).

Definition end_to_end_shors N rnds :=
  iterate rnds (shor_body N).

(** Correctness properties for Shor's **)

Definition coprime (a b : nat) : Prop := Nat.gcd a b = 1%nat.

(* The probability that shor_body returns ord(a,N) is at least κ / (Nat.log2 N)^4
   where κ is about 0.055 (see Shor.Shor_correct_full). *)
Lemma shor_body_returns_order : forall (a N : nat),
  (0 < a < N)%nat ->
  coprime a N ->
  let n := shor_output_nqs N in
  let k := modmult_nqs N in
  let circ := to_base_ucom (n + k) (shor_circuit a N) in
  pr_outcome_sum
      (apply_u (UnitarySem.uc_eval circ))
      (fun x => OF_post a N (fst k x) n =? ord a N)
    >= κ / INR (Nat.log2 N)^4.
Proof.
  intros a N Ha1 Ha2 n k circ.
  subst circ.
  remember (fun x => OF_post a N x n =? ord a N) as f'.
  replace (fun x : nat => OF_post a N (fst k x) n =? ord a N)
    with (fun x : nat => f' (fst k x)).
  rewrite rewrite_pr_outcome_sum.
  specialize (Shor.Shor_correct a N Ha1 Ha2) as H1.
  specialize (shor_circuit_same' a N) as H2.
  unfold prob_shor_outputs in H2.
  erewrite big_sum_eq_bounded.
  2: { intro i. rewrite H2. reflexivity. lia. }
  unfold probability_of_success in H1.
  unfold r_found in H1.
  subst f'.
  apply H1.
  apply WF_uc_eval.
  subst f'.
  reflexivity.
Qed.

Definition leads_to_factor N a :=
  nontrivgcd a N ||
  (nontrivgcd (a ^ ((ord a N) / 2)%nat - 1) N ||
   nontrivgcd (a ^ ((ord a N) / 2)%nat + 1) N).

(* Assuming that N is not prime, not even, and not a power of a prime, for a
   random choice of a, the probability that ord(a,N) can be used to find a
   factor is at least 1/2. *)
Lemma shor_factoring_succeeds : forall N,
  ~ (prime N) -> Nat.Odd N -> (forall p k, prime p -> N <> p ^ k)%nat ->
   pr_outcome_sum
     (uniform 1 N)
     (fun x => leads_to_factor N x)
   >= 1 / 2.
Proof.
  intros.
  apply simplify_primality in H; trivial. clear H0 H1.
  destruct H as [p [k [q [H0 [H1 [H3 [H4 [H5 H6]]]]]]]].
  assert (H :( N - 1 <= 2 * count1 (leads_to_factor N) (N - 1))%nat).
  subst N.
  apply reduction_factor_order_finding; auto.
  assert (2 < N)%nat.
  subst N.
  rewrite <- (Nat.mul_1_l 2).
  apply Nat.mul_lt_mono_nonneg; try lia.
  apply Nat.pow_gt_1; lia.
  rewrite pr_outcome_sum_count by lia.
  unfold count1 in *. erewrite count_eq.
  2 : { intros x Hx. replace (2 + x - 1)%nat with (x + 1)%nat by lia. reflexivity. }
  rewrite count_eq with (g := leads_to_factor N).
  apply le_INR in H. rewrite mult_INR in H. replace (INR 2) with 2 in H by easy.
  unfold Rdiv.
  assert (0 < INR (N - 1)).
  { apply lt_0_INR. lia. }
  assert (0 < / INR (N - 1)).
  { apply Harmonic.INR_inv_pos. lia. }
  apply Rmult_le_compat_r with (r := (/ INR (N - 1))%R) in H; try lra.
  rewrite Rinv_r in H by lra.
  apply Rmult_le_compat_l with (r := 2%R) in H; try lra.
  intros. f_equal. lia.
Qed.

Definition is_a_factor x y := exists z, (1 < z < y)%nat /\ y = (z * x)%nat.

Lemma gcd_is_factor : forall x y, (1 < Nat.gcd x y < y)%nat -> is_a_factor (Nat.gcd x y) y.
Proof.
  intros x y H.
  unfold is_a_factor.
  specialize (Nat.gcd_divide_r x y) as G. destruct G.
  exists x0.
  split; try lia.
  split; nia.
Qed.

Lemma factor_returns_factor : forall a N r x,
  factor a N r = Some x -> is_a_factor x N.
Proof.
  intros a N r x H.
  unfold factor in H.
  remember (Nat.gcd (a ^ (r / 2) - 1) N) as k1.
  remember (Nat.gcd (a ^ (r / 2) + 1) N) as k2.
  bdestruct (1 <? k1); bdestruct (k1 <? N);
    bdestruct (1 <? k2); bdestruct (k2 <? N);
    simpl in H; inversion H; subst;
    apply gcd_is_factor; auto.
Qed.

Lemma end_to_end_shors_correct : forall N rnds x,
    (1 < N)%nat ->
    (Forall (fun x => 0 <= x < 1) rnds) ->
    end_to_end_shors N rnds = Some x ->
    is_a_factor x N.
Proof.
  intros N rnds x H Hrnds H0.
  unfold end_to_end_shors in H0.
  induction rnds as [ | rnd rnds]; intros.
  inversion H0.
  simpl in H0.
  destruct (shor_body N rnd) eqn:sb; auto.
  inversion H0; subst.
  unfold shor_body in sb.
  remember (sample (uniform 1 N) rnd) as a.
  bdestruct (Nat.gcd a N =? 1).
  apply factor_returns_factor in sb.
  auto.
  inversion sb.
  apply gcd_is_factor.
  assert (1 <= a < N)%nat.
  { rewrite Heqa.
    inversion Hrnds.
    apply sample_uniform; auto.
  }
  assert (0 < Nat.gcd a N)%nat.
  apply Natgcd_pos; lia.
  assert (Nat.gcd a N <= a)%nat.
  rewrite Nat.gcd_comm.
  apply Misc.Nat_gcd_le_r.
  lia.
  lia.
  inversion Hrnds. apply IHrnds; assumption.
Qed.

(* For the rest of the proof, it is convenient to use a version
   of shor_body that explicitly constructs the joint distribution. *)
Definition process N out :=
  let n := shor_output_nqs N in
  let k := modmult_nqs N in
  let a := fst (n + k) out in
  let x := snd (n + k) out in
  if Nat.gcd a N =? 1%nat
  then factor a N (OF_post a N (fst k x) n)
  else Some (Nat.gcd a N).

Definition shor_joint_distr N :=
  join (uniform 1 N)
       (fun a => apply_u (uc_eval (shor_nqs N) (shor_circuit a N))).

Definition shor_body_alt N rnd :=
  let out := sample (shor_joint_distr N) rnd in
  process N out.

Lemma shor_body_alt_same : forall N rnd,
  (1 < N)%nat ->
  0 <= rnd < 1 ->
  shor_body N rnd = shor_body_alt N rnd.
Proof.
  intros.
  assert (Hun : distribution (uniform 1 N)).
  apply distribution_uniform. auto.
  destruct Hun as [Hun1 Hun2].
  unfold shor_body, shor_body_alt, shor_joint_distr, process.
  rewrite fst_sample_join, snd_sample_join.
  reflexivity.
  rewrite Hun2. auto.
  apply Hun1.
  intro k. apply length_apply_u.
  intros k Hk.
  apply distribution_apply_u.
  apply uc_eval_unitary.
  apply uc_well_typed_shor_circuit.
  rewrite length_uniform in Hk; lia.
  lra.
  apply Hun1.
  intro k. apply length_apply_u.
  intros k Hk.
  apply distribution_apply_u.
  apply uc_eval_unitary.
  apply uc_well_typed_shor_circuit.
  rewrite length_uniform in Hk; lia.
Qed.

Lemma shor_body_succeeds_with_high_probability' : forall N,
    ~ (prime N) -> Nat.Odd N -> (forall p k, prime p -> N <> p ^ k)%nat ->
    let n := shor_output_nqs N in
    let k := modmult_nqs N in
    let distr := shor_joint_distr N in
    let f1 a := leads_to_factor N a in
    let f2 a x := (OF_post a N (fst k x) n =? ord a N) ||
                  negb (Nat.gcd a N =? 1) in
    pr_outcome_sum distr
      (fun z => let x := fst (n + k) z in
             let y := snd (n + k) z in
             f1 x && f2 x y)
      >= (1 / 2) * (κ / INR (Nat.log2 N)^4).
Proof.
  intros.
  assert (H1N : (1 < N)%nat).
  { destruct N. inversion H0. lia.
    destruct N. destruct (infinitely_many_primes 1%nat) as [p [Hp1 Hp2]].
    specialize (H1 p O Hp2). simpl in H1. lia. lia.
  }
  assert (ILog : (1 <= Nat.log2 N)%nat).
  { specialize (Nat.log2_pos N) as G. lia.
  }
  specialize (κn4in01 (Nat.log2 N) ILog) as G.
  apply pr_outcome_sum_join_geq.
  apply distribution_uniform.
  apply H1N.
  lra.
  apply shor_factoring_succeeds; auto.
  intros i Hi.
  split.
  apply length_apply_u.
  subst f2.
  assert (Hdist : distribution (apply_u (UnitarySem.uc_eval (to_base_ucom (n + k) (shor_circuit i N))))).
  { apply distribution_apply_u.
    apply uc_eval_unitary.
    apply uc_well_typed_shor_circuit.
    rewrite length_uniform in Hi.
    lia.
    lia.
  }
  bdestruct (Nat.gcd i N =? 1).
  eapply Rge_trans.
  apply Rle_ge.
  apply pr_outcome_sum_orb.
  destruct Hdist as [Hdist _]; auto.
  apply shor_body_returns_order.
  split.
  destruct i. simpl in H2. lia. lia.
  rewrite length_uniform in Hi. lia. lia.
  unfold coprime.
  assumption.
  rewrite pr_outcome_sum_true.
  destruct Hdist as [_ Hdist].
  subst n k.
  unfold uc_eval.
  unfold shor_nqs.
  rewrite Hdist.
  lra.
  intros j Hj.
  bdestruct (Nat.gcd i N =? 1).
  easy.
  simpl. rewrite orb_true_r. reflexivity.
Qed.

Lemma shor_body_succeeds_with_high_probability : forall N,
    ~ (prime N) -> Nat.Odd N -> (forall p k, prime p -> N <> p ^ k)%nat ->
    let n := shor_output_nqs N in
    let k := modmult_nqs N in
    let distr := shor_joint_distr N in
    pr_outcome_sum distr (fun x => negb (isNone (process N x)))
      >= (1 / 2) * (κ / INR (Nat.log2 N)^4).
Proof.
  intros N HN1 HN2 HN3 n k distr.
  assert (H1N : (1 < N)%nat).
  { destruct N. inversion HN2. lia.
    destruct N. destruct (infinitely_many_primes 1%nat) as [p [Hp1 Hp2]].
    specialize (HN3 p O Hp2). simpl in HN3. lia. lia.
  }
  assert (Hdist: distribution distr).
  subst distr.
  apply distribution_join.
  apply distribution_uniform.
  lia.
  intros i Hi.
  apply distribution_apply_u.
  apply uc_eval_unitary.
  apply uc_well_typed_shor_circuit.
  rewrite length_uniform in Hi.
  lia.
  lia.
  apply Rle_ge.
  eapply Rle_trans.
  apply Rge_le.
  apply shor_body_succeeds_with_high_probability'; auto.
  apply pr_outcome_sum_implies.
  destruct Hdist as [Hdist _]; auto.
  simpl.
  intros x H.
  unfold process.
  subst n k.
  remember (fst (shor_output_nqs N + modmult_nqs N) x) as a.
  remember (snd (shor_output_nqs N + modmult_nqs N) x) as y.
  clear - H.
  destruct (Nat.gcd a N =? 1) eqn:E; auto.
  apply beq_nat_true in E.
  apply andb_prop in H as [H1 H2].
  simpl in H2. rewrite orb_false_r in H2.
  apply beq_nat_true in H2. rewrite H2.
  unfold factor.
  unfold leads_to_factor in H1.
  remember (a ^ (ord a N / 2) + 1)%nat as ap1.
  remember (a ^ (ord a N / 2) - 1)%nat as am1.
  replace ((1 <? Nat.gcd am1 N) && (Nat.gcd am1 N <? N)) with (nontrivgcd am1 N) by (unfold nontrivgcd; reflexivity).
  replace ((1 <? Nat.gcd ap1 N) && (Nat.gcd ap1 N <? N)) with (nontrivgcd ap1 N) by (unfold nontrivgcd; reflexivity).
  destruct (nontrivgcd am1 N). easy.
  destruct (nontrivgcd ap1 N). easy.
  simpl in H1. rewrite orb_false_r in H1.
  unfold nontrivgcd, nontriv in H1. rewrite E in H1. simpl in H1. easy.
Qed.

Lemma shor_body_fails_with_low_probability : forall N,
    ~ (prime N) -> Nat.Odd N -> (forall p k, prime p -> N <> p ^ k)%nat ->
    let n := shor_output_nqs N in
    let k := modmult_nqs N in
    let distr := shor_joint_distr N in
    pr_outcome_sum distr (fun x => isNone (process N x))
      <= 1 - (1 / 2) * (κ / INR (Nat.log2 N)^4).
Proof.
  intros.
  assert (H1N : (1 < N)%nat).
  { destruct N. inversion H0. lia.
    destruct N. destruct (infinitely_many_primes 1%nat) as [p [Hp1 Hp2]].
    specialize (H1 p O Hp2). simpl in H1. lia. lia.
  }
  rewrite pr_outcome_sum_negb.
  specialize (shor_body_succeeds_with_high_probability N H H0 H1) as G.
  assert (distribution distr).
  { apply distribution_join.
    apply distribution_uniform.
    lia.
    intros.
    apply distribution_apply_u.
    apply uc_eval_unitary.
    apply uc_well_typed_shor_circuit.
    rewrite length_uniform in H2. lia.
    lia.
  }
  destruct H2. rewrite H3.
  assert (forall r1 r2 r3, r2 >= r3 -> r1 - r2 <= r1 - r3)%R by (intros; lra).
  apply H4. apply G.
Qed.

(* For n iterations of end_to_end_shors, the probability of success is
   1 - (1 - ((1 / 2) * (κ / INR (Nat.log2 N)^4))^n). *)
Local Opaque pow leads_to_factor.
Lemma end_to_end_shors_fails_with_low_probability : forall N niter r,
  ~ (prime N) -> Nat.Odd N -> (forall p k, prime p -> N <> p ^ k)%nat ->
  pr_Ps (fun rnds => isNone (end_to_end_shors N rnds) = true) niter r ->
  (r <= (1 - (1 / 2) * (κ / INR (Nat.log2 N)^4))^niter)%R.
Proof.
  intros N niter r HN1 HN2 HN3 H.
  assert (H1N : (1 < N)%nat).
  { destruct N. inversion HN2. lia.
    destruct N. destruct (infinitely_many_primes 1%nat) as [p [Hp1 Hp2]].
    specialize (HN3 p O Hp2). simpl in HN3. lia. lia.
  }
  unfold end_to_end_shors in H.
  apply pr_Ps_same
    with (Ps2:=fun rnds => isNone (iterate rnds (shor_body_alt N)) = true) in H.
  specialize (shor_body_fails_with_low_probability N HN1 HN2 HN3) as Hbody.
  apply pr_outcome_sum_leq_exists in Hbody.
  destruct Hbody as [r0 [? ?]].
  apply pr_iterate_None with (n := niter) in H1.
  eapply pr_Ps_unique in H.
  2: apply H1.
  subst r.
  remember (1 / 2 * (κ / INR (Nat.log2 N) ^ 4)) as β.
  clear H1.
  apply pow_incr.
  assumption.
  apply distribution_join.
  apply distribution_uniform.
  lia.
  intros i Hi.
  apply distribution_apply_u.
  apply uc_eval_unitary.
  apply uc_well_typed_shor_circuit.
  rewrite length_uniform in Hi.
  auto.
  lia.
  intros rnds Hrnds.
  rewrite iterate_replace_body with (body':=shor_body_alt N); auto.
  reflexivity.
  intros.
  apply shor_body_alt_same; auto.
Qed.


Require Import DecidabilityFacts SemiDecidabilityFacts.
Require Cantor.
Require Import FinTypesDef.

Local Notation "'if!' x 'is' p 'then' a 'else' b" := (match x with p => a | _ => b end) (at level 0, p pattern).

Lemma enumerable_semi_decidable {X} {p : X -> Prop} :
  discrete X -> enumerable p -> semi_decidable p.
Proof.
  unfold enumerable, enumerator.
  intros [d Hd] [f Hf].
  exists (fun x n => if! f n is Some y then d (x,y) else false).
  intros x. rewrite Hf. split.
  - intros [n Hn]. exists n.
    rewrite Hn. now eapply Hd.
  - intros [n Hn]. exists n.
    destruct (f n); inversion Hn.
    eapply Hd in Hn. now subst.
Qed.

Definition enumerator__T' X f := forall x : X, exists n : nat, f n = Some x.
Notation enumerator__T f X := (enumerator__T' X f).
Definition enumerable__T X := exists f : nat -> option X, enumerator__T f X.

Lemma semi_decider_enumerator {X} {p : X -> Prop} {e f} :
  enumerator__T e X -> semi_decider f p -> {g | enumerator g p}.
Proof.
  unfold semi_decider. intros He Hf.
  exists (fun p => let (n, m) := Cantor.of_nat p in
           if! e n is Some x then if f x m then Some x else None else None).
  intros x. rewrite Hf. split.
  - intros [n Hn]. destruct (He x) as [m Hm].
    exists (Cantor.to_nat (m,n)). now rewrite Cantor.cancel_of_to, Hm, Hn.
  - intros [mn Hmn]. destruct (Cantor.of_nat mn) as (m, n).
    destruct (e m) as [x'|]; try congruence.
    destruct (f x' n) eqn:E; inversion Hmn. subst.
    exists n. exact E.
Qed.

Lemma semi_decidable_enumerable {X} {p : X -> Prop} :
  enumerable__T X -> semi_decidable p -> enumerable p.
Proof.
  intros [e He] [f Hf].
  destruct (semi_decider_enumerator He Hf) as [g Hg].
  now exists g.
Qed.

Theorem dec_count_enum {X} {p : X -> Prop} :
  decidable p -> enumerable__T X -> enumerable p.
Proof.
  intros ? % decidable_semi_decidable ?.
  now eapply semi_decidable_enumerable.
Qed.

Theorem dec_count_enum' X (p : X -> Prop) :
  decidable p -> enumerable__T X -> enumerable (fun x => ~ p x).
Proof.
  intros ? % dec_compl ?. eapply dec_count_enum; eauto.
Qed.

Lemma enumerable_enumerable_T X :
  enumerable (fun _ : X => True) <-> enumerable__T X.
Proof.
  split.
  - intros [e He]. exists e. intros x. now eapply He.
  - intros [c Hc]. exists c. intros x. split; eauto.
Qed.

(* Type enumerability facts  *)

Definition nat_enum (n : nat) := Some n.
Lemma enumerator__T_nat :
  enumerator__T nat_enum nat.
Proof.
  intros n. cbv. eauto.
Qed.

Definition unit_enum (n : nat) := Some tt.
Lemma enumerator__T_unit :
  enumerator__T unit_enum unit.
Proof.
  intros []. cbv. now exists 0.
Qed.

Definition bool_enum (n : nat) := Some (if! n is 0 then true else false).
Lemma enumerator__T_bool :
  enumerator__T bool_enum bool.
Proof.
  intros []. cbv.
  - now exists 0.
  - now exists 1.
Qed.

Definition prod_enum {X Y} (f1 : nat -> option X) (f2 : nat -> option Y) n : option (X * Y) :=
  let (n, m) := Cantor.of_nat n in
  if! (f1 n, f2 m) is (Some x, Some y) then Some (x, y) else None.
Lemma enumerator__T_prod {X Y} f1 f2 :
  enumerator__T f1 X -> enumerator__T f2 Y ->
  enumerator__T (prod_enum f1 f2) (X * Y).
Proof.
  intros H1 H2 (x, y).
  destruct (H1 x) as [n1 Hn1], (H2 y) as [n2 Hn2].
  exists (Cantor.to_nat (n1, n2)). unfold prod_enum.
  now rewrite Cantor.cancel_of_to, Hn1, Hn2.
Qed.

Definition option_enum {X} (f : nat -> option X) n :=
  match n with 0 => Some None | S n => Some (f n) end.
Lemma enumerator__T_option {X} f :
  enumerator__T f X -> enumerator__T (option_enum f) (option X).
Proof.
  intros H [x | ].
  - destruct (H x) as [n Hn]. exists (S n). cbn. now rewrite Hn.
  - exists 0. reflexivity.
Qed.

Definition sigT_enum {X: Type} {P : X -> Type}
  (f : nat -> option X) (fP : forall x, nat -> option (P x)) (n : nat) :
    option {x : X & P x} :=
  let (nx, nP) := Cantor.of_nat n in
  match f nx with
  | Some x =>
    match fP x nP with
    | Some y => Some (existT P x y)
    | _ => None
    end
  | None => None
  end.
Lemma enumerator__T_sigT {X: Type} {P : X -> Type} f fP :
  enumerator__T f X -> (forall x, enumerator__T (fP x) (P x)) ->
  enumerator__T (sigT_enum f fP) {x : X & P x}.
Proof.
  intros Hf HfP [x HPx].
  destruct (Hf x) as [nx Hnx].
  destruct (HfP x (HPx)) as [nP HnP].
  exists (Cantor.to_nat (nx, nP)).
  unfold sigT_enum.
  now rewrite !Cantor.cancel_of_to, Hnx, HnP.
Qed.

Definition sigT2_enum {X: Type} {P : X -> Type} {Q : X -> Type}
  (f : nat -> option X) (fP : forall x, nat -> option (P x)) (fQ : forall x, nat -> option (Q x)) (n : nat) :
    option {x : X & P x & Q x} :=
  let (nx, m) := Cantor.of_nat n in
  let (nP, nQ) := Cantor.of_nat m in
  match f nx with
  | Some x =>
    match fP x nP, fQ x nQ with
    | Some y, Some z => Some (existT2 P Q x y z)
    | _, _ => None
    end
  | None => None
  end.
Lemma enumerator__T_sigT2 {X: Type} {P : X -> Type} {Q : X -> Type} f fP fQ :
  enumerator__T f X -> (forall x, enumerator__T (fP x) (P x)) -> (forall x, enumerator__T (fQ x) (Q x)) ->
  enumerator__T (sigT2_enum f fP fQ) {x : X & P x & Q x}.
Proof.
  intros Hf HfP HfQ [x HPx HQx].
  destruct (Hf x) as [nx Hnx].
  destruct (HfP x (HPx)) as [nP HnP].
  destruct (HfQ x (HQx)) as [nQ HnQ].
  exists (Cantor.to_nat (nx, Cantor.to_nat (nP, nQ))).
  unfold sigT2_enum.
  now rewrite !Cantor.cancel_of_to, Hnx, HnP, HnQ.
Qed.

Require Import List.

Definition finType_enum {X: finType} (n : nat) : option X :=
  nth_error (@enum _ (class X)) n.
Lemma enumerator__T_finType {X: finType} :
  enumerator__T finType_enum X.
Proof.
  intros x.
  assert (H := (@enum_ok _ (class X)) x).
  unfold finType_enum. induction enum as [|y L IH].
  - easy.
  - cbn in H. destruct (Dec (x = y)) as [->|H'].
    + now exists 0.
    + destruct (IH H) as [n Hn]. now exists (S n).
Qed.

Fixpoint all_fins (n : nat) : list (Fin.t n) :=
  match n with
  | 0 => nil
  | S n => Fin.F1 :: map Fin.FS (all_fins n)
  end.

Definition Fin_enum {k: nat} (n : nat) : option (Fin.t k) :=
  nth_error (all_fins k) n.
Lemma enumerator__T_Fin {k: nat} :
  enumerator__T Fin_enum (Fin.t k).
Proof.
  intros t. exists (proj1_sig (Fin.to_nat t)).
  unfold Fin_enum. induction t as [n|n t IH].
  { reflexivity. }
  cbn. destruct (Fin.to_nat t) as [t' H']. cbn in *.
  now rewrite nth_error_map, IH.
Qed.

Opaque Cantor.to_nat Cantor.of_nat.

Fixpoint Vector_enum {X: Type} {k: nat} (f : nat -> option X) (n : nat) : option (Vector.t X k) :=
  match k return option (Vector.t X k) with
  | 0 => Some (@Vector.nil X)
  | S k' =>
    let (nx, m) := Cantor.of_nat n in
    match f nx with
    | Some x =>
      match (@Vector_enum X k' f m) with
      | Some v => Some (@Vector.cons X x k' v)
      | _ => None
      end
    | None => None
    end
  end.
Lemma enumerator__T_Vector {X: Type} {k: nat} (f : nat -> option X) :
  enumerator__T f X -> enumerator__T (Vector_enum f) (Vector.t X k).
Proof.
  intros Hf. induction k as [|k IH].
  { intros t. pattern t. apply (Vector.case0). now exists 0. }
  intros t. rewrite (Vector.eta t).
  destruct (Hf (VectorDef.hd t)) as [nx Hnx].
  destruct (IH (VectorDef.tl t)) as [m Hm].
  exists (Cantor.to_nat (nx, m)).
  cbn. now rewrite Cantor.cancel_of_to, Hnx, Hm.
Qed.

Existing Class enumerator__T'.
(* Existing Class enumerable__T. *)

Lemma enumerator_enumerable {X} {f} :
  enumerator__T f X -> enumerable__T X.
Proof.
  intros H. exists f. eapply H.
Qed.
#[export] Hint Resolve enumerator_enumerable : core.

#[global] Existing Instance enumerator__T_prod.
#[global] Existing Instance enumerator__T_option.
#[global] Existing Instance enumerator__T_bool.
#[global] Existing Instance enumerator__T_nat.
#[global] Existing Instance enumerator__T_sigT.
#[global] Existing Instance enumerator__T_sigT2.
#[global] Existing Instance enumerator__T_finType.
#[global] Existing Instance enumerator__T_finType.
#[global] Existing Instance enumerator__T_Fin.
#[global] Existing Instance enumerator__T_Vector.


(** * Generation of Hoare proof obligations in partial correctness

 This file is part of the "Tutorial on Hoare Logic".
 For an introduction to this Coq library,
 see README #or index.html#.

 This file gives a syntactic definition of the weakest liberal precondition [wlp]
 introduced in ##[hoarelogicsemantics]##.
*)

Global Set Asymmetric Patterns.
Set Implicit Arguments.
Require Export hoarelogicsemantics.

Module PartialHoareLogic (HD: HoareLogicDefs).

Export HD.
Module HLD:=HD.

Definition sem_wp := wlp.

(** * Syntactic definition of the weakest liberal precondition.

 In the following, we show that this definition is logically
 equivalent to [wlp].
 *)
Fixpoint synt_wp (prog: ImpProg) : Pred -> Pred
 := fun post e =>
  match prog with
  | Iskip => post e
  | (Iset A x expr) => post (E.upd x (E.eval expr e) e)
  | (Iif cond p1 p2) =>
          ((E.eval cond e)=true -> (synt_wp p1 post e))
       /\ ((E.eval cond e)=false -> (synt_wp p2 post e))
  | (Iseq p1 p2) => synt_wp p1 (synt_wp p2 post) e
  | (Iwhile cond p) =>
        exists inv:Pred,
             (inv e)
          /\ (forall e', (inv e')
                  -> (E.eval cond e')=false -> (post e'))
          /\ (forall e', (inv e')
                  -> (E.eval cond e')=true -> (synt_wp p inv e'))
  end.

(** This property is also trivially satisfied by [wlp].
    We need it here to prove the soundness.
*)
Lemma synt_wp_monotonic:
  forall (p: ImpProg) (post1 post2: Pred),
   (post1 |= post2) -> (synt_wp p post1) |= (synt_wp p post2).
Proof.
  induction p; simpl; firstorder eauto with hoare.
Qed.

Hint Resolve synt_wp_monotonic: hoare.

(** * Soundness

    The proof of soundness proceeds by induction over the derivation
    [exec ... prog ...] in implicit hypothesis induced by [wlp] definition.

    Please, notice that coq performs the [exec_Iwhile] case alone (that's where
    monotonicity is used). Unfortunately, the case [exec_Iif] which seems
    trivial to a human is not discharged by Coq.
*)
Lemma wp_sound: forall prog post, synt_wp prog post |= prog{=post=}.
Proof.
 intros prog post e H0 e' H; generalize post H0; clear H0 post.
 elim H; clear H e' e prog; simpl; try ((firstorder eauto 20 with hoare); fail).
 (** - case [exec_Iif] *)
 intros e cond p1 p2 e'.
 case (E.eval cond e); simpl; firstorder auto.
Qed.

(** * Completeness

    The proof of completeness proceeds by induction over [prog] syntax.

    Please, notice that coq performs this proof almost alone. The only
    hint given here is the invariant.
*)
Lemma wp_complete: forall prog post, prog{=post=} |= (synt_wp prog post).
Proof.
 unfold wlp; intros prog; elim prog; clear prog; simpl;
 try ((firstorder auto with hoare); fail).
 (** - case [Iseq] *)
 eauto with hoare.
 (** - case [Iwhile]: I provide the invariant below *)
  intros.
  constructor 1 with (x:=wlp (Iwhile cond p) post).
  unfold wlp; intuition eauto 20 with hoare.
Qed.

(** * Combining the previous results with transitivity of [ |= ] *)

Hint Resolve wp_complete wp_sound: hoare.

Theorem soundness: forall pre p post, pre |= (synt_wp p post) -> pre |= p {=post=}.
Proof.
 auto with hoare.
Qed.

Theorem completeness: forall pre p post, pre |= p {=post=} -> pre |= (synt_wp p post).
Proof.
  intuition auto with hoare.
Qed.

End PartialHoareLogic.

(** "Tutorial on Hoare Logic" Library. Copyright 2007 Sylvain Boulme.

This file is distributed under the terms of the
 "GNU LESSER GENERAL PUBLIC LICENSE" version 3.
*)