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

 Initial objects in enriched categories

 We define the notion of initial objects in the context of
 enriched category theory. In ordinary category theory, an object
 is called initial if there is a unique morphism to every object
 in the category. To translate this concept to enriched category
 theory, we need to phrase this universal property in an arbitrary
 monoidal category instead of for sets.

 The idea is as follows. We want to say that an object `x` is
 initial. For every `y`, we have an object `C ⟦ x , y ⟧` in the
 monoidal category `V`. Then `x` is initial if this hom-object
 is a terminal object in `V`.

 Contents
 1. Initial objects in an enriched category
 2. Being initial is a proposition
 3. Accessors for initial objects
 4. Builders for initial objects
 5. Being initial is closed under iso
 6. Initial objects are isomorphic
 7. Enriched categories with a terminal object

 *****************************************************************)
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.Monoidal.Categories.
Require Import UniMath.CategoryTheory.EnrichedCats.Enrichment.
Require Import UniMath.CategoryTheory.limits.terminal.
Require Import UniMath.CategoryTheory.limits.initial.

Import MonoidalNotations.
Local Open Scope cat.
Local Open Scope moncat.

Section EnrichedInitial.
  Context {V : monoidal_cat}
          {C : category}
          (E : enrichment C V).

  (**
   1. Initial objects in an enriched category
   *)
  Definition is_initial_enriched
             (x : C)
    : UU
    := ∏ (y : C), isTerminal V (E ⦃ x , y ⦄).

  Definition initial_enriched
    : UU
    := ∑ (x : C), is_initial_enriched x.

  Coercion initial_enriched_to_ob
           (x : initial_enriched)
    : C
    := pr1 x.

  Coercion initial_enriched_to_is_initial
           (x : initial_enriched)
    : is_initial_enriched x
    := pr2 x.

  (**
   2. Being initial is a proposition
   *)
  Proposition isaprop_is_initial_enriched
              (x : C)
    : isaprop (is_initial_enriched x).
  Proof.
    do 2 (use impred ; intro).
    apply isapropiscontr.
  Qed.

  (**
   3. Accessors for initial objects
   *)
  Section Accessors.
    Context {x : C}
            (Hx : is_initial_enriched x).

    Definition is_initial_enriched_arrow
               (y : C)
      : I_{V} --> E ⦃ x , y ⦄
      := TerminalArrow (_ ,, Hx y) I_{V}.

    Definition is_initial_enriched_eq
               {y : C}
               (f g : I_{V} --> E ⦃ x , y ⦄)
      : f = g.
    Proof.
      apply (@TerminalArrowEq _ (_ ,, Hx y) I_{V}).
    Qed.

    Definition initial_underlying
      : Initial C.
    Proof.
      refine (x ,, _).
      intros y.
      use iscontraprop1.
      - abstract
          (use invproofirrelevance ;
           intros f g ;
           refine (!(enriched_to_from_arr E f) @ _ @ enriched_to_from_arr E g) ;
           apply maponpaths ;
           apply is_initial_enriched_eq).
      - exact (enriched_to_arr E (is_initial_enriched_arrow y)).
    Defined.
  End Accessors.

  (**
   4. Builders for initial objects
   *)
  Definition make_is_initial_enriched
             (x : C)
             (f : ∏ (w : V) (y : C), w --> E ⦃ x , y ⦄)
             (p : ∏ (w : V) (y : C) (f g : w --> E ⦃ x , y ⦄), f = g)
    : is_initial_enriched x.
  Proof.
    intros y w.
    use iscontraprop1.
    - abstract
        (use invproofirrelevance ;
         intros φ₁ φ₂ ;
         apply p).
    - apply f.
  Defined.

  Definition make_is_initial_enriched_from_iso
             (TV : Terminal V)
             (x : C)
             (Hx : ∏ (y : C),
                   is_z_isomorphism (TerminalArrow TV (E ⦃ x , y ⦄)))
    : is_initial_enriched x.
  Proof.
    intros y.
    use (iso_to_Terminal TV).
    exact (z_iso_inv (TerminalArrow TV (E ⦃ x , y ⦄) ,, Hx y)).
  Defined.

  Definition initial_enriched_from_underlying
             (TC : Initial C)
             (TV : Terminal V)
             (HV : conservative_moncat V)
    : is_initial_enriched TC.
  Proof.
    use (make_is_initial_enriched_from_iso TV).
    intro y.
    use HV.
    use isweq_iso.
    - intro f.
      apply enriched_from_arr.
      apply (InitialArrow TC).
    - abstract
        (intros f ; cbn ;
         refine (_ @ enriched_from_to_arr E f) ;
         apply maponpaths ;
         apply InitialArrowEq).
    - abstract
        (intros f ; cbn ;
         apply TerminalArrowEq).
  Defined.

  (**
   5. Being initial is closed under iso
   *)
  Definition initial_enriched_from_iso
             {x y : C}
             (Hx : is_initial_enriched x)
             (f : z_iso x y)
    : is_initial_enriched y.
  Proof.
    intros w.
    use (iso_to_Terminal (_ ,, Hx w)) ; cbn.
    exact (precomp_arr_z_iso E w (z_iso_inv f)).
  Defined.

  (**
   6. Initial objects are isomorphic
   *)
  Definition iso_between_initial_enriched
             {x y : C}
             (Hx : is_initial_enriched x)
             (Hy : is_initial_enriched y)
    : z_iso x y.
  Proof.
    use make_z_iso.
    - exact (enriched_to_arr E (is_initial_enriched_arrow Hx y)).
    - exact (enriched_to_arr E (is_initial_enriched_arrow Hy x)).
    - split.
      + abstract
          (refine (enriched_to_arr_comp E _ _ @ _ @ enriched_to_arr_id E _) ;
           apply maponpaths ;
           apply (is_initial_enriched_eq Hx)).
      + abstract
          (refine (enriched_to_arr_comp E _ _ @ _ @ enriched_to_arr_id E _) ;
           apply maponpaths ;
           apply (is_initial_enriched_eq Hy)).
  Defined.

  Definition isaprop_initial_enriched
             (HC : is_univalent C)
    : isaprop initial_enriched.
  Proof.
    use invproofirrelevance.
    intros φ₁ φ₂.
    use subtypePath.
    {
      intro.
      apply isaprop_is_initial_enriched.
    }
    use (isotoid _ HC).
    use iso_between_initial_enriched.
    - exact (pr2 φ₁).
    - exact (pr2 φ₂).
  Defined.
End EnrichedInitial.

(**
 7. Enriched categories with a terminal object
 *)
Definition cat_with_enrichment_initial
           (V : monoidal_cat)
  : UU
  := ∑ (C : cat_with_enrichment V), initial_enriched C.

Coercion cat_with_enrichment_initial_to_cat_with_enrichment
         {V : monoidal_cat}
         (C : cat_with_enrichment_initial V)
  : cat_with_enrichment V
  := pr1 C.

Definition initial_of_cat_with_enrichment
           {V : monoidal_cat}
           (C : cat_with_enrichment_initial V)
  : initial_enriched C
  := pr2 C.


Require Import GeoCoq.Tarski_dev.Definitions.

Section Euclid_def.

Context `{Tn:Tarski_neutral_dimensionless}.

(** First some statements needed for equivalence proofs
between different versions of the parallel postulate. *)

Definition decidability_of_parallelism := forall A B C D,
  Par A B C D \/ ~ Par A B C D.

Definition decidability_of_not_intersection := forall A B C D,
  ~ (exists I, Col I A B /\ Col I C D) \/
  ~ ~ (exists I, Col I A B /\ Col I C D).

Definition decidability_of_intersection := forall A B C D,
  (exists I, Col I A B /\ Col I C D) \/
  ~ (exists I, Col I A B /\ Col I C D).

(*
Definition decidability_of_intersection_in_a_plane :=
  forall A B C D,
  Coplanar A B C D ->
  (exists I, Col I A B /\ Col I C D) \/
  ~ (exists I, Col I A B /\ Col I C D).
*)

Definition tarski_s_parallel_postulate := forall A B C D T,
  Bet A D T -> Bet B D C -> A <> D ->
  exists X Y, Bet A B X /\ Bet A C Y /\ Bet X T Y.

(** This is uniqueness of parallel postulate. *)

Definition playfair_s_postulate := forall A1 A2 B1 B2 C1 C2 P,
  Par A1 A2 B1 B2 -> Col P B1 B2 ->
  Par A1 A2 C1 C2 -> Col P C1 C2 ->
  Col C1 B1 B2 /\ Col C2 B1 B2.

(** The sum of the angles of triangles is the flat angle.
    Notice that we do not use pi here,
    because defining angle measure requires some continuity axioms. *)

Definition triangle_postulate := forall A B C D E F,
  TriSumA A B C D E F -> Bet D E F.

(** A figure with three right angles is closed. *)

Definition bachmann_s_lotschnittaxiom := forall P Q R P1 R1,
  P <> Q -> Q <> R -> Per P Q R -> Per Q P P1 -> Per Q R R1 ->
  Coplanar P Q R P1 -> Coplanar P Q R R1 ->
  exists S, Col P P1 S /\ Col R R1 S.

(** Transitivity of parallelism. *)

Definition postulate_of_transitivity_of_parallelism := forall A1 A2 B1 B2 C1 C2,
  Par A1 A2 B1 B2 -> Par B1 B2 C1 C2 ->
  Par A1 A2 C1 C2.

(** This is the converse of triangle_mid_par. *)

Definition midpoint_converse_postulate := forall A B C P Q,
  ~ Col A B C ->
  Midpoint P B C -> Par A B Q P -> Col A C Q ->
  Midpoint Q A C.

(** This is the converse of l12_21_b.
    The alternate interior angles between two parallel lines are congruent. *)

Definition alternate_interior_angles_postulate := forall A B C D,
  TS A C B D -> Par A B C D ->
  CongA B A C D C A.

(** The consecutive interior angles between two parallel lines are supplementary. *)

Definition consecutive_interior_angles_postulate := forall A B C D,
  OS B C A D -> Par A B C D -> SuppA A B C B C D.

(** If two lines are parallel, every perpendicular to one of the lines is perpendicular to the other. *)

Definition perpendicular_transversal_postulate := forall A B C D P Q,
  Par A B C D -> Perp A B P Q -> Coplanar C D P Q ->
  Perp C D P Q.

(** Two lines, each perpendicular to one of a pair of parallel lines, are parallel. *)

Definition postulate_of_parallelism_of_perpendicular_transversals :=
  forall A1 A2 B1 B2 C1 C2 D1 D2,
    Par A1 A2 B1 B2 -> Perp A1 A2 C1 C2 -> Perp B1 B2 D1 D2 ->
    Coplanar A1 A2 C1 D1 -> Coplanar A1 A2 C1 D2 ->
    Coplanar A1 A2 C2 D1 -> Coplanar A1 A2 C2 D2 ->
    Par C1 C2 D1 D2.

(** If two lines are parallel then they are everywhere equidistant. *)

Definition universal_posidonius_postulate := forall A1 A2 A3 A4 B1 B2 B3 B4,
  Par A1 A2 B1 B2 ->
  Col A1 A2 A3 -> Col B1 B2 B3 -> Perp A1 A2 A3 B3 ->
  Col A1 A2 A4 -> Col B1 B2 B4 -> Perp A1 A2 A4 B4 ->
  Cong A3 B3 A4 B4.

(** A variant of Playfair's postulate useful in the proofs. *)

Definition alternative_playfair_s_postulate := forall A1 A2 B1 B2 C1 C2 P,
  Perp2 A1 A2 B1 B2 P -> ~ Col A1 A2 P -> Col P B1 B2 -> Coplanar A1 A2 B1 B2 ->
  Par A1 A2 C1 C2 -> Col P C1 C2 ->
  Col C1 B1 B2 /\ Col C2 B1 B2.

(** According to wikipedia:
"Proclus (410-485) wrote a commentary on The Elements where he comments on attempted proofs to deduce
 the fifth postulate from the other four, in particular he notes that Ptolemy had produced a false 'proof'.
 Proclus then goes on to give a false proof of his own.
 However he did give a postulate which is equivalent to the fifth postulate." *)

Definition proclus_postulate := forall A B C D P Q,
  Par A B C D -> Col A B P -> ~ Col A B Q -> Coplanar C D P Q ->
  exists Y, Col P Q Y /\ Col C D Y.

Definition alternative_proclus_postulate := forall A B C D P Q,
  Perp2 A B C D P -> ~ Col C D P -> Coplanar A B C D ->
  Col A B P -> ~ Col A B Q -> Coplanar C D P Q ->
  exists Y, Col P Q Y /\ Col C D Y.

(** Non degenerated triangles can be circumscribed. *)

Definition triangle_circumscription_principle := forall A B C,
  ~ Col A B C ->
  exists CC, Cong A CC B CC /\ Cong A CC C CC /\ Coplanar A B C CC.

(** For any given acute angle, any point together with
    its orthogonal projection on one side of the angle
    form a line which intersects the other side. *)

Definition inverse_projection_postulate := forall A B C P Q,
  Acute A B C ->
  Out B A P -> P <> Q -> Per B P Q -> Coplanar A B C Q ->
  exists Y, Out B C Y /\ Col P Q Y.

(** Given a non-degenerated parallelogram PRQS and a point U strictly between Q and R,
    the rays PU and SQ intersect beyond U and Q. *)

Definition euclid_5 := forall P Q R S T U,
  BetS P T Q -> BetS R T S -> BetS Q U R -> ~ Col P Q S ->
  Cong P T Q T -> Cong R T S T ->
  exists I, BetS S Q I /\ BetS P U I.

(** Given a non-degenerated parallelogram PRQS and a point U not on line PR,
    the lines PU and SQ intersect. *)

Definition strong_parallel_postulate :=  forall P Q R S T U,
  BetS P T Q -> BetS R T S -> ~ Col P R U ->
  Coplanar P Q R U ->
  Cong P T Q T -> Cong R T S T ->
  exists I, Col S Q I /\ Col P U I.

(** If a straight line falling on two straight lines make
    the sum of the interior angles on the same side different from two right angles,
    the two straight lines meet if produced indefinitely. *)

Definition alternative_strong_parallel_postulate := forall A B C D P Q R,
  OS B C A D -> SumA A B C B C D P Q R -> ~ Bet P Q R ->
  exists Y, Col B A Y /\ Col C D Y.

(** If a straight line falling on two straight lines
    make the interior angles on the same side less than two right angles,
    the two straight lines, if produced indefinitely,
    meet on that side on which are the angles less than the two right angles. *)

Definition euclid_s_parallel_postulate := forall A B C D P Q R,
  OS B C A D -> SAMS A B C B C D -> SumA A B C B C D P Q R -> ~ Bet P Q R ->
  exists Y, Out B A Y /\ Out C D Y.

(** There exists a triangle whose sum of angles is equal to the flat angle. *)

Definition postulate_of_existence_of_a_triangle_whose_angles_sum_to_two_rights :=
  exists A B C D E F, ~ Col A B C /\ TriSumA A B C D E F /\ Bet D E F.

(** There exists two lines which are everywhere equidistant. *)

Definition posidonius_postulate :=
  exists A1 A2 B1 B2,
    ~ Col A1 A2 B1 /\ B1 <> B2 /\ Coplanar A1 A2 B1 B2 /\
    forall A3 A4 B3 B4,
      Col A1 A2 A3 -> Col B1 B2 B3 -> Perp A1 A2 A3 B3 ->
      Col A1 A2 A4 -> Col B1 B2 B4 -> Perp A1 A2 A4 B4 ->
      Cong A3 B3 A4 B4.

(** There exists two non congruent similar triangles. *)

Definition postulate_of_existence_of_similar_triangles :=
  exists A B C D E F,
    ~ Col A B C /\ ~ Cong A B D E /\
    CongA A B C D E F /\ CongA B C A E F D /\ CongA C A B F D E.

(** If A, B and C are points on a circle where the line AB is a diameter of the circle,
    then the angle ACB is a right angle. *)

Definition thales_postulate := forall A B C M,
  Midpoint M A B -> Cong M A M C -> Per A C B.

(** The circumcenter of a right triangle is the midpoint of the hypotenuse. *)

Definition thales_converse_postulate := forall A B C M,
  Midpoint M A B -> Per A C B -> Cong M A M C.

(** There exists a right triangle whose circumcenter is the midpoint of the hypotenuse. *)

Definition existential_thales_postulate :=
  exists A B C M, ~ Col A B C /\ Midpoint M A B /\ Cong M A M C /\ Per A C B.

(** The angles of a any Saccheri quadrilateral are right. *)

Definition postulate_of_right_saccheri_quadrilaterals := forall A B C D,
  Saccheri A B C D -> Per A B C.

(** There exists a Saccheri quadrilateral whose angles are right. *)

Definition postulate_of_existence_of_a_right_saccheri_quadrilateral :=
  exists A B C D, Saccheri A B C D /\ Per A B C.

(** The angles of a any Lambert quadrilateral are right, i.e
    if in a quadrilateral three angles are right, so is the fourth. *)

Definition postulate_of_right_lambert_quadrilaterals := forall A B C D,
  Lambert A B C D -> Per B C D.

(** There exists a Lambert quadrilateral whose angles are right. *)

Definition postulate_of_existence_of_a_right_lambert_quadrilateral :=
  exists A B C D, Lambert A B C D /\ Per B C D.

(** For any angle, that, together with itself, make a right angle,
    any point together with its orthogonal projection on one side of the angle
    form a line which intersects the other side. *)

Definition weak_inverse_projection_postulate := forall A B C D E F P Q,
  Acute A B C -> Per D E F -> SumA A B C A B C D E F ->
  Out B A P -> P <> Q -> Per B P Q -> Coplanar A B C Q ->
  exists Y, Out B C Y /\ Col P Q Y.

Definition weak_tarski_s_parallel_postulate := forall A B C T,
  Per A B C -> InAngle T A B C ->
  exists X Y, Out B A X /\ Out B C Y /\ Bet X T Y.

(** The perpendicular bisectors of the legs of a right triangle intersect *)

Definition weak_triangle_circumscription_principle := forall A B C A1 A2 B1 B2,
  ~ Col A B C -> Per A C B ->
  Perp_bisect A1 A2 B C -> Perp_bisect B1 B2 A C ->
  Coplanar A B C A1 -> Coplanar A B C A2 ->
  Coplanar A B C B1 -> Coplanar A B C B2 ->
  exists I, Col A1 A2 I /\ Col B1 B2 I.

Definition legendre_s_parallel_postulate :=
  exists A B C,
    ~ Col A B C /\ Acute A B C /\
    forall T,
      InAngle T A B C ->
      exists X Y, Out B A X /\ Out B C Y /\ Bet X T Y.

(** There exists a point and a line such that
    there is only one parallel to this line going through this point. *)

Definition existential_playfair_s_postulate :=
  exists A1 A2 P, ~ Col A1 A2 P /\
             (forall B1 B2 C1 C2,
                Par A1 A2 B1 B2 -> Col P B1 B2 ->
                Par A1 A2 C1 C2 -> Col P C1 C2 ->
                Col C1 B1 B2 /\ Col C2 B1 B2).

End Euclid_def.


Require Export Iron.Language.Calc.Base.

(* Type expressions *)
Inductive ty  : Type :=
 | TNat     : ty                        (* number   type constructor *)
 | TBool    : ty                        (* boolean  type constructor *)
 | TText    : ty                        (* test     type constructor *)
 | TFun     : ty  -> ty -> ty.          (* function type constructor *)
Hint Constructors ty : calc.

(* Term expressions *)
Inductive va : Type :=
 | VNat     : nat    -> va              (* natural number value *)
 | VBool    : bool   -> va              (* boolean value *)
 | VText    : string -> va.             (* text value *)
Hint Constructors va : calc.

Inductive tm : Type :=
 | MVal     : va -> tm                  (* value *)
 | MAdd     : tm -> tm -> tm            (* addition       *)
 | MLess    : tm -> tm -> tm            (* less-than      *)
 | MAnd     : tm -> tm -> tm            (* boolean and    *)
 | MIf      : tm -> tm -> tm -> tm.     (* if-then-else   *)
Hint Constructors tm : calc.

Definition MNat  (n: nat)    := MVal (VNat  n).
Definition MBool (b: bool)   := MVal (VBool b).
Definition MText (t: string) := MVal (VText t).


(** This file contains some lemmas you will have to prove, i.e. replacing
   the "Admitted" joker with a sequence of tactic calls, terminated with a
   "Qed" command.

   Each lemma should be proved several times :
   first using only elementary tactics :
   intro[s], apply, assumption
   split, left, right, destruct.
   exists, rewrite
   assert (only if you don't find another solution)

   Then, use tactic composition, auto, tauto, firstorder.

Notice that, if you want to keep all solutions, you may use various
identifiers like in the given example : imp_dist, imp_dist' share
the same statement, with different interactive proofs.

*)

Section Minimal_propositional_logic.
 Variables P Q R S : Prop.

 Lemma id_P : P -> P.
 Proof.
 Admitted.

 Lemma id_PP : (P -> P) -> P -> P.
 Proof.
 Admitted.

 Lemma imp_dist : (P -> Q -> R) -> (P -> Q) -> P -> R.
 Proof.
 Admitted.

 Lemma imp_trans : (P -> Q) -> (Q -> R) -> P -> R.
 Proof.
 Admitted.

 Lemma imp_perm : (P -> Q -> R) -> Q -> P -> R.
 Proof.
 Admitted.

 Lemma ignore_Q : (P -> R) -> P -> Q -> R.
 Proof.
 Admitted.

 Lemma delta_imp : (P -> P -> Q) -> P -> Q.
 Proof.
 Admitted.

 Lemma delta_impR : (P -> Q) -> P -> P -> Q.
 Proof.
 Admitted.

 Lemma diamond : (P -> Q) -> (P -> R) -> (Q -> R -> S) -> P -> S.
 Proof.
 Admitted.

 Lemma weak_peirce : ((((P -> Q) -> P) -> P) -> Q) -> Q.
 Proof.
 Admitted.

End Minimal_propositional_logic.

(** Same exercise as the previous one, with full intuitionistic propositional
   logic

   You may use the tactics intro[s], apply, assumption, destruct,
                           left, right, split and try to use tactic composition *)

Section propositional_logic.

 Variables P Q R S T : Prop.

 Lemma and_assoc : P /\ (Q /\ R) -> (P /\ Q) /\ R.
 Proof.
 Admitted.

 Lemma and_imp_dist : (P -> Q) /\ (R -> S) -> P /\ R -> Q /\ S.
 Proof.
 Admitted.

 Lemma not_contrad :  ~(P /\ ~P).
 Proof.
 Admitted.

 Lemma or_and_not : (P \/ Q) /\ ~P -> Q.
 Proof.
 Admitted.

 Lemma not_not_exm : ~ ~ (P \/ ~ P).
 Proof.
 Admitted.

 Lemma de_morgan_1 : ~(P \/ Q) -> ~P /\ ~Q.
 Proof.
 Admitted.

 Lemma de_morgan_2 : ~P /\ ~Q -> ~(P \/ Q).
 Proof.
 Admitted.

 Lemma de_morgan_3 : ~P \/ ~Q -> ~(P /\ Q).
 Proof.
 Admitted.

 Lemma or_to_imp : P \/ Q -> ~ P -> Q.
 Admitted.

 Lemma imp_to_not_not_or : (P -> Q) -> ~~(~P \/ Q).
 Admitted.

 Lemma contraposition : (P -> Q) -> (~Q -> ~P).
 Admitted.

 Lemma contraposition' : (~P -> ~Q) <-> (~~Q -> ~~P).
 Admitted.

 Lemma contraposition'' : (~P -> ~Q) <-> ~~(Q -> P).
 Admitted.

 Section S0.
  Hypothesis H0 : P -> R.
  Hypothesis H1 : ~P -> R.

  Lemma weak_exm : ~~R.
  Admitted.

End S0.

Check weak_exm.

 (* Now, you may invent and solve your own exercises !
    Note that you can trust the tactic tauto: if it fails, then your formula
    is probably not (intuitionnistically) provable *)
(*
Lemma contraposition''' : (~P -> ~Q) <-> (Q -> P).
Proof.
 tauto.
Toplevel input, characters 8-13:
Error: tauto failed.
*)
End propositional_logic.

(* Now observe that the section mechanism discharges also the local
variables P, Q, R, etc. *)

Check and_imp_dist.


Set Warnings "-notation-overridden,-parsing,-deprecated-hint-without-locality".
From Coq Require Import Strings.String.
From PLF Require Import Maps.
From Coq Require Import Bool.Bool.
From Coq Require Import Arith.Arith.
From Coq Require Import Arith.EqNat.
From Coq Require Import Arith.PeanoNat. Import Nat.
From Coq Require Import Lia.
From PLF Require Export Imp.
From PLF Require Import Hoare.

(*    {{ True }}
      if X ≤ Y then
          {{ True /\ X ≤ Y           }} ->>
          {{ Y = X + Y - X           }}
        Z := Y - X
          {{ Y = X + Z               }}
      else
          {{ True /\ ~(X ≤ Y)        }} ->>
          {{ X + Z = X + Z           }}
        Y := X + Z
          {{ Y = X + Z               }}
      end
        {{ Y = X + Z }}
*)

(*
        (1)      {{ True }}
               while ~(X = 0) do
        (2)        {{ True ∧ X ≠ 0 }} ->>
        (3)        {{ True }}
                 X := X - 1
        (4)        {{ True }}
               end
        (5)      {{ True ∧ ~(X ≠ 0) }} ->>
        (6)      {{ X = 0 }}
*)
Definition reduce_to_zero' : com :=
  <{ while ~(X = 0) do X := X - 1 end }>.
Theorem reduce_to_zero_correct' :
  {{True}} reduce_to_zero' {{X = 0}}.
Proof.
  unfold reduce_to_zero'.
  (* First we need to transform the postcondition so
     that hoare_while will apply. *)
  eapply hoare_consequence_post.
  - apply hoare_while.
    + (* Loop body preserves invariant *)
      (* Need to massage precondition before hoare_asgn applies *)
      eapply hoare_consequence_pre.
      * apply hoare_asgn.
      * (* Proving trivial implication (2) ->> (3) *)
        unfold assn_sub, "->>". simpl. intros. exact I.
  - (* Invariant and negated guard imply postcondition *)
    intros st [Inv GuardFalse].
    unfold bassn in GuardFalse. simpl in GuardFalse.
    rewrite not_true_iff_false in GuardFalse.
    rewrite negb_false_iff in GuardFalse.
    apply eqb_eq in GuardFalse.
    apply GuardFalse.
Qed.

Ltac verify_assn :=
  repeat split;
  simpl; unfold assert_implies;
  unfold ap in *; unfold ap2 in *;
  unfold bassn in *; unfold beval in *; unfold aeval in *;
  unfold assn_sub; intros;
  repeat (simpl in *;
          rewrite t_update_eq ||
          (try rewrite t_update_neq; [| (intro X; inversion X; fail)] ) );
  simpl in *;
  repeat match goal with [H : _ /\ _ |- _] => destruct H end;
  repeat rewrite not_true_iff_false in *;
  repeat rewrite not_false_iff_true in *;
  repeat rewrite negb_true_iff in *;
  repeat rewrite negb_false_iff in *;
  repeat rewrite eqb_eq in *;
  repeat rewrite eqb_neq in *;
  repeat rewrite leb_iff in *;
  repeat rewrite leb_iff_conv in *;
  try subst;
  simpl in *;
  repeat
    match goal with
      [st : state |- _] =>
        match goal with
        | [H : st _ = _ |- _] => rewrite -> H in *; clear H
        | [H : _ = st _ |- _] => rewrite <- H in *; clear H
        end
    end;
  try eauto; try lia.

Theorem reduce_to_zero_correct''' :
  {{True}} reduce_to_zero' {{X = 0}}.
Proof.
  unfold reduce_to_zero'.
  eapply hoare_consequence_post.
  - apply hoare_while.
    + eapply hoare_consequence_pre.
      * apply hoare_asgn.
      * verify_assn.
  - verify_assn.
Qed.

(*
       X := m;
       Y := 0;
       while n ≤ X do
         X := X - n;
         Y := Y + 1
       end;

    Y = m / n
    X = m % n

    n × Y + X = m ∧ X < n.

      (1)    {{ True }} ->>
      (2)    {{ n × 0 + m = m }}
           X := m;
      (3)    {{ n × 0 + X = m }}
           Y := 0;
      (4)    {{ n × Y + X = m }}
           while n ≤ X do
      (5)      {{ n × Y + X = m ∧ n ≤ X }} ->>
      (6)      {{ n × (Y + 1) + (X - n) = m }}
             X := X - n;
      (7)      {{ n × (Y + 1) + X = m }}
             Y := Y + 1
      (8)      {{ n × Y + X = m }}
           end
      (9)    {{ n × Y + X = m ∧ ¬(n ≤ X) }} ->>
     (10)    {{ n × Y + X = m ∧ X < n }}
*)

(*
      {{ X = m }}
      {{ X = m /\ 0 = 0}}
      Y := 0;
      {{ X = m /\ Y = 0}}
      {{ X + Y = m /\ ~(X = 0) }}
      while ~(X = 0) do
        {{ X - 1 + Y + 1 = m /\ ~(X = 0) }}
        X := X - 1;
        {{ X + Y + 1 = m /\ ~(X = 0) }}
        Y := Y + 1
        {{ X + Y = m /\ ~(X = 0) }}
      end
      {{ X + Y = m /\ X = 0 }}
      {{ Y = m }}
*)
Definition  slow_assignment_prog : com :=
  <{
      Y := 0;
      while ~(X = 0) do
        X := X - 1;
        Y := Y + 1
      end
  }>.

Definition body_slow_assignment_prog: com :=
  <{
    X := X - 1;
    Y := Y + 1
  }>.
Lemma tst: forall (m: nat), {{ X + Y = m /\ ~(X = 0)}} body_slow_assignment_prog {{ X + Y = m }}.
Proof. intro m. unfold body_slow_assignment_prog.
  eapply hoare_seq.
  - (* Y *)
    apply hoare_asgn.
  - (* X *)
    eapply hoare_consequence_pre.
    + apply hoare_asgn.
    + (* func *)
      verify_assn.
Qed.

Fixpoint parity x :=
  match x with
  | 0 => 0
  | 1 => 1
  | S (S x') => parity x'
  end.

Lemma parity_ge_2 : forall x, 2 <= x -> parity (x - 2) = parity x.
Proof.
  induction x; intros; simpl.
  - reflexivity.
  - destruct x.
    + lia.
    + inversion H; subst; simpl.
      * reflexivity.
      * rewrite sub_0_r. reflexivity.
Qed.

Lemma parity_lt_2 : forall x, ~(2 <= x) -> parity x = x.
Proof.
  induction x; intros; simpl.
  - reflexivity.
  - destruct x.
    + reflexivity.
    + lia.
Qed.

Theorem parity_correct : forall (m:nat),
  {{ X = m }}
  while 2 <= X do
    X := X - 2
  end
  {{ X = parity m }}.
Proof.
  intro m.
  apply hoare_consequence_pre with (P' := assert (ap parity X = parity m)).
  --  eapply hoare_consequence_post.
      - eapply hoare_while.
        + (* While body *)
          eapply hoare_consequence_pre.
          * apply hoare_asgn.
          * verify_assn.
            rewrite <- H.
            apply (parity_ge_2 (st X)).
            destruct (st X). discriminate H0.
            destruct n. discriminate H0.
            lia.
      - verify_assn.
        rewrite <- H. symmetry.
        apply parity_lt_2.
        destruct (st X). lia.
        destruct n. lia.
        lia.
  -- verify_assn.
Qed.

(*
    {{ X = m }} ->>
    {{ X! * 1 = m!                                     }}
      Y := 1;
    {{ X! * Y = m!                                     }}
      while ~(X = 0)
      do   {{ X! * Y = m!  /\  ~(X = 0)                }} ->>
           {{ X! * Y = m!                              }}
         Y := Y × X;
           {{ X! * (Y * X) = m!                        }}
         X := X - 1
           {{ (X - 1)! * (Y * X) = m!                  }}
      end
    {{ X! * Y = m!  /\  X = 0                          }} ->>
    {{ Y = m! }}
*)

(*
  {{ True }} ->>
  {{ min a b  + 0 = min a b                      }}
  X := a;
  {{ min X b  + 0 = min a b                      }}
  Y := b;
  {{ min X Y  + 0 = min a b                      }}
  Z := 0;
  {{ min X Y  + Z = min a b                      }}
  while ~(X = 0) && ~(Y = 0) do
    {{ (min X Y  + Z = min a b) /\ ~(X = 0) /\ ~(Y = 0)    }} ->>
    {{ (min (X - 1) (Y - 1)  + (Z + 1) = min a b)          }}
    X := X - 1;
    {{ (min X (Y - 1)  + (Z + 1) = min a b)                }}
    Y := Y - 1;
    {{ (min X Y  + (Z + 1) = min a b)                      }}
    Z := Z + 1
    {{ (min X Y  + Z = min a b)                        }}
  end
  {{ (min X Y  + Z = min a b) /\ (X = 0) /\ (Y = 0)    }} ->>
  {{ Z = min a b }}
*)

Definition is_wp P c Q :=
  {{P}} c {{Q}} /\ forall P', {{P'}} c {{Q}} -> (P' ->> P).

Theorem is_wp_example :
  is_wp (Y <= 4) <{X := Y + 1}> (X <= 5).
Proof.
  split.
  - eapply hoare_consequence_pre.
    * apply hoare_asgn.
    * verify_assn.
  - intros P' H.
    unfold hoare_triple in H.
    unfold "->>".
    intros st Hp'.
    assert (G: (X !-> st Y + 1; st) X <= 5). {
      simpl in H.
      apply (H st (X !-> st Y + 1; st)).
      + constructor. simpl. reflexivity.
      + assumption.
    }
    unfold t_update in G. simpl in G.
    Search (?c <-> S ?x <= S ?y).
    Search (?x + ?y = ?y + ?x).
    rewrite add_comm in G.
    rewrite <- succ_le_mono in G.
    simpl.
    apply G.
Qed.

Theorem hoare_asgn_weakest : forall Q X a,
  is_wp (Q [X |-> a]) <{ X := a }> Q.
Proof.
  split.
  - apply hoare_asgn.
  - intros P' Hc st Hpst.
    unfold assn_sub.
    apply (Hc st).
    + constructor. reflexivity.
    + assumption.
Qed.

Module Himp2.
Import Himp.
Lemma hoare_havoc_weakest : forall (P Q : Assertion) (X : string),
  {{ P }} havoc X {{ Q }}  ->  P ->> havoc_pre X Q.
Proof.
  intros P Q X H st Hpst n.
  apply (H st).
  - constructor.
  - assumption.
Qed.
End Himp2.

Inductive dcom : Type :=
| DCSkip (Q : Assertion) (* skip {{ Q }} *)
| DCSeq (d1 d2 : dcom)  (* d1 ; d2 *)
| DCAsgn (X : string) (a : aexp) (Q : Assertion)  (* X := a {{ Q }} *)
| DCIf (b : bexp) (P1 : Assertion) (d1 : dcom)
       (P2 : Assertion) (d2 : dcom) (Q : Assertion)
  (* if b then {{ P1 }} d1 else {{ P2 }} d2 end {{ Q }} *)
| DCWhile (b : bexp) (P : Assertion) (d : dcom) (Q : Assertion)  (* while b do {{ P }} d end {{ Q }} *)
| DCPre (P : Assertion) (d : dcom)  (* ->> {{ P }} d *)
| DCPost (d : dcom) (Q : Assertion)  (* d ->> {{ Q }} *)
.

Inductive decorated : Type :=
  | Decorated : Assertion -> dcom -> decorated.

Declare Scope dcom_scope.
Notation "'skip' {{ P }}" := (DCSkip P)
      (in custom com at level 0, P constr) : dcom_scope.
Notation "l ':=' a {{ P }}" := (DCAsgn l a P)
      (in custom com at level 0, l constr at level 0, a custom com at level 85, P constr, no associativity) : dcom_scope.
Notation "'while' b 'do' {{ P }} d 'end' {{ Q }}" := (DCWhile b P d Q)
      (in custom com at level 89, b custom com at level 99, P constr, Q constr) : dcom_scope.
Notation "'if' b 'then' {{ P }} d 'else' {{ P' }} d' 'end' {{ Q }}" := (DCIf b P d P' d' Q)
      (in custom com at level 89, b custom com at level 99, P constr, P' constr, Q constr) : dcom_scope.
Notation "'->>' {{ P }} d" := (DCPre P d)
      (in custom com at level 12, right associativity, P constr) : dcom_scope.
Notation "d '->>' {{ P }}" := (DCPost d P)
      (in custom com at level 10, right associativity, P constr) : dcom_scope.
Notation " d ; d' " := (DCSeq d d')
      (in custom com at level 90, right associativity) : dcom_scope.
Notation "{{ P }} d" := (Decorated P d)
      (in custom com at level 91, P constr) : dcom_scope.
Open Scope dcom_scope.

Example dec0 :=  <{ skip {{ True }} }>.
Example dec1 :=  <{ while true do {{ True }} skip {{ True }} end  {{ True }} }>.

Example dec_while : decorated :=
  <{
    {{ True }}
    while ~(X = 0)
    do
      {{ True /\ ~(X = 0) }}
      X := X - 1
      {{ True }}
    end
    {{ True /\ X = 0}} ->>
    {{ X = 0 }}
  }>.

Fixpoint extract (d : dcom) : com :=
  match d with
  | DCSkip _            => CSkip
  | DCSeq d1 d2         => CSeq (extract d1) (extract d2)
  | DCAsgn X a _        => CAsgn X a
  | DCIf b _ d1 _ d2 _  => CIf b (extract d1) (extract d2)
  | DCWhile b _ d _     => CWhile b (extract d)
  | DCPre _ d           => extract d
  | DCPost d _          => extract d
  end.

Definition extract_dec (dec : decorated) : com :=
  match dec with
  | Decorated P d => extract d
  end.

Example extract_while_ex :
  extract_dec dec_while = <{while ~(X = 0) do X := X - 1 end}>.
Proof.
  unfold dec_while.
  reflexivity.
Qed.

Fixpoint post (d : dcom) : Assertion :=
  match d with
  | DCSkip P          => P
  | DCSeq _ d2        => post d2
  | DCAsgn _ _ Q      => Q
  | DCIf _ _ _ _ _ Q  => Q
  | DCWhile _ _ _ Q   => Q
  | DCPre _ d         => post d
  | DCPost _ Q        => Q
  end.

Definition pre_dec (dec : decorated) : Assertion :=
  match dec with
  | Decorated P d => P
  end.

Definition post_dec (dec : decorated) : Assertion :=
  match dec with
  | Decorated P d => post d
  end.

Example pre_dec_while : pre_dec dec_while = True.
Proof. reflexivity. Qed.

Example post_dec_while : post_dec dec_while = (X = 0)%assertion.
Proof. reflexivity. Qed.

Definition dec_correct (dec : decorated) :=  {{pre_dec dec}} extract_dec dec {{post_dec dec}}.

Example dec_while_triple_correct :
  dec_correct dec_while
 = {{ True }}
   while ~(X = 0) do X := X - 1 end
   {{ X = 0 }}.
Proof. reflexivity. Qed.

Fixpoint verification_conditions (P : Assertion) (d : dcom) : Prop :=
  match d with
  | DCSkip Q    => (P ->> Q)
  | DCSeq d1 d2 =>
         verification_conditions P d1
      /\ verification_conditions (post d1) d2
  | DCAsgn X a Q =>
      (P ->> Q [X |-> a])
  | DCIf b P1 d1 P2 d2 Q =>
         ((P /\  b) ->> P1)%assertion
      /\ ((P /\ ~b) ->> P2)%assertion
      /\ (post d1 ->> Q)
      /\ (post d2 ->> Q)
      /\ verification_conditions P1 d1
      /\ verification_conditions P2 d2
  | DCWhile b Pbody d Ppost =>
      (* post d is the loop invariant and the initial precondition *)
         (P ->> post d)
      /\ ((post d /\  b) ->> Pbody)%assertion
      /\ ((post d /\ ~b) ->> Ppost)%assertion
      /\ verification_conditions Pbody d
  | DCPre P' d =>
         (P ->> P')
      /\ verification_conditions P' d
  | DCPost d Q =>
         verification_conditions P d
      /\ (post d ->> Q)
  end.

Theorem verification_correct : forall d P,
  verification_conditions P d -> {{P}} extract d {{post d}}.
Proof.
  induction d; intros; simpl in *.
  - (* Skip *)
    eapply hoare_consequence_pre.
      + apply hoare_skip.
      + assumption.
  - (* Seq *)
    destruct H as [H1 H2].
    eapply hoare_seq.
      + apply IHd2. apply H2.
      + apply IHd1. apply H1.
  - (* Asgn *)
    eapply hoare_consequence_pre.
      + apply hoare_asgn.
      + assumption.
  - (* If *)
    destruct H as [HPre1 [HPre2 [Hd1 [Hd2 [HThen HElse] ] ] ] ].
    apply IHd1 in HThen. clear IHd1.
    apply IHd2 in HElse. clear IHd2.
    apply hoare_if.
      + eapply hoare_consequence; eauto.
      + eapply hoare_consequence; eauto.
  - (* While *)
    destruct H as [Hpre [Hbody1 [Hpost1 Hd] ] ].
    eapply hoare_consequence; eauto.
    apply hoare_while.
    eapply hoare_consequence_pre; eauto.
  - (* Pre *)
    destruct H as [HP Hd].
    eapply hoare_consequence_pre; eauto.
  - (* Post *)
    destruct H as [Hd HQ].
    eapply hoare_consequence_post; eauto.
Qed.

Definition verification_conditions_dec (dec : decorated) : Prop :=
  match dec with
  | Decorated P d => verification_conditions P d
  end.

Corollary verification_correct_dec : forall dec,
  verification_conditions_dec dec -> dec_correct dec.
Proof.
  intros [P d]. apply verification_correct.
Qed.

Eval simpl in verification_conditions_dec dec_while.

Example vc_dec_while : verification_conditions_dec dec_while.
Proof. verify_assn. Qed.

Ltac verify :=
  intros;
  apply verification_correct;
  verify_assn.

Theorem Dec_while_correct :  dec_correct dec_while.
Proof. verify. Qed.

Example subtract_slowly_dec (m : nat) (p : nat) : decorated :=
  <{
      {{ X = m /\ Z = p }} ->>
      {{ Z - X = p - m }}
    while ~(X = 0)
    do {{ Z - X = p - m /\ X <> 0 }} ->>
         {{ (Z - 1) - (X - 1) = p - m }}
       Z := Z - 1
         {{ Z - (X - 1) = p - m }} ;
       X := X - 1
         {{ Z - X = p - m }}
    end
      {{ Z - X = p - m /\ X = 0 }} ->>
      {{ Z = p - m }}
  }>.
Theorem subtract_slowly_dec_correct : forall m p,
  dec_correct (subtract_slowly_dec m p).
Proof. verify. (* this grinds for a bit! *) Qed.

(* Definition swap : com := *)
(*   <{ X := X + Y; *)
(*      Y := X - Y; *)
(*      X := X - Y }>. *)
Definition swap_dec (m n:nat) : decorated :=
  <{
       {{ X = m /\ Y = n}} ->>
       {{ (X + Y) - ((X + Y) - Y) = n /\ (X + Y) - Y = m }}
      X := X + Y
       {{ X - (X - Y) = n /\ X - Y = m }};
      Y := X - Y
       {{ X - Y = n /\ Y = m }};
      X := X - Y
       {{ X = n /\ Y = m}}
  }>.
Theorem swap_correct : forall m n,  dec_correct (swap_dec m n).
Proof. verify. Qed.

Definition div_mod_dec (a b : nat) : decorated :=
  <{
      {{ True }} ->>
      {{ b * 0 + a = a }}
      X := a
      {{ b * 0 + X = a }};
      Y := 0
      {{ b * Y + X = a }};
      while b <= X do
        {{ b * Y + X = a /\ b <= X }} ->>
        {{ b * (Y + 1) + (X - b) = a }}
        X := X - b
        {{ b * (Y + 1) + X = a }};
        Y := Y + 1
        {{ b * Y + X = a }}
      end
      {{ b * Y + X = a /\ ~(b <= X) }} ->>
      {{ b * Y + X = a /\ (X < b) }}
  }>.
Theorem div_mod_dec_correct : forall a b,  dec_correct (div_mod_dec a b).
Proof.
  verify.
Qed.

Inductive ev : nat -> Prop :=
  | ev_0 : ev O
  | ev_SS : forall n : nat, ev n -> ev (S (S n)).

Definition find_parity_dec' (m:nat) : decorated :=
  <{
        {{ X = m }} ->>
        {{ ap ev X <-> ev m }}
       while 2 <= X do
          {{ (ap ev X <-> ev m) /\ 2 <= X }} ->>
          {{ ap ev (X - 2) <-> ev m }}
          X := X - 2
          {{ ap ev X <-> ev m }}
       end
       {{ (ap ev X <-> ev m) /\ ~(2 <= X) }} ->>
       {{ X=0 <-> ev m }}
  }>.

Lemma l4 : forall m,
  2 <= m -> (ev (m - 2) <-> ev m).
Proof.
  induction m; intros. split; intro; constructor.
  destruct m. inversion H. inversion H1. simpl in *.
  rewrite <- minus_n_O in *. split; intro.
    constructor. assumption.
    inversion H0. assumption.
Qed.

Theorem find_parity_correct' : forall m,  dec_correct (find_parity_dec' m).
Proof.
  verify;
    (* simplification too aggressive ... reverting a bit *)
    fold (2 <=? (st X)) in *;
    try rewrite leb_iff in *;
    try rewrite leb_iff_conv in *; intuition; eauto; try lia.
  - (* invariant preserved (part 1) *)
    rewrite l4 in H0; eauto.
  - (* invariant preserved (part 2) *)
    rewrite l4; eauto.
  - (* invariant strong enough to imply conclusion
       (-> direction) *)
    apply H0. constructor.
  - (* invariant strong enough to imply conclusion
       (<- direction) *)
      destruct (st X) as [| [| n] ]. (* by H1 X can only be 0 or 1 *)
      + (* st X = 0 *)
        reflexivity.
      + (* st X = 1 *)
        inversion H.
      + (* st X = 2 *)
        lia.
Qed.

Example slow_assignment_dec (m : nat) : decorated :=
  <{  {{ X = m }} ->>
      {{ X + 0 = m }}
      Y := 0
      {{ X + Y = m }};
      while ~(X = 0) do
        {{ X + Y = m /\ ~(X = 0) }} ->>
        {{ (X - 1) + (Y + 1) = m }}
        X := X - 1
        {{ X + (Y + 1) = m }};
        Y := Y + 1
        {{ X + Y = m }}
      end
      {{ X + Y = m /\ (X = 0) }} ->>
      {{ Y = m }}
  }>.

Theorem slow_assignment_dec_correct : forall m,  dec_correct (slow_assignment_dec m).
Proof. verify. Qed.

Definition foo1: nat -> nat -> nat := fun a b => a + b.
Definition foo2: nat -> nat -> Prop := fun a b => a = b.

Definition foo3: foo2 1 1. (* Theorem / Lemma is just functions *)
Proof. reflexivity. Qed.

Fixpoint fib n :=
  match n with
  | 0    => 1
  | S n' => match n' with
            | 0     => 1
            | S n'' => fib n' + fib n''
            end
  end.

Lemma fib_eqn : forall n,
  n > 0 -> fib n + fib (pred n) = fib (1 + n).
Proof.
  intros n Hgt0.
  destruct n as [| n'].
  - inversion Hgt0.
  - simpl. reflexivity.
Qed.

Definition T : string := "T".

Open Scope com_scope.
Definition fib_prog (n: nat) : com :=
  <{
    X := 1;
    Y := 1;
    Z := 1;
    while ~(X = 1 + n) do
      T := Z;
      Z := Z + Y;
      Y := T;
      X := 1 + X
    end
  }>.

Open Scope dcom_scope.
Definition dfib (n: nat) : decorated :=
  <{
    {{ True }} ->>
    {{ 1 = 1 /\ 1 = 1 /\ 1 = 1 }}
    X := 1
    {{ X = 1 /\ 1 = 1 /\ 1 = 1 }};
    Y := 1
    {{ X = 1 /\ Y = 1 /\ 1 = 1 }};
    Z := 1
    {{ X = 1 /\ Y = 1 /\ Z = 1 }} ->>
    {{ X > 0 /\ Y = (ap fib (X - 1)) /\ Z = (ap fib X) }};
    while ~(X = 1 + n) do
      {{ X > 0 /\ Y = (ap fib (X - 1)) /\ Z = (ap fib X) /\ ~(X = 1 + n) }}
      T := Z
      {{ X > 0 /\ Y = (ap fib (X - 1)) /\ Z = (ap fib X) /\ T = (ap fib X) /\ ~(X = 1 + n) }};
      Z := Z + Y
      {{ X > 0 /\ Y = (ap fib (X - 1)) /\ Z = (ap fib (1 + X)) /\ T = (ap fib X) /\ ~(X = 1 + n) }};
      Y := T
      {{ X > 0 /\ Y = (ap fib X) /\ Z = (ap fib (1 + X)) /\ T = (ap fib X) /\ ~(X = 1 + n)  }} ->>
      {{ X > 0 /\ Y = (ap fib ((X + 1) - 1)) /\ Z = (ap fib (1 + X)) }};
      X := 1 + X
      {{ X > 0 /\ Y = (ap fib (X - 1)) /\ Z = (ap fib X) }}
    end
    {{ X > 0 /\ Y = (ap fib (X - 1)) /\ Z = (ap fib X) /\ (X = 1 + n) }} ->>
    {{ Y = fib n }}
  }>.

Lemma sn_1: forall n, S n - 1 = n.
Proof. intros n. simpl. lia. Qed.

Lemma n_1_1: forall n, n + 1 - 1 = n.
Proof. intros n. lia. Qed.

Lemma n_0: forall n, n - 0 = n.
Proof. intros n. lia. Qed.

Theorem dfib_correct : forall n,  dec_correct (dfib n).
Proof. verify.
  - destruct (st X). inversion H.
    rewrite -> sn_1. reflexivity.
  - rewrite -> n_1_1. reflexivity.
  - rewrite -> n_1_1.
    rewrite -> n_0. reflexivity.
  - rewrite -> sn_1. reflexivity.
Qed.

(*
  Exercise: 5 stars, advanced, optional (improve_dcom)
  The formal decorated programs defined in this section are intended to
  look as similar as possible to the informal ones defined earlier in the
  chapter. If we drop this requirement, we can eliminate almost all annotations,
   just requiring final postconditions and loop invariants to be provided explicitly.
  Do this -- i.e., define a new version of dcom with as few annotations as possible
  and adapt the rest of the formal development leading up to the verification_correct theorem.
*)

Module LastEx.
End LastEx.


From mathcomp Require Import all_ssreflect.

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

(**

----------------------------------------------------------
#
#
** Lesson 7: summary

- generic notations and theories
- interfaces
- parametrizing theories
- the BigOp library (the theories of fold)

Let's start with a lie and then make it true:

#
#
Coq is an object oriented
programming language.
#
#

#
#

----------------------------------------------------------
#
#
** Generic notations and theories

Polymorphism != overloading.

Example: the [==] computable equality

#
#
*)

(**
#
#

Polymorphism

#
#

*)

Check (_ = _).

Check true = false.

Check (eq true false).

Check @eq.

Check (@eq _ true false).

Check (@eq bool true false).

(**
#
#

Overloading : looking inside types

#
#

*)

Check (_ == _).

Check true == false.

Check (@eq_op _ true false).

Check (@eq_op bool_eqType true false).

Check 3 == 4.

Check [::] == [:: 2; 3; 4].

Section T.

Variable T : eqType.
Variable x : T.

Eval lazy in x == x.

End T.

(**
#
#

Object oriented flavor

#
#

*)

Eval lazy in true == false.

Eval lazy in 3 == 4.

Eval lazy in [::] == [:: 2; 3; 4].

Check (3, true) == (4, false).

Eval lazy in (3, true) == (4, false).

(**
#
#

Overloading may fail, polymorphism never

#
#

*)

Fail Check (fun x => x) == (fun y => y).

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

(**
#
#

Type inference

#
#

*)

Check [eqType of bool].

Fail Check [eqType of bool -> bool].

Check [eqType of {ffun bool -> bool}].

Check [eqType of nat].

Fail Check [eqType of nat -> nat].

Check [eqType of {ffun 'I_256 -> nat}].

Check [eqType of seq nat].

Fail Check [eqType of seq (nat -> nat)].

Check [eqType of seq {ffun 'I_256 -> nat}].

(**
#
#

We call [eqType] an interface. With some "approximation"
[eqType] is defined as follows:

<<

Module Equality.

Structure type : Type := Pack {
  sort : Type;
  op : sort -> sort -> bool;
  axiom : ∀x y, reflect (x = y) (op x y)
}.

End Equality
>>

#
(notes)
#
This slide corresponds to
section 5.4 of
#the Mathematical Components book#
#

#
#

#
#
#

----------------------------------------------------------
#
#
** Interfaces

Mathematical Components defines a hierarchy
of interfaces. They group notations and
theorems.

# #

Let's use the theory of [eqType]

#
#
*)

About eqxx.

About eq_refl.

Lemma test_eq (*(T : eqType) (x : T)*) :
  (3 == 3) && (true == true) (*&& (x == x)*).
Proof.
rewrite eqxx.
rewrite eqxx.
(* rewrite eqxx. *)
by [].
Qed.

(**
#
#

Interfaces do apply to registered, concrete examples
such as [bool] or [nat]. They can also apply to variables,
as long as their type is "rich" ([eqType] is richer than [Type]).

#
(notes)
#
This slide corresponds to
section 5.5 and 7 of
#the Mathematical Components book#
#

#

#

#
#
#

----------------------------------------------------------
#
#
** Theories over an interface

Interfaces can be used to parametrize an
entire theory

#
#
*)
Module Seq. Section Theory.

Variable T : eqType.

Implicit Type s : seq T.

Fixpoint mem_seq s x :=
  if s is y :: s1
  then (y == x) || mem_seq s1 x
  else false.

(* the infix \in and \notin are generic, not
   just for sequences. *)

Fixpoint uniq s :=
  if s is x :: s1
  then (x \notin s1) && uniq s1
  else true.

Fixpoint undup s :=
  if s is x :: s1 then
    if x \in s1 then undup s1 else x :: undup s1
  else [::].

End Theory. End Seq.

About undup_uniq.

Eval lazy in (undup [::1;3;1;4]).

Lemma test : uniq (undup [::1;3;1;4]).
Proof.
by rewrite undup_uniq.
Qed.

(**
#
#

Others interfaces

**)

Section Interfaces.

Variable chT : choiceType.

Check (@sigW chT).

Check [eqType of chT].

Variable coT : countType.

Check [countType of nat].
Check [choiceType of coT].
Check [choiceType of nat * nat].
Check [choiceType of seq coT].

Variable fT : finType.

Check [finType of bool].
Check [finType of 'I_10].
Check [finType of {ffun 'I_10 -> fT}].
Check [finType of bool * bool].

End Interfaces.

(**
#
#

#
(notes)
#
This slide corresponds to
section 5.6 of
#the Mathematical Components book#
#

#

#

#
#
#

----------------------------------------------------------
#
#
** Generic theories: the BigOp library

The BigOp library is the canonical example
of a generic theory. It it about the
[fold] iterator we studied in lesson 1,
and the many uses it can have.

#
#
*)

Lemma sum_odd_3 :
  \sum_(0 <= i < 6 | odd i) i = 3^2.
Proof.
rewrite unlock /=.
by [].
Qed.

About big_mkcond.
About big_nat_recr.

Lemma sum_odd_3_bis :
  \sum_(0 <= i < 6 | odd i) i = 3^2.
Proof.
rewrite big_mkcond big_nat_recr //= -big_mkcond /=.
Abort.

Lemma prod_odd_3_bis : (* try [maxn/0] and also [maxn/1] *)
  \big[muln/1]_(0 <= i < 6 | odd i) i = 3^2.
Proof.
rewrite big_mkcond big_nat_recr //= -big_mkcond /=.
Abort.

(**
#
#

Most of the lemmas require the operation to be a monoid,
some others to be a commutative monoid.

#
#
*)

About bigD1.

(**
#
#

Searching for bigop

#
#
*)

Lemma sum_odd_even_all n :
  \sum_(0 <= i < n) i =
  \sum_(0 <= i < n | odd i) i + \sum_(0 <= i < n | ~~ odd i) i.
Proof.
Search _ (~~ _) in bigop.
by rewrite (bigID odd).
Qed.

(**
#
#

Primer for bigop

#
#
*)

Section Primer.

Variable n: nat.
Variable f : 'I_n -> nat.
Variable g : nat -> nat.

Check \big[addn/0]_(i <- [::1; 4; 5] | odd i) g i.

Check \big[addn/0]_(i : 'I_n | odd i) f i.

Definition oddIn := [pred i | odd (i : 'I_n)].

Check \big[addn/0]_(i in oddIn) f i.

Goal \sum_(i in oddIn) i = \sum_(i < n | odd i) i.
Proof.
by [].
Qed.

Check \big[addn/0]_(0 <= i < n | odd i) g i.

Goal \sum_(0 <= i < n | odd i) g i = \sum_(i < n | odd i) g i.
Proof.
Check big_mkord.
rewrite big_mkord.
by [].
Qed.

Goal \sum_(0 <= i < n |odd i) i.*2 = \sum_(0 <= i < n|odd i) (i + i).
Proof.
Fail rewrite addnn.
About eq_bigr.
apply: eq_bigr.
move=> i Hi.
by rewrite addnn.
Qed.

Goal \sum_(0 <= i < n |odd i) i.*2 = \sum_(0 <= i < n | odd i) (i + i).
Proof.
About eq_bigr.
rewrite (eq_bigr (fun i => i + i)) //.
move=> i Hi.
by rewrite addnn.
Qed.

Goal (\sum_(i < n|odd i) i).*2 = \sum_(i < n |odd i) i.*2.
Proof.
About  big_morph.
Fail rewrite big_morph.
rewrite (big_morph _ (_ : {morph double : x y / x + y}) (_ : 0.*2 = 0)).
- by [].
- move=> x y; exact: doubleD.
by [].
Qed.

End Primer.

(**
#
#

#
(notes)
#
This slide corresponds to
section 5.7 of
#the Mathematical Components book#
#

#

#

#
#
#

----------------------------------------------------------
#
#
** Sum up

- Coq is an object oriented language ;-)

- in the Mathematical Components library [xxType] is an
  interface (eg [eqType] for types with an equality test).
  Notations and theorems are linked to interfaces.
  Interfaces are organized in hierarchies (we just saw a picture,
  how it works can be found in the book).

#
#

*)


(**************************************************************)
(* Negation.v                                                 *)
(*                                                            *)
(* Author: Aaron Bohannon                                     *)
(**************************************************************)

(** This file provides some lemmas and tactics for manipulating
    uses of [not] in propositions.  A few assorted items are
    included that would make more sense in [Decidable.v] in the
    standard library. *)

Require Export Decidable.
Require Import Setoid.

(** * Some Lemmas and Tactics About Decidable Propositions *)

Lemma dec_iff : forall P Q : Prop,
  decidable P ->
  decidable Q ->
  decidable (P <-> Q).
Proof.
  unfold decidable in *. tauto.
Qed.

(** With this hint database, we can leverage [auto] to check
    decidability of propositions. *)
Hint Resolve
  dec_True dec_False dec_or dec_and dec_imp dec_not dec_iff
: decidable_prop.

(** [solve_decidable using lib] will solve goals about the
    decidability of a proposition, assisted by an auxiliary
    database of lemmas.  The database is intended to contain
    lemmas stating the decidability of additional propositions,
    (e.g., the decidability of equality on a particular
    inductive type). *)
Tactic Notation "solve_decidable" "using" ident(db) :=
  match goal with
  | |- decidable ?P =>
    solve [ auto 100 with decidable_prop db ]
  end.

Tactic Notation "solve_decidable" :=
  solve_decidable using core.

(** * Propositional Equivalences Involving Negation
    These are all written with the unfolded form of negation,
    since, in a situation (such as a tactic) where they will be
    used repeatedly, we don't want to have to interleave their
    uses with uses of [fold] or [unfold] to get their full
    benefit.  (For a specific example, consider what would
    happen if the first lemma [not_true_iff] were written as [~
    True <-> False].  How would it be used to replace [True ->
    (~ True)] with [False]?)
*)

(** ** Eliminating Negations
    We begin with lemmas that, when read from left to right, can
    be understood as ways to eliminate uses of [not]. *)

Lemma not_true_iff :
  (True -> False) <-> False.
Proof.
  tauto.
Qed.

Lemma not_false_iff :
  (False -> False) <-> True.
Proof.
  tauto.
Qed.

Lemma not_not_iff : forall P : Prop,
  decidable P ->
  (((P -> False) -> False) <-> P).
Proof.
  unfold decidable in *. tauto.
Qed.

Lemma contrapositive : forall P Q : Prop,
  decidable P ->
  (((P -> False) -> (Q -> False)) <-> (Q -> P)).
Proof.
  unfold decidable in *. tauto.
Qed.

Lemma and_not_l_iff_1 : forall P Q : Prop,
  decidable P ->
  ((P -> False) \/ Q <-> (P -> Q)).
Proof.
  unfold decidable in *. tauto.
Qed.

Lemma and_not_l_iff_2 : forall P Q : Prop,
  decidable Q ->
  ((P -> False) \/ Q <-> (P -> Q)).
Proof.
  unfold decidable in *. tauto.
Qed.

Lemma and_not_r_iff_1 : forall P Q : Prop,
  decidable P ->
  (P \/ (Q -> False) <-> (Q -> P)).
Proof.
  unfold decidable in *. tauto.
Qed.

Lemma and_not_r_iff_2 : forall P Q : Prop,
  decidable Q ->
  (P \/ (Q -> False) <-> (Q -> P)).
Proof.
  unfold decidable in *. tauto.
Qed.

Lemma imp_not_l : forall P Q : Prop,
  decidable P ->
  ((~ P -> Q) <-> (P \/ Q)).
Proof.
  unfold decidable in *. tauto.
Qed.

(** ** Pushing Negations Around
    We have four lemmas that, when read from left to right,
    describe how to push negations toward the leaves of a
    proposition and, when read from right to left, describe
    how to pull negations toward the top of a propsition. *)

Lemma not_or_iff : forall P Q : Prop,
  (P \/ Q -> False) <-> (P -> False) /\ (Q -> False).
Proof.
  tauto.
Qed.

Lemma not_and_iff : forall P Q : Prop,
  (P /\ Q -> False) <-> (P -> Q -> False).
Proof.
  tauto.
Qed.

Lemma not_imp_iff : forall P Q : Prop,
  decidable P ->
  (((P -> Q) -> False) <-> P /\ (Q -> False)).
Proof.
  unfold decidable in *. tauto.
Qed.

Lemma not_imp_rev_iff : forall P Q : Prop,
  decidable P ->
  (((P -> Q) -> False) <-> (Q -> False) /\ P).
Proof.
  unfold decidable in *. tauto.
Qed.

(** * Tactics for Negations *)

(** ** Folding Negations
    This section provides tactics for folding uses of [not]
    wherever possible.  Multiple versions are provided that
    correspond to many of the forms used by the built-in
    conversion tactics. *)

Tactic Notation "fold" "any" "not" :=
  repeat (
    match goal with
    | |- context [?P -> False] =>
      fold (~ P)
    end).

Tactic Notation "fold" "any" "not" "in" ident(H) "|-" :=
  repeat (
    match goal with
    | J: context [?P -> False] |- _ =>
      fold (~ P) in H
    end).

Tactic Notation "fold" "any" "not" "in" ident(H) :=
  fold any not in H |-.

Tactic Notation "fold" "any" "not" "in" "*" "|-" :=
  repeat (
    match goal with
    | H: context [?P -> False] |- _ =>
      fold (~ P) in H
    end).

Tactic Notation "fold" "any" "not" "in" "*" :=
  fold any not in * |-; fold any not.

Tactic Notation "fold" "any" "not" "in" "*" "|-" "*" :=
  fold any not in *.

(** ** Folding [Iff]
    This section provides tactics for folding uses of [iff]
    wherever possible.  Multiple versions are provided that
    correspond to many of the forms used by the built-in
    conversion tactics.  These tactic may be better located
    somewhere else in the standard library: although it is
    used in this file, it has nothing to do with negation. *)

Tactic Notation "fold" "any" "iff" :=
  repeat (
    match goal with
    | |- context [(?P -> ?Q) /\ (?Q -> ?P)] =>
      fold (P <-> Q)
    end).

Tactic Notation "fold" "any" "iff" "in" ident(H) "|-" :=
  repeat (
    match goal with
    | J: context [(?P -> ?Q) /\ (?Q -> ?P)] |- _ =>
      fold (P <-> Q) in H
    end).

Tactic Notation "fold" "any" "iff" "in" ident(H) :=
  fold any iff in H |-.

Tactic Notation "fold" "any" "iff" "in" "*" "|-" :=
  repeat (
    match goal with
    | H: context [(?P -> ?Q) /\ (?Q -> ?P)] |- _ =>
      fold (P <-> Q) in H
    end).

Tactic Notation "fold" "any" "iff" "in" "*" :=
  fold any iff in * |-; fold any iff.

Tactic Notation "fold" "any" "iff" "in" "*" "|-" "*" :=
  fold any iff in *.

(** [push not using db] will push all negations to the leaves of
    propositions in the goal, using the lemmas in [db] to assist
    in checking the decidability of the propositions involved.
    If [using db] is omitted, then [core] will be used.
    Additional versions are provided to manipulate the
    hypotheses, following the conventions used by the built-in
    tactics.  (Is there a way to do this without using so much
    cut-and-paste?) *)

Tactic Notation "push" "not" "using" ident(db) :=
  unfold not, iff;
  repeat (
    match goal with
    (** simplification by not_true_iff *)
    | |- context [True -> False] =>
      rewrite not_true_iff
    (** simplification by not_false_iff *)
    | |- context [False -> False] =>
      rewrite not_false_iff
    (** simplification by not_not_iff *)
    | |- context [(?P -> False) -> False] =>
      rewrite (not_not_iff P);
        [ solve_decidable using db | ]
    (** simplification by contrapositive *)
    | |- context [(?P -> False) -> (?Q -> False)] =>
      rewrite (contrapositive P Q);
        [ solve_decidable using db | ]
    (** simplification by and_not_l_iff_1/_2 *)
    | |- context [(?P -> False) \/ ?Q] =>
      (rewrite (and_not_l_iff_1 P Q);
        [ solve_decidable using db | ]) ||
      (rewrite (and_not_l_iff_2 P Q);
        [ solve_decidable using db | ])
    (** simplification by and_not_r_iff_1/_2 *)
    | |- context [?P \/ (?Q -> False)] =>
      (rewrite (and_not_r_iff_1 P Q);
        [ solve_decidable using db | ]) ||
      (rewrite (and_not_r_iff_2 P Q);
        [ solve_decidable using db | ])
    (** simplification by imp_not_l *)
    | |- context [(?P -> False) -> ?Q] =>
      rewrite (imp_not_l P Q);
        [ solve_decidable using db | ]
    (** rewriting by not_or_iff *)
    | |- context [?P \/ ?Q -> False] =>
      rewrite (not_or_iff P Q)
    (** rewriting by not_and_iff *)
    | |- context [?P /\ ?Q -> False] =>
      rewrite (not_and_iff P Q)
    (** rewriting by not_imp_iff *)
    | |- context [(?P -> ?Q) -> False] =>
      rewrite (not_imp_iff P Q);
        [ solve_decidable using db | ]
    end);
  fold any not; fold any iff.

Tactic Notation "push" "not" :=
  push not using core.

Tactic Notation "push" "not" "in" ident(H) "|-"
  "using" ident(db) :=
  unfold not, iff in * |-;
  repeat (
    match goal with
    (** simplification by not_true_iff *)
    | J: context [True -> False] |- _ =>
      rewrite not_true_iff in H
    (** simplification by not_false_iff *)
    | J: context [False -> False] |- _ =>
      rewrite not_false_iff in H
    (** simplification by not_not_iff *)
    | J: context [(?P -> False) -> False] |- _ =>
      rewrite (not_not_iff P) in H;
        [ | solve_decidable using db ]
    (** simplification by contrapositive *)
    | J: context [(?P -> False) -> (?Q -> False)] |- _ =>
      rewrite (contrapositive P Q) in H;
        [ | solve_decidable using db ]
    (** simplification by and_not_l_iff_1/_2 *)
    | J: context [(?P -> False) \/ ?Q] |- _ =>
      (rewrite (and_not_l_iff_1 P Q) in H;
        [ | solve_decidable using db ]) ||
      (rewrite (and_not_l_iff_2 P Q) in H;
        [ | solve_decidable using db ])
    (** simplification by and_not_r_iff_1/_2 *)
    | J: context [?P \/ (?Q -> False)] |- _ =>
      (rewrite (and_not_r_iff_1 P Q) in H;
        [ | solve_decidable using db ]) ||
      (rewrite (and_not_r_iff_2 P Q) in H;
        [ | solve_decidable using db ])
    (** simplification by imp_not_l *)
    | J: context [(?P -> False) -> ?Q] |- _ =>
      rewrite (imp_not_l P Q) in H;
        [ | solve_decidable using db ]
    (** rewriting by not_or_iff *)
    | J: context [?P \/ ?Q -> False] |- _ =>
      rewrite (not_or_iff P Q) in H
    (** rewriting by not_and_iff *)
    | J: context [?P /\ ?Q -> False] |- _ =>
      rewrite (not_and_iff P Q) in H
    (** rewriting by not_imp_iff *)
    | J: context [(?P -> ?Q) -> False] |- _ =>
      rewrite (not_imp_iff P Q) in H;
        [ | solve_decidable using db ]
    end);
  fold any not in * |-; fold any iff in * |-.

Tactic Notation "push" "not" "in" ident(H) "|-"  :=
  push not in H |- using core.

Tactic Notation "push" "not" "in" ident(H) "using" ident(db) :=
  push not in H |- using db.
Tactic Notation "push" "not" "in" ident(H) :=
  push not in H |- using core.

Tactic Notation "push" "not" "in" "*" "|-" "using" ident(db) :=
  unfold not, iff in * |-;
  repeat (
    match goal with
    (** simplification by not_true_iff *)
    | H: context [True -> False] |- _ =>
      rewrite not_true_iff in H
    (** simplification by not_false_iff *)
    | H: context [False -> False] |- _ =>
      rewrite not_false_iff in H
    (** simplification by not_not_iff *)
    | H: context [(?P -> False) -> False] |- _ =>
      rewrite (not_not_iff P) in H;
        [ | solve_decidable using db ]
    (** simplification by contrapositive *)
    | H: context [(?P -> False) -> (?Q -> False)] |- _ =>
      rewrite (contrapositive P Q) in H;
        [ | solve_decidable using db ]
    (** simplification by and_not_l_iff_1/_2 *)
    | H: context [(?P -> False) \/ ?Q] |- _ =>
      (rewrite (and_not_l_iff_1 P Q) in H;
        [ | solve_decidable using db ]) ||
      (rewrite (and_not_l_iff_2 P Q) in H;
        [ | solve_decidable using db ])
    (** simplification by and_not_r_iff_1/_2 *)
    | H: context [?P \/ (?Q -> False)] |- _ =>
      (rewrite (and_not_r_iff_1 P Q) in H;
        [ | solve_decidable using db ]) ||
      (rewrite (and_not_r_iff_2 P Q) in H;
        [ | solve_decidable using db ])
    (** simplification by imp_not_l *)
    | H: context [(?P -> False) -> ?Q] |- _ =>
      rewrite (imp_not_l P Q) in H;
        [ | solve_decidable using db ]
    (** rewriting by not_or_iff *)
    | H: context [?P \/ ?Q -> False] |- _ =>
      rewrite (not_or_iff P Q) in H
    (** rewriting by not_and_iff *)
    | H: context [?P /\ ?Q -> False] |- _ =>
      rewrite (not_and_iff P Q) in H
    (** rewriting by not_imp_iff *)
    | H: context [(?P -> ?Q) -> False] |- _ =>
      rewrite (not_imp_iff P Q) in H;
        [ | solve_decidable using db ]
    end);
  fold any not in * |-; fold any iff in * |-.

Tactic Notation "push" "not" "in" "*" "|-"  :=
  push not in * |- using core.

Tactic Notation "push" "not" "in" "*" "using" ident(db) :=
  push not using db; push not in * |- using db.
Tactic Notation "push" "not" "in" "*" :=
  push not in * using core.

Tactic Notation "push" "not" "in" "*" "|-" "*"
  "using" ident(db) :=
  push not in * using db.
Tactic Notation "push" "not" "in" "*" "|-" "*" :=
  push not in * using core.

Lemma test_push : forall P Q R : Prop,
  decidable P ->
  decidable Q ->
  (~ True) ->
  (~ False) ->
  (~ ~ P) ->
  (~ (P /\ Q) -> ~ R) ->
  ((P /\ Q) \/ ~ R) ->
  (~ (P /\ Q) \/ R) ->
  (R \/ ~ (P /\ Q)) ->
  (~ R \/ (P /\ Q)) ->
  (~ P -> R) ->
  (~ ((R -> P) \/ (R -> Q))) ->
  (~ (P /\ R)) ->
  (~ (P -> R)) ->
  True.
Proof.
  intros. push not in *. tauto.
Qed.

(** [pull not using db] will pull as many negations as possible
    toward the top of the propositional formula in the goal,
    using the lemmas in [db] to assist in checking the
    decidability of the propositions involved.  If [using db] is
    omitted, then [core] will be used.  Additional versions are
    provided to manipulate the hypotheses, following the
    conventions used by the built-in tactics.  (Is there a way
    to do this without using so much cut-and-paste?) *)

Tactic Notation "pull" "not" "using" ident(db) :=
  unfold not, iff;
  repeat (
    match goal with
    (** simplification by not_true_iff *)
    | |- context [True -> False] =>
      rewrite not_true_iff
    (** simplification by not_false_iff *)
    | |- context [False -> False] =>
      rewrite not_false_iff
    (** simplification by not_not_iff *)
    | |- context [(?P -> False) -> False] =>
      rewrite (not_not_iff P);
        [ solve_decidable using db | ]
    (** simplification by contrapositive *)
    | |- context [(?P -> False) -> (?Q -> False)] =>
      rewrite (contrapositive P Q);
        [ solve_decidable using db | ]
    (** simplification by and_not_l_iff_1/_2 *)
    | |- context [(?P -> False) \/ ?Q] =>
      (rewrite (and_not_l_iff_1 P Q);
        [ solve_decidable using db | ]) ||
      (rewrite (and_not_l_iff_2 P Q);
        [ solve_decidable using db | ])
    (** simplification by and_not_r_iff_1/_2 *)
    | |- context [?P \/ (?Q -> False)] =>
      (rewrite (and_not_r_iff_1 P Q);
        [ solve_decidable using db | ]) ||
      (rewrite (and_not_r_iff_2 P Q);
        [ solve_decidable using db | ])
    (** simplification by imp_not_l *)
    | |- context [(?P -> False) -> ?Q] =>
      rewrite (imp_not_l P Q);
        [ solve_decidable using db | ]
    (** rewriting by not_or_iff *)
    | |- context [(?P -> False) /\ (?Q -> False)] =>
      rewrite <- (not_or_iff P Q)
    (** rewriting by not_and_iff *)
    | |- context [?P -> ?Q -> False] =>
      rewrite <- (not_and_iff P Q)
    (** rewriting by not_imp_iff *)
    | |- context [?P /\ (?Q -> False)] =>
      rewrite <- (not_imp_iff P Q);
        [ solve_decidable using db | ]
    (** rewriting by not_imp_rev_iff *)
    | |- context [(?Q -> False) /\ ?P] =>
      rewrite <- (not_imp_rev_iff P Q);
        [ solve_decidable using db | ]
    end);
  fold any not; fold any iff.

Tactic Notation "pull" "not" :=
  pull not using core.

Tactic Notation "pull" "not" "in" ident(H) "|-"
  "using" ident(db) :=
  unfold not, iff in * |-;
  repeat (
    match goal with
    (** simplification by not_true_iff *)
    | J: context [True -> False] |- _ =>
      rewrite not_true_iff in H
    (** simplification by not_false_iff *)
    | J: context [False -> False] |- _ =>
      rewrite not_false_iff in H
    (** simplification by not_not_iff *)
    | J: context [(?P -> False) -> False] |- _ =>
      rewrite (not_not_iff P) in H;
        [ | solve_decidable using db ]
    (** simplification by contrapositive *)
    | J: context [(?P -> False) -> (?Q -> False)] |- _ =>
      rewrite (contrapositive P Q) in H;
        [ | solve_decidable using db ]
    (** simplification by and_not_l_iff_1/_2 *)
    | J: context [(?P -> False) \/ ?Q] |- _ =>
      (rewrite (and_not_l_iff_1 P Q) in H;
        [ | solve_decidable using db ]) ||
      (rewrite (and_not_l_iff_2 P Q) in H;
        [ | solve_decidable using db ])
    (** simplification by and_not_r_iff_1/_2 *)
    | J: context [?P \/ (?Q -> False)] |- _ =>
      (rewrite (and_not_r_iff_1 P Q) in H;
        [ | solve_decidable using db ]) ||
      (rewrite (and_not_r_iff_2 P Q) in H;
        [ | solve_decidable using db ])
    (** simplification by imp_not_l *)
    | J: context [(?P -> False) -> ?Q] |- _ =>
      rewrite (imp_not_l P Q) in H;
        [ | solve_decidable using db ]
    (** rewriting by not_or_iff *)
    | J: context [(?P -> False) /\ (?Q -> False)] |- _ =>
      rewrite <- (not_or_iff P Q) in H
    (** rewriting by not_and_iff *)
    | J: context [?P -> ?Q -> False] |- _ =>
      rewrite <- (not_and_iff P Q) in H
    (** rewriting by not_imp_iff *)
    | J: context [?P /\ (?Q -> False)] |- _ =>
      rewrite <- (not_imp_iff P Q) in H;
        [ | solve_decidable using db ]
    (** rewriting by not_imp_rev_iff *)
    | J: context [(?Q -> False) /\ ?P] |- _ =>
      rewrite <- (not_imp_rev_iff P Q) in H;
        [ | solve_decidable using db ]
    end);
  fold any not in * |-; fold any iff in * |-.

Tactic Notation "pull" "not" "in" ident(H) "|-"  :=
  pull not in H |- using core.

Tactic Notation "pull" "not" "in" ident(H) "using" ident(db) :=
  pull not in H |- using db.
Tactic Notation "pull" "not" "in" ident(H) :=
  pull not in H |- using core.

Tactic Notation "pull" "not" "in" "*" "|-" "using" ident(db) :=
  unfold not, iff in * |-;
  repeat (
    match goal with
    (** simplification by not_true_iff *)
    | H: context [True -> False] |- _ =>
      rewrite not_true_iff in H
    (** simplification by not_false_iff *)
    | H: context [False -> False] |- _ =>
      rewrite not_false_iff in H
    (** simplification by not_not_iff *)
    | H: context [(?P -> False) -> False] |- _ =>
      rewrite (not_not_iff P) in H;
        [ | solve_decidable using db ]
    (** simplification by contrapositive *)
    | H: context [(?P -> False) -> (?Q -> False)] |- _ =>
      rewrite (contrapositive P Q) in H;
        [ | solve_decidable using db ]
    (** simplification by and_not_l_iff_1/_2 *)
    | H: context [(?P -> False) \/ ?Q] |- _ =>
      (rewrite (and_not_l_iff_1 P Q) in H;
        [ | solve_decidable using db ]) ||
      (rewrite (and_not_l_iff_2 P Q) in H;
        [ | solve_decidable using db ])
    (** simplification by and_not_r_iff_1/_2 *)
    | H: context [?P \/ (?Q -> False)] |- _ =>
      (rewrite (and_not_r_iff_1 P Q) in H;
        [ | solve_decidable using db ]) ||
      (rewrite (and_not_r_iff_2 P Q) in H;
        [ | solve_decidable using db ])
    (** simplification by imp_not_l *)
    | H: context [(?P -> False) -> ?Q] |- _ =>
      rewrite (imp_not_l P Q) in H;
        [ | solve_decidable using db ]
    (** rewriting by not_or_iff *)
    | H: context [(?P -> False) /\ (?Q -> False)] |- _ =>
      rewrite <- (not_or_iff P Q) in H
    (** rewriting by not_and_iff *)
    | H: context [?P -> ?Q -> False] |- _ =>
      rewrite <- (not_and_iff P Q) in H
    (** rewriting by not_imp_iff *)
    | H: context [?P /\ (?Q -> False)] |- _ =>
      rewrite <- (not_imp_iff P Q) in H;
        [ | solve_decidable using db ]
    (** rewriting by not_imp_rev_iff *)
    | H: context [(?Q -> False) /\ ?P] |- _ =>
      rewrite <- (not_imp_rev_iff P Q) in H;
        [ | solve_decidable using db ]
    end);
  fold any not in * |-; fold any iff in * |-.

Tactic Notation "pull" "not" "in" "*" "|-"  :=
  pull not in * |- using core.

Tactic Notation "pull" "not" "in" "*" "using" ident(db) :=
  pull not using db; pull not in * |- using db.
Tactic Notation "pull" "not" "in" "*" :=
  pull not in * using core.

Tactic Notation "pull" "not" "in" "*" "|-" "*"
  "using" ident(db) :=
  pull not in * using db.
Tactic Notation "pull" "not" "in" "*" "|-" "*" :=
  pull not in * using core.

Lemma test_pull : forall P Q R : Prop,
  decidable P ->
  decidable Q ->
  (~ True) ->
  (~ False) ->
  (~ ~ P) ->
  (~ (P /\ Q) -> ~ R) ->
  ((P /\ Q) \/ ~ R) ->
  (~ (P /\ Q) \/ R) ->
  (R \/ ~ (P /\ Q)) ->
  (~ R \/ (P /\ Q)) ->
  (~ P -> R) ->
  (~ (R -> P) /\ ~ (R -> Q)) ->
  (~ P \/ ~ R) ->
  (P /\ ~ R) ->
  (~ R /\ P) ->
  True.
Proof.
  intros. pull not in *. tauto.
Qed.


Load LFindLoad.
From lfind Require Import LFind.
Unset Printing Notations.
Set Printing Implicit.

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

Inductive lst : Type :=  Nil : lst | Cons : natural -> lst -> lst .

Inductive tree : Type := Node : natural -> tree -> tree -> tree |  Leaf : tree.

Inductive Pair : Type := mkpair : natural -> natural -> Pair
with Zlst : Type := zcons : Pair -> Zlst -> Zlst |  znil : Zlst.

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) : natural
           := match plus_arg0, plus_arg1 with
              | Zero, n => n
              | Succ n, m => Succ (plus n m)
              end.

Fixpoint mult (mult_arg0 : natural) (mult_arg1 : natural) : natural
           := match mult_arg0, mult_arg1 with
              | Zero, n => Zero
              | Succ n, m => plus (mult n m) m
              end.

Fixpoint fac (fac_arg0 : natural) : natural
           := match fac_arg0 with
              | Zero => Succ Zero
              | Succ n => mult (fac n) n
              end.

Fixpoint qfac (qfac_arg0 : natural) (qfac_arg1 : natural) : natural
           := match qfac_arg0, qfac_arg1 with
              | Zero, n => n
              | Succ n, m => qfac n (mult m n)
              end.
Lemma plus_succ : forall (x y : natural), plus x (Succ y) = Succ (plus x y).
Proof.
   intros.
   induction x.
   - reflexivity.
   - simpl. rewrite IHx. reflexivity.
Qed.

Lemma plus_assoc : forall (x y z : natural), plus (plus x y) z = plus x (plus y z).
Proof.
   intros.
   induction x.
   - reflexivity.
   - simpl. rewrite IHx. reflexivity.
Qed.

Lemma plus_zero : forall (x : natural), plus x Zero = x.
Proof.
   intros.
   induction x.
   - reflexivity.
   - simpl. rewrite IHx. reflexivity.
Qed.

Lemma plus_commut : forall (x y : natural), plus x y = plus y x.
Proof.
   intros.
   induction x.
   -
   rewrite plus_zero. reflexivity.
   - simpl. rewrite plus_succ. rewrite IHx. reflexivity.
Qed.

Lemma mult_zero : forall (x : natural), mult x Zero = Zero.
Proof.
   intros.
   induction x.
   - reflexivity.
   - simpl. rewrite IHx. reflexivity.
Qed.

Lemma mult_succ : forall (x y : natural), plus (mult x y) x = mult x (Succ y).
Proof.
   intros.
   induction x.
   - reflexivity.
   - simpl. rewrite plus_succ. rewrite plus_assoc. rewrite (plus_commut y x).
      rewrite <- plus_assoc. rewrite IHx. rewrite plus_succ. reflexivity.
Qed.

Lemma mult_commut : forall (x y : natural), mult x y = mult y x.
Proof.
   intros.
   induction x.
   -
     rewrite mult_zero. reflexivity.
   - simpl. rewrite IHx. rewrite mult_succ. reflexivity.
Qed.

Lemma distrib : forall (x y z : natural), mult (plus x y) z = plus (mult x z) (mult y z).
Proof.
   intros.
   induction x.
   - reflexivity.
   - simpl. rewrite IHx. rewrite plus_assoc. rewrite (plus_commut (mult y z) z).
     rewrite <- plus_assoc. reflexivity.
Qed.

Lemma mult_assoc : forall (x y z : natural), mult (mult x y) z = mult x (mult y z).
Proof.
   intros.
   induction x.
   - reflexivity.
   - simpl. rewrite distrib. rewrite IHx. reflexivity.
Qed.

Lemma qfac_mult : forall (x y : natural), qfac x y = mult (qfac x (Succ Zero)) y.
Proof.
   intro.
   induction x.
   - reflexivity.
   - intros. simpl. rewrite IHx. rewrite (IHx x). lfind. Admitted.


Definition BoolE : forall (p:bool -> Prop), p true -> p false -> forall (x:bool), p x :=
    fun (p:bool -> Prop) =>
        fun (tt:p true) =>
            fun (ff: p false) =>
                fun (x:bool) =>
                    match x with
                    | true  => tt
                    | false => ff
                    end.

Definition BoolC1 : bool := true.
Definition BoolC2 : bool := false.

Definition L1 : forall (x:bool), negb (negb x) = x.
Proof.
    intros x.
    apply (BoolE (fun z => negb (negb z) = z)).
    - exact (eq_refl true).
    - exact (eq_refl false).
Qed.

Definition L2 : forall (x:bool), negb (negb x) = x :=
    fun (x:bool) => BoolE
        (fun (z:bool) => negb (negb z) = z)
        (eq_refl true)
        (eq_refl false)
        x.

Definition BoolRec : forall (p:bool -> Type), p true -> p false -> forall (x:bool), p x :=
    fun (p:bool -> Type) =>
        fun (tt:p true) =>
            fun (ff: p false) =>
                fun (x:bool) =>
                    match x with
                    | true  => tt
                    | false => ff
                    end.

Definition not : bool -> bool := BoolRec (fun (x:bool) => bool) false true.

Definition L3 : not = fun(x:bool) => match x with true => false | false => true end :=
    eq_refl not.

Definition BoolE' : forall (p:bool -> Prop), p true -> p false -> forall (x:bool), p x :=
    fun (p:bool -> Prop) => BoolRec p.

Variable BoolE1 : forall (p:bool -> Prop), p true -> p false -> forall (x:bool), p x.

Definition L4 : forall (x:bool), x = true \/ x = false :=
    fun (x:bool) =>
        match x with
        | true  => or_introl (eq_refl true)
        | false => or_intror (eq_refl false)
        end.

Definition L5 : forall (x:bool), x = true \/ x = false := BoolE1
    (fun (x:bool) => x = true \/ x = false)
    (or_introl (eq_refl true))
    (or_intror (eq_refl false)).

Definition L6 : forall (p:bool -> Prop), (forall (x y:bool), y = x -> p x) -> forall (x:bool), p x :=
    fun (p:bool -> Prop) =>
        fun (q:forall (x y:bool), y = x -> p x) =>
            fun (x:bool) => q x x (eq_refl x).

Fail Definition L7 : forall (p:bool -> Prop) (x:bool), (x = true -> p true) -> (x = false -> p false) -> p x :=
    fun (p:bool -> Prop) =>
        fun (x:bool) =>
            fun (tt:x = true -> p true) =>
                fun (ff:x = false -> p false) =>
                    match x with
                    | true  => tt (eq_refl true)
                    | false => ff (eq_refl false)
                    end.

Definition bool_dec : forall (x:bool), x = true \/ x = false :=
    fun (x:bool) =>
        match x with
        | true  => or_introl (eq_refl true)
        | false => or_intror (eq_refl false)
        end.

Fail Definition L8 : forall (p:bool -> Prop) (x:bool), (x = true -> p true) -> (x = false -> p false) -> p x :=
    fun (p:bool -> Prop) =>
        fun (x:bool) =>
            fun (tt:x = true -> p true) =>
                fun (ff:x = false -> p false) =>
                    match bool_dec x with
                    | or_introl p  => tt p
                    | or_intror p  => ff p
                    end.

Definition bool_dec' : forall (x:bool), {x = true} + {x = false} :=
    fun (x:bool) =>
        match x with
        | true  => left  (eq_refl true)
        | false => right (eq_refl false)
        end.

Fail Definition L9 : forall (p:bool -> Prop) (x:bool), (x = true -> p true) -> (x = false -> p false) -> p x :=
    fun (p:bool -> Prop) =>
        fun (x:bool) =>
            fun (tt:x = true -> p true) =>
                fun (ff:x = false -> p false) =>
                    match bool_dec' x with
                    | left p   => tt p
                    | right p  => ff p
                    end.

Definition L10 : forall (p:bool -> Prop) (x:bool), (x = true -> p true) -> (x = false -> p false) -> p x.
Proof.
    intros p x H1 H2. destruct x.
    - apply H1. reflexivity.
    - apply H2. reflexivity.
Qed.

Definition L11 : forall (p:bool -> Prop) (x:bool), (x = true -> p true) -> (x = false -> p false) -> p x :=
    fun (p:bool -> Prop) (x:bool) (H1:x = true -> p true) (H2:x = false -> p false) =>
        match x as b return x = b -> p b with
        | true  => H1
        | false => H2
        end (eq_refl x).

Print L10.

Definition L12 : forall (p:bool -> Prop) (x:bool), (x = true -> p true) -> (x = false -> p false) -> p x :=
    fun (p:bool -> Prop) (x:bool) (H1:x = true -> p true) (H2:x = false -> p false) =>
        match x as b return  ((b = true -> p true) -> (b = false -> p false) -> p b) with
        | true  => fun (H3:true  = true -> p true) (_ :true  = false -> p false) => H3 (eq_refl true)
        | false => fun (_ :false = true -> p true) (H4:false = false -> p false) => H4 (eq_refl false)
        end H1 H2.

Definition and1 : bool -> bool -> bool := BoolRec
    (fun _ => bool -> bool)
    (fun y => y)
    (fun _ => false).

Definition and : bool -> bool -> bool :=
    fun (x:bool) =>
        fun(y:bool) => (BoolRec
            (fun _ => bool)
            y
            false) x.

(* and is computationally equal to ....                                        *)
Definition L13 : and = fun (x y:bool) => match x with true => y | false => false end.
Proof.
    unfold and. unfold BoolRec. reflexivity.
Qed.

Definition or : bool -> bool -> bool :=
    fun (x:bool) =>
        fun (y:bool) => (BoolRec
            (fun _ => bool)
            true
            y) x.

(* or is computationally equal to ....                                        *)
Definition L14 : or = fun (x y:bool) => match x with true => true | false => y end.
Proof.
    unfold or. unfold BoolRec. reflexivity.
Qed.

Definition L15 : forall (x y:bool), and x y = true <-> x = true /\ y = true.
Proof.
    intros x y. split; intros H.
    - unfold and in H. unfold BoolRec in H. destruct x.
        + split.
            { reflexivity. }
            { assumption. }
        + inversion H.
    - destruct H as [H1 H2]. rewrite H1. rewrite H2. reflexivity.
Qed.

Print L15.

Definition subst2 (a:Type) (p:a -> Prop) (x y:a) (e:x = y) (px: p x) : p y.
Proof.
   rewrite <- e. assumption.
Qed.

Definition subst1 (a:Type) (p:a -> Prop) (x y:a) (e:x = y) (px: p x) : p y.
Proof.
refine (
    match e with
    | eq_refl _ => px
    end
).
Defined.

Definition subst : forall (a:Type) (p:a -> Prop) (x y:a), x = y -> p x -> p y :=
    fun (a:Type) (p:a -> Prop) (x y:a) (e:x = y) (px:p x) =>
        match e with
        | eq_refl _ => px
        end.

Definition boolFalse : false = true -> False :=
    fun (e:false = true) =>
        subst bool (fun (b:bool) => if b then False else True) false true e I.

Definition contradiction : forall (p:Prop), False -> p :=
    fun (p:Prop) (H:False) => match H with end.

Definition subst2d : forall (a:Type) (p:a -> a -> Prop) (x x' y y':a),
    x = x' -> y = y' -> p x y -> p x' y' :=
    fun (a:Type) (p:a -> a -> Prop) (x x' y y':a) =>
        fun (ex:x = x') (ey:y = y') (pxy:p x y) =>
            match ex with
            | eq_refl _ =>
                match ey with
                | eq_refl _ => pxy
                end
            end.

Definition L16 : forall (x y:bool), and x y = true <-> x = true /\ y = true.
Proof.
    refine (fun (x y:bool) => conj
        (fun (H:and x y = true)       =>
            match x as b return (if b then y else false) = true -> b = true /\ y = true with
            | true  => fun (H1:y = true) => conj (eq_refl true) H1
            | false => fun (H1:false = true) => conj H1 (contradiction _ (boolFalse H1))
            end H)
        (fun (H:x = true /\ y = true) =>
            match H with
            | conj H1 H2 =>
                subst2d bool (fun x y => and x y = true)
                    true x true y (eq_sym H1) (eq_sym H2) (eq_refl true)
            end)
).
Qed.


(* Exercise 44 *)

Require Import BenB.

Variable D : Set.
Variables P Q S T : D -> Prop.
Variable R : D -> D -> Prop.

Theorem exercise_044 : (forall x, P x -> Q x) /\ (forall x, ~(P x /\ Q x)) -> (forall x, ~ P x).
Proof.
imp_i a1.
all_i a.
neg_i (Q a) a2.
neg_i (P a /\ Q a) a3.
all_e (forall x:D, ~(P x /\ Q x)) a.
con_e2 (forall x:D, P x -> Q x).
hyp a1.
con_i.
hyp a2.
hyp a3.
imp_e (P a).
all_e (forall x:D, P x -> Q x) a.
con_e1 (forall x:D, ~(P x /\ Q x)).
hyp a1.
hyp a2.
Qed.