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

 Colimits in self enriched categories

 We construct colimits in self enriched categories. Copowers in
 the self enriched category come from the tensor in the monoidal
 category.

 To show how the construction of colimits works, we show how to
 construct an initial object in the self-enriched category Suppose
 that `V` is a symmetric monoidal closed category and let `x` be
 an initial object in `V`. We want to show that `x` also is an
 initial object in the enriched sense. This means that for all
 objects `y`, we must show that `x ⊸ y` is terminal in `V`. So,
 we must show that for every `w` the type `w --> x ⊸ y` is
 contractible.

 Since `⊸` is right adjoint to `⊗`, the types `w --> x ⊸ y` and
 `w ⊗ x --> y` are equivalent. As such, it suffices to show that
 `w ⊗ x --> y` is contractible. This is equivalent to `w ⊗ x`
 being an initial object, so it suffices to show that `w ⊗ x` is
 initial. Since `V` is monoidal closed, we know that the functor
 `x ↦ w ⊗ x` is a left adjoint, and thus it preserves initial
 objects. Since `x` is initial, we also get that `w ⊗ x` is
 initial, so we conclude that `V` has an initial object in the
 enriched sense.

 Contents
 1. Initial objects
 2. Binary coproducts
 3. Coequalizers
 4. Copowers
 5. Type indexed coproducts

 *****************************************************************)
Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Adjunctions.Core.
Require Import UniMath.CategoryTheory.EnrichedCats.Enrichment.
Require Import UniMath.CategoryTheory.EnrichedCats.Examples.SelfEnriched.
Require Import UniMath.CategoryTheory.EnrichedCats.Colimits.EnrichedInitial.
Require Import UniMath.CategoryTheory.EnrichedCats.Colimits.EnrichedBinaryCoproducts.
Require Import UniMath.CategoryTheory.EnrichedCats.Colimits.EnrichedCoproducts.
Require Import UniMath.CategoryTheory.EnrichedCats.Colimits.EnrichedCoequalizers.
Require Import UniMath.CategoryTheory.EnrichedCats.Colimits.EnrichedCopowers.
Require Import UniMath.CategoryTheory.Monoidal.WhiskeredBifunctors.
Require Import UniMath.CategoryTheory.Monoidal.Categories.
Require Import UniMath.CategoryTheory.Monoidal.Structure.Symmetric.
Require Import UniMath.CategoryTheory.Monoidal.Structure.Closed.
Require Import UniMath.CategoryTheory.limits.Preservation.
Require Import UniMath.CategoryTheory.limits.initial.
Require Import UniMath.CategoryTheory.limits.bincoproducts.
Require Import UniMath.CategoryTheory.limits.coproducts.
Require Import UniMath.CategoryTheory.limits.coequalizers.
Require Import UniMath.CategoryTheory.limits.terminal.
Require Import UniMath.CategoryTheory.limits.binproducts.
Require Import UniMath.CategoryTheory.limits.equalizers.

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

Section SelfEnrichmentColimits.
  Context (V : sym_mon_closed_cat).

  (**
   1. Initial objects
   *)
  Definition self_enrichment_initial
             (v : Initial V)
    : initial_enriched (self_enrichment V).
  Proof.
    refine (pr1 v ,, _).
    intros x y ; cbn.
    use (iscontrweqb (internal_hom_equiv _ _ _)).
    exact (left_adjoint_preserves_initial
             _
             (sym_mon_closed_left_tensor_left_adjoint V y)
             _
             (pr2 v)
             x).
  Defined.

  (**
   2. Binary coproducts
   *)
  Section SelfEnrichedCoproduct.
    Context {x y : V}
            (c : BinCoproduct x y).

    Let ι₁ : I_{V} --> x ⊸ c
      := enriched_from_arr
           (self_enrichment V)
           (BinCoproductIn1 c).

    Let ι₂ : I_{V} --> y ⊸ c
      := enriched_from_arr
           (self_enrichment V)
           (BinCoproductIn2 c).

    Definition make_self_enriched_binary_coprod_cocone
      : enriched_binary_coprod_cocone (self_enrichment V) x y.
    Proof.
      use make_enriched_binary_coprod_cocone.
      - exact c.
      - exact ι₁.
      - exact ι₂.
    Defined.

    Definition self_enriched_is_binary_coprod_paths_weq
               {w z : V}
               (f : z --> x ⊸ w)
               (g : z --> y ⊸ w)
               (fg : z --> c ⊸ w)
      : (fg · precomp_arr (self_enrichment V) w (internal_to_arr ι₁) = f
         ×
         fg · precomp_arr (self_enrichment V) w (internal_to_arr ι₂) = g)
        ≃
        (identity z #⊗ BinCoproductIn1 c · (fg #⊗ identity c · internal_eval c w)
         =
         f #⊗ identity x · internal_eval x w)
        ×
        (identity z #⊗ BinCoproductIn2 c · (fg #⊗ identity c · internal_eval c w)
         =
         g #⊗ identity y · internal_eval y w).
    Proof.
      use weqimplimpl.
      - intros pq.
        split.
        + rewrite !assoc.
          rewrite <- tensor_split.
          pose (p := pr1 pq) ; cbn in p.
          rewrite self_enrichment_precomp in p.
          rewrite <- p.
          rewrite tensor_comp_r_id_r.
          rewrite !assoc'.
          rewrite internal_beta.
          rewrite !assoc.
          rewrite <- tensor_split'.
          apply maponpaths_2.
          apply maponpaths.
          rewrite internal_to_from_arr.
          apply idpath.
        + rewrite !assoc.
          rewrite <- tensor_split.
          pose (p := pr2 pq) ; cbn in p.
          rewrite self_enrichment_precomp in p.
          rewrite <- p.
          rewrite tensor_comp_r_id_r.
          rewrite !assoc'.
          rewrite internal_beta.
          rewrite !assoc.
          rewrite <- tensor_split'.
          apply maponpaths_2.
          apply maponpaths.
          rewrite internal_to_from_arr.
          apply idpath.
      - intros pq.
        split.
        + pose (p := pr1 pq).
          rewrite !assoc in p.
          rewrite <- tensor_split in p.
          use internal_funext.
          intros a h.
          rewrite tensor_comp_r_id_r.
          rewrite self_enrichment_precomp.
          rewrite !assoc'.
          rewrite internal_beta.
          rewrite (tensor_split f h).
          rewrite !assoc'.
          rewrite <- p.
          rewrite !assoc.
          apply maponpaths_2.
          rewrite <- !tensor_comp_mor.
          rewrite id_left, id_right.
          do 2 apply maponpaths.
          cbn.
          apply internal_to_from_arr.
        + pose (p := pr2 pq) ; cbn in p.
          rewrite !assoc in p.
          rewrite <- tensor_split in p.
          use internal_funext.
          intros a h.
          rewrite tensor_comp_r_id_r.
          rewrite self_enrichment_precomp.
          rewrite !assoc'.
          rewrite internal_beta.
          rewrite (tensor_split g h).
          rewrite !assoc'.
          rewrite <- p.
          rewrite !assoc.
          apply maponpaths_2.
          rewrite <- !tensor_comp_mor.
          rewrite id_left, id_right.
          do 2 apply maponpaths.
          cbn.
          apply internal_to_from_arr.
      - apply isapropdirprod ; apply homset_property.
      - apply isapropdirprod ; apply homset_property.
    Qed.

    Definition self_enriched_is_binary_coprod_weq
               {w z : V}
               (f : z --> x ⊸ w)
               (g : z --> y ⊸ w)
      : (∑ (fg : z --> c ⊸ w),
         fg · precomp_arr (self_enrichment V) w (internal_to_arr ι₁) = f
         ×
         fg · precomp_arr (self_enrichment V) w (internal_to_arr ι₂) = g)
        ≃
        (∑ (fg : z ⊗ c --> w),
         identity z #⊗ BinCoproductIn1 c · fg = f #⊗ identity x · internal_eval x w
         ×
         identity z #⊗ BinCoproductIn2 c · fg = g #⊗ identity y · internal_eval y w).
    Proof.
      use weqtotal2.
      - exact (internal_hom_equiv z c w).
      - exact (self_enriched_is_binary_coprod_paths_weq f g).
    Defined.

    Definition self_enriched_is_binary_coprod
      : is_binary_coprod_enriched
          (self_enrichment V)
          x y
          make_self_enriched_binary_coprod_cocone.
    Proof.
      intros w z f g.
      use (iscontrweqb (self_enriched_is_binary_coprod_weq f g)).
      apply (left_adjoint_preserves_bincoproduct
               _
               (sym_mon_closed_left_tensor_left_adjoint V z)
               _ _ _ _ _
               (pr2 c)).
    Defined.
  End SelfEnrichedCoproduct.

  Definition self_enrichment_binary_coproducts
             (coprodV : BinCoproducts V)
    : enrichment_binary_coprod (self_enrichment V)
    := λ x y,
       make_self_enriched_binary_coprod_cocone (coprodV x y)
       ,,
       self_enriched_is_binary_coprod (coprodV x y).

  (**
   3. Coequalizers
   *)
  Section SelfEnrichmentCoequalizer.
    Context {x y : V}
            {f g : x --> y}
            (c : Coequalizer f g).

    Let e : y --> c := CoequalizerArrow c.

    Definition make_self_enriched_coequalizer_cocone
      : enriched_coequalizer_cocone (self_enrichment V) f g.
    Proof.
      use make_enriched_coequalizer_cocone.
      - exact c.
      - exact (enriched_from_arr (self_enrichment V) e).
      - abstract
          (cbn ;
           rewrite !internal_to_from_arr ;
           exact (CoequalizerEqAr c)).
    Defined.

    Definition self_enriched_is_coequalizer_path_weq
               {w z : V}
               (h : z --> y ⊸ w)
               (φ : z --> c ⊸ w)
      : (φ · precomp_arr (self_enrichment V) w (internal_to_arr (internal_from_arr e))
         =
         h)
        ≃
        (identity z #⊗ CoequalizerArrow c · (φ #⊗ identity c · internal_eval c w)
         =
         h #⊗ identity y · internal_eval y w).
    Proof.
      use weqimplimpl.
      - intro p.
        rewrite self_enrichment_precomp in p.
        rewrite <- p.
        rewrite tensor_comp_id_r.
        rewrite !assoc'.
        rewrite internal_beta.
        rewrite internal_to_from_arr.
        rewrite !assoc.
        rewrite <- tensor_split.
        rewrite <- tensor_split'.
        apply idpath.
      - intro p.
        use internal_funext.
        intros a k.
        rewrite !assoc in p.
        rewrite <- tensor_split in p.
        rewrite self_enrichment_precomp.
        rewrite tensor_comp_r_id_r.
        rewrite !assoc'.
        rewrite internal_beta.
        rewrite internal_to_from_arr.
        rewrite (tensor_split h k).
        rewrite !assoc'.
        rewrite <- p.
        rewrite !assoc.
        rewrite <- !tensor_comp_mor.
        rewrite id_right.
        rewrite id_left.
        apply idpath.
      - apply homset_property.
      - apply homset_property.
    Qed.

    Definition self_enriched_is_coequalizer_weq
               {w z : V}
               (h : z --> y ⊸ w)
               (r : h · precomp_arr (self_enrichment V) w f
                    =
                    h · precomp_arr (self_enrichment V) w g)
      : (∑ (φ : z --> c ⊸ w),
         φ · precomp_arr (self_enrichment V) w (internal_to_arr (internal_from_arr e)) = h)
        ≃
        (∑ (φ : z ⊗ c --> w),
         identity z #⊗ CoequalizerArrow c · φ = h #⊗ identity _ · internal_eval y w).
    Proof.
      use weqtotal2.
      - exact (internal_hom_equiv z c w).
      - exact (self_enriched_is_coequalizer_path_weq h).
    Defined.

    Definition make_self_enriched_is_coequalizer
      : is_coequalizer_enriched
          (self_enrichment V)
          f g
          make_self_enriched_coequalizer_cocone.
    Proof.
      intros w z h r.
      use (iscontrweqb (self_enriched_is_coequalizer_weq h r)).
      refine (left_adjoint_preserves_coequalizer
                _
                (sym_mon_closed_left_tensor_left_adjoint V z)
                _ _ _ _ _ _ _ _
                (pr22 c)
                _ _ _).
      - cbn.
        rewrite <- !tensor_comp_id_l.
        apply maponpaths.
        apply CoequalizerEqAr.
      - abstract
          (cbn ;
           pose (maponpaths (λ z, z #⊗ identity _ · internal_eval _ _) r)
             as r' ;
           cbn in r' ;
           rewrite !self_enrichment_precomp in r' ;
           rewrite !tensor_comp_id_r in r' ;
           rewrite !assoc' in r' ;
           rewrite !internal_beta in r' ;
           rewrite !assoc in r' ;
           rewrite <- !tensor_split' in r' ;
           rewrite !assoc ;
           rewrite <- !tensor_split ;
           exact r').
    Defined.
  End SelfEnrichmentCoequalizer.

  Definition self_enrichment_coequalizers
             (coeqV : Coequalizers V)
    : enrichment_coequalizers (self_enrichment V)
    := λ x y f g,
       make_self_enriched_coequalizer_cocone (coeqV x y f g)
       ,,
       make_self_enriched_is_coequalizer (coeqV x y f g).

  (**
   4. Copowers
   *)
  Section SelfEnrichmentCopower.
    Context (v₁ v₂ : V).

    Definition self_enrichment_copower_cocone
      : copower_cocone (self_enrichment V) v₁ v₂.
    Proof.
      use make_copower_cocone.
      - exact (v₁ ⊗ v₂).
      - exact (internal_pair v₁ v₂).
    Defined.

    Proposition self_enrichment_is_copower_eq_1
                (w : V)
      : is_copower_enriched_map
          (self_enrichment V)
          v₁ v₂
          self_enrichment_copower_cocone
          w
        · internal_uncurry v₁ v₂ w
        =
        identity _.
    Proof.
      cbn.
      use internal_funext.
      intros a h.
      rewrite tensor_comp_r_id_r.
      rewrite !assoc'.
      unfold internal_uncurry.
      rewrite internal_beta.
      unfold is_copower_enriched_map.
      rewrite tensor_split.
      rewrite <- tensor_id_id.
      etrans.
      {
        rewrite !assoc'.
        apply maponpaths.
        rewrite !assoc.
        rewrite tensor_rassociator.
        rewrite !assoc'.
        apply maponpaths.
        rewrite !assoc.
        rewrite <- tensor_comp_id_r.
        rewrite internal_beta ; cbn.
        rewrite tensor_comp_id_r.
        rewrite !assoc'.
        unfold internal_comp.
        rewrite internal_beta.
        rewrite !assoc.
        rewrite tensor_lassociator.
        rewrite !assoc'.
        apply maponpaths.
        rewrite !assoc.
        rewrite <- tensor_comp_id_l.
        unfold internal_pair.
        rewrite internal_beta.
        rewrite tensor_id_id.
        apply id_left.
      }
      rewrite !assoc.
      apply maponpaths_2.
      rewrite !assoc'.
      rewrite mon_rassociator_lassociator.
      apply id_right.
    Qed.

    Proposition self_enrichment_is_copower_eq_2
                (w : V)
      : internal_uncurry v₁ v₂ w
        · is_copower_enriched_map
            (self_enrichment V)
            v₁ v₂
            self_enrichment_copower_cocone
            w
        =
        identity _.
    Proof.
      use internal_funext ; cbn.
      intros a₁ h₁.
      rewrite tensor_comp_r_id_r.
      rewrite !assoc'.
      unfold is_copower_enriched_map ; cbn.
      rewrite internal_beta.
      use internal_funext ; cbn.
      intros a₂ h₂.
      rewrite !tensor_comp_r_id_r.
      rewrite !assoc'.
      unfold internal_comp.
      rewrite internal_beta.
      etrans.
      {
        apply maponpaths.
        rewrite !assoc.
        rewrite tensor_lassociator.
        rewrite !assoc'.
        apply maponpaths.
        rewrite !assoc.
        rewrite <- tensor_comp_id_l.
        unfold internal_pair.
        rewrite internal_beta.
        rewrite tensor_id_id.
        apply id_left.
      }
      rewrite !assoc.
      rewrite tensor_lassociator.
      rewrite !assoc'.
      etrans.
      {
        apply maponpaths.
        rewrite tensor_split.
        rewrite !assoc'.
        unfold internal_uncurry.
        rewrite internal_beta.
        rewrite !assoc.
        rewrite tensor_rassociator.
        rewrite !assoc'.
        apply idpath.
      }
      rewrite !assoc.
      rewrite mon_lassociator_rassociator.
      rewrite id_left.
      apply idpath.
    Qed.

    Definition self_enrichment_is_copower
      : is_copower_enriched
          (self_enrichment V)
          v₁ v₂
          self_enrichment_copower_cocone.
    Proof.
      use make_is_copower_enriched.
      - exact (λ w, internal_uncurry v₁ v₂ w).
      - exact self_enrichment_is_copower_eq_1.
      - exact self_enrichment_is_copower_eq_2.
    Defined.
  End SelfEnrichmentCopower.

  Definition self_enrichment_copowers
    : enrichment_copower (self_enrichment V)
    := λ v₁ v₂,
       self_enrichment_copower_cocone v₁ v₂
       ,,
       self_enrichment_is_copower v₁ v₂.

  (**
   5. Type indexed coproducts
   *)
  Section SelfEnrichmentTypeCoproduct.
    Context {J : UU}
            {D : J → V}
            (coprod : Coproduct J V D).

    Let ι : ∏ (j : J), I_{V} --> D j ⊸ coprod
      := λ j,
         enriched_from_arr
           (self_enrichment V)
           (CoproductIn _ _ coprod j).

    Definition self_enriched_coprod_cocone
      : enriched_coprod_cocone (self_enrichment V) D.
    Proof.
      use make_enriched_coprod_cocone.
      - exact coprod.
      - exact ι.
    Defined.

    Definition self_enriched_is_coprod_weq_path
               {w z : V}
               (f : ∏ (j : J), z --> D j ⊸ w)
               (fs : z --> coprod ⊸ w)
               (j : J)
      : (fs · precomp_arr
                (self_enrichment V)
                w
                (internal_to_arr (internal_from_arr (CoproductIn J V coprod j)))
         =
         f j)
        ≃
        (identity z #⊗ CoproductIn J V coprod j
         · (fs #⊗ identity coprod · internal_eval coprod w)
         =
         f j #⊗ identity (D j) · internal_eval (D j) w).
    Proof.
      rewrite internal_to_from_arr.
      rewrite self_enrichment_precomp.
      rewrite !assoc.
      rewrite <- tensor_split.
      use weqimplimpl.
      - intro p.
        pose (maponpaths (λ z, z #⊗ identity _ · internal_eval _ _) p) as q.
        cbn in q.
        rewrite tensor_comp_id_r in q.
        rewrite !assoc' in q.
        rewrite internal_beta in q.
        rewrite !assoc in q.
        rewrite <- tensor_split' in q.
        exact q.
      - intro p.
        use internal_funext.
        intros a h.
        rewrite tensor_comp_r_id_r.
        rewrite !assoc'.
        rewrite internal_beta.
        rewrite !assoc.
        rewrite (tensor_split fs h).
        rewrite (tensor_split (f j) h).
        rewrite !assoc'.
        apply maponpaths.
        rewrite !assoc.
        rewrite <- tensor_split'.
        exact p.
      - apply homset_property.
      - apply homset_property.
    Qed.

    Definition self_enriched_is_coprod_weq
               {w z : V}
               (f : ∏ (j : J), z --> D j ⊸ w)
      : (∑ (fs : z --> coprod ⊸ w),
         ∏ (j : J),
         fs · precomp_arr (self_enrichment V) w (internal_to_arr (ι j)) = f j)
        ≃
        (∑ (fs : z ⊗ coprod --> w),
         ∏ (j : J),
         identity z #⊗ CoproductIn _ _ coprod j · fs
         =
         f j #⊗ identity _ · internal_eval (D j) w).
    Proof.
      use weqtotal2.
      - exact (internal_hom_equiv z coprod w).
      - intro fs ; cbn -[ι].
        use weqonsecfibers.
        intro j.
        apply self_enriched_is_coprod_weq_path.
    Defined.

    Definition self_enriched_is_coprod
      : is_coprod_enriched (self_enrichment V) D self_enriched_coprod_cocone.
    Proof.
      intros w z f.
      use (iscontrweqb (self_enriched_is_coprod_weq f)).
      apply (left_adjoint_preserves_coproduct
               _
               (sym_mon_closed_left_tensor_left_adjoint V z)
                _ _ _ _
               (pr2 coprod)).
    Defined.
  End SelfEnrichmentTypeCoproduct.

  Definition self_enrichment_coprod
             (J : UU)
             (HV : Coproducts J V)
    : enrichment_coprod (self_enrichment V) J
    := λ D,
       self_enriched_coprod_cocone (HV D)
       ,,
       self_enriched_is_coprod (HV D).
End SelfEnrichmentColimits.


Require Export GeoCoq.Elements.OriginalProofs.lemma_samesidesymmetric.
Require Export GeoCoq.Elements.OriginalProofs.lemma_planeseparation.

Section Euclid.

Context `{Ax:euclidean_neutral_ruler_compass}.

Lemma lemma_samenotopposite :
   forall A B C D,
   OS A B C D ->
   ~ TS A C D B.
Proof.
intros.
assert (OS B A C D) by (forward_using lemma_samesidesymmetric).
assert (~ TS A C D B).
 {
 intro.
 assert (TS B C D B) by (conclude lemma_planeseparation).
 let Tf:=fresh in
 assert (Tf:exists M, BetS B M B) by (conclude_def TS );destruct Tf as [M];spliter.
 assert (~ BetS B M B) by (conclude axiom_betweennessidentity).
 contradict.
 }
close.
Qed.

End Euclid.


(** Calculation of a compiler for the call-by-name lambda calculus +
arithmetic. *)

Require Import List.
Require Import ListIndex.
Require Import Tactics.

(** * Syntax *)

Inductive Expr : Set :=
| Val : nat -> Expr
| Add : Expr -> Expr -> Expr
| Var : nat -> Expr
| Abs : Expr -> Expr
| App : Expr -> Expr -> Expr.

(** * Semantics *)

(** We start with the evaluator for this language, which is taken from
Ager et al. "A functional correspondence between evaluators and
abstract machines" (we use Haskell syntax to describe the evaluator):
<<
type Env   = [Thunk]
data Thunk = Thunk (() -> Value)
data Value = Num Int | Clo (Thunk -> Value)

eval :: Expr -> Env -> Value
eval (Val n)   e = Num n
eval (Add x y) e = case eval x e of
                     Num n -> case eval y e of
                                Num m -> Num (n + m)
eval (Var i)   e = case e !! i of
                     Thunk t -> t ()
eval (Abs x)   e = Clo (\t -> eval x (t : e))
eval (App x y) e = case eval x e of
                     Clo f -> f (Thunk (\_ -> eval y e))
>>
After defunctionalisation and translation into relational form we
obtain the semantics below.  *)

Inductive Thunk : Set  :=
  | thunk : Expr -> list Thunk -> Thunk.

Definition Env : Set := list Thunk.

Inductive Value : Set :=
| Num : nat -> Value
| Clo : Expr -> Env -> Value.

Reserved Notation "x ⇓[ e ] y" (at level 80, no associativity).

Inductive eval : Expr -> Env -> Value -> Prop :=
| eval_val e n : Val n ⇓[e] Num n
| eval_add e x y m n : x ⇓[e] Num m -> y ⇓[e] Num n -> Add x y ⇓[e] Num (m + n)
| eval_var e e' x i v : nth e i = Some (thunk x e') -> x ⇓[e'] v -> Var i ⇓[e] v
| eval_abs e x : Abs x ⇓[e] Clo x e
| eval_app e e' x x' x'' y  : x ⇓[e] Clo x' e' -> x' ⇓[thunk y e :: e'] x'' -> App x y ⇓[e] x''
where "x ⇓[ e ] y" := (eval x e y).

(** * Compiler *)

Inductive Code : Set :=
| PUSH : nat -> Code -> Code
| ADD : Code -> Code
| RET : Code
| LOOKUP : nat -> Code -> Code
| APP : Code -> Code -> Code
| ABS : Code -> Code -> Code
| HALT : Code.

Fixpoint comp' (e : Expr) (c : Code) : Code :=
  match e with
    | Val n => PUSH n c
    | Add x y => comp' x (comp' y (ADD c))
    | Var i => LOOKUP i c
    | App x y => comp' x (APP (comp' y RET) c)
    | Abs x => ABS (comp' x RET) c
  end.

Definition comp (e : Expr) : Code := comp' e HALT.

(** * Virtual Machine *)

Inductive Thunk' : Set  :=
  | thunk' : Code -> list Thunk' -> Thunk'.

Definition Env' : Set := list Thunk'.

Inductive Value' : Set :=
| Num' : nat -> Value'
| Clo' : Code -> Env' -> Value'.

Inductive Elem : Set :=
| VAL : Value' -> Elem
| CLO : Code -> Env' -> Elem
.
Definition Stack : Set := list Elem.

Inductive Conf : Set :=
| conf : Code -> Stack -> Env' -> Conf.

Notation "⟨ x , y , e ⟩" := (conf x y e).

Reserved Notation "x ==> y" (at level 80, no associativity).
Inductive VM : Conf -> Conf -> Prop :=
| vm_push n c s e :  ⟨PUSH n c, s, e⟩ ==> ⟨c, VAL (Num' n) :: s, e⟩
| vm_add c m n s e : ⟨ADD c, VAL (Num' n) :: VAL (Num' m) :: s, e⟩
                       ==> ⟨c, VAL (Num'(m + n)) :: s, e⟩
| vm_ret v c e e' s  : ⟨RET, VAL v :: CLO c e :: s, e'⟩ ==> ⟨c, VAL v :: s, e⟩
| vm_lookup e e' i c c' s : nth e i = Some (thunk' c' e') -> ⟨LOOKUP i c, s, e ⟩ ==> ⟨c', CLO c e :: s, e' ⟩
| vm_app c c' c'' e e' s : ⟨APP c' c, VAL (Clo' c'' e') :: s, e⟩
                           ==> ⟨c'', CLO c e :: s, thunk' c' e :: e'⟩
| vm_abs c c' s e : ⟨ABS c' c, s, e ⟩ ==> ⟨c, VAL (Clo' c' e) :: s, e ⟩
where "x ==> y" := (VM x y).

(** Conversion functions from semantics to VM *)

Fixpoint convT (t : Thunk) : Thunk' :=
  match t with
    | thunk x e => thunk' (comp' x RET) (map convT e)
  end.

Definition convE : Env -> Env' := map convT.

Definition convV (v : Value) : Value' :=
  match v with
    | Num n => Num' n
    | Clo x e => Clo' (comp' x RET) (convE e)
  end.

(** * Calculation *)

(** Boilerplate to import calculation tactics *)

Module VM <: Preorder.
Definition Conf := Conf.
Definition VM := VM.
End VM.
Module VMCalc := Calculation VM.
Import VMCalc.

(** Specification of the compiler *)

Theorem spec p e r c s : p ⇓[e] r -> ⟨comp' p c, s, convE e⟩
                                 =>> ⟨c , VAL (convV r) :: s, convE e⟩.

(** Setup the induction proof *)

Proof.
  intros.
  generalize dependent c.
  generalize dependent s.
  induction H;intros.

(** Calculation of the compiler *)

(** - [Val n ⇓[e] Num n]: *)

  begin
  ⟨c, VAL (Num' n) :: s, convE e⟩.
  <== { apply vm_push }
  ⟨PUSH n c, s, convE e⟩.
  [].

(** - [Add x y ⇓[e] Num (m + n)]: *)

  begin
    ⟨c, VAL (Num' (m + n)) :: s, convE e ⟩.
  <== { apply vm_add }
    ⟨ADD c, VAL (Num' n) :: VAL (Num' m) :: s, convE e⟩.
  <<= { apply IHeval2 }
  ⟨comp' y (ADD c), VAL (Num' m) :: s, convE e⟩.
  <<= { apply IHeval1 }
  ⟨comp' x (comp' y (ADD c)), s, convE e⟩.
  [].

(** - [Var i ⇓[e] v]: *)

  begin
    ⟨c, VAL (convV v) :: s, convE e ⟩.
  <== {apply vm_ret}
    ⟨RET, VAL (convV v) :: CLO c (convE e) :: s, convE e'⟩.
  <<= {apply IHeval}
    ⟨comp' x RET, CLO c (convE e) :: s, convE e'⟩.
  <== {apply vm_lookup; unfold convE; rewrite nth_map}
    ⟨LOOKUP i c, s, convE e ⟩.
  [].

(** - [Abs x ⇓[e] Clo x e]: *)

  begin
    ⟨c, VAL (Clo' (comp' x RET) (convE e)) :: s, convE e ⟩.
  <== { apply vm_abs }
    ⟨ABS (comp' x RET) c, s, convE e ⟩.
  [].

(** - [App x y ⇓[e] x'']: *)

  begin
    ⟨c, VAL (convV x'') :: s, convE e ⟩.
  <== { apply vm_ret }
    ⟨RET, VAL (convV x'') :: CLO c (convE e) :: s, convE (thunk y e :: e') ⟩.
  <<= { apply IHeval2 }
    ⟨comp' x' RET, CLO c (convE e) :: s, convE (thunk y e :: e') ⟩.
  = {reflexivity}
    ⟨comp' x' RET, CLO c (convE e) :: s, thunk' (comp' y RET) (convE e) :: convE e' ⟩.
  <== { apply vm_app }
    ⟨APP (comp' y RET) c, VAL (Clo' (comp' x' RET) (convE e')) :: s, convE e ⟩.
  = { reflexivity }
    ⟨APP (comp' y RET) c, VAL (convV (Clo x' e')) :: s, convE e ⟩.
  <<= { apply IHeval1 }
    ⟨comp' x (APP (comp' y RET) c), s, convE e ⟩.
  [].
Qed.

(** * Soundness *)

Lemma determ_vm : determ VM.
  intros C C1 C2 V. induction V; intro V'; inversion V'; subst; congruence.
Qed.

Definition terminates (p : Expr) : Prop := exists r, p ⇓[nil] r.

Theorem sound p s C : terminates p -> ⟨comp p, s, nil⟩ =>>! C ->
                          exists r, C = ⟨HALT , VAL (convV r) :: s, nil⟩ /\ p ⇓[nil] r.
Proof.
  unfold terminates. intros. destruct H as [r T].

  pose (spec p nil r HALT s) as H'. exists r. split. pose (determ_trc determ_vm) as D.
  unfold determ in D. eapply D. eassumption. split. auto. intro. destruct H.
  inversion H. assumption.
Qed.


Require Import CPidgin.Data.List.
Require Import CPidgin.Data.Maybe.
Require Import CPidgin.Data.Monoid.
Require Import CPidgin.Data.Semigroup.
Require Import Coq.Arith.Compare_dec.
Require Import PeanoNat.

Module ListTheorems.

Import Maybe.
Import Monoid.
Import List.
Import Semigroup.

(* head of [] returns Nothing. *)
Lemma list_head_nil_none:
    forall (A : Type),
        head ([] : List A) = Nothing.
Proof.
    intros.
    unfold head.
    trivial.
Qed.

(* head of x :: xs returns x. *)
Lemma list_head_cons:
    forall (A : Type) (x : A) (xs : List A),
        head (x :: xs) = Just x.
Proof.
    intros.
    unfold head.
    trivial.
Qed.

(* tail of [] is []. *)
Lemma list_tail_nil:
    forall (A : Type),
        tail ([] : List A) = [].
Proof.
    intros.
    unfold tail.
    trivial.
Qed.

(* tail of x :: xs is xs. *)
Lemma list_tail_cons:
    forall (A : Type) (x : A) (xs : List A),
        tail (x :: xs) = xs.
Proof.
    intros.
    unfold tail.
    trivial.
Qed.

(* helper to create a duplicate list of a given size. *)
Fixpoint dupList {A : Type} (n : nat) (m : A) (ls : List A) : List A :=
    match n with
        | 0 => ls
        | S n' => m :: dupList n' m ls
    end.

(* proof that we can unroll drop by 1. *)
Lemma list_drop_unroll:
    forall (A : Type) (n : nat) (x : A) (xs : List A),
        drop (S n) (x :: xs) = drop n xs.
Proof.
    intros.
    unfold drop.
    trivial.
Qed.

(* proof that we can unroll dupList by 1. *)
Lemma list_dupList_unroll:
    forall (A : Type) (n : nat) (x : A) (xs : List A),
        dupList (S n) x xs = x :: dupList n x xs.
Proof.
    intros.
    unfold dupList.
    trivial.
Qed.

(* proof that drop n drops n values from a list. *)
Lemma list_drop:
    forall (A : Type) (n : nat) (x : A) (xs : List A),
        drop n (dupList n x xs) = xs.
Proof.
    intros.
    induction n.
    1: {
        unfold drop.
        unfold dupList.
        trivial.
    }
    1: {
        rewrite list_dupList_unroll.
        rewrite list_drop_unroll.
        rewrite IHn.
        trivial.
    }
Qed.

(* Proof that we can unroll length by one. *)
Lemma list_length_unroll:
    forall (A : Type) (l : List A) (m : A),
        length (m :: l) = S (length l).
Proof.
    intros.
    unfold length.
    trivial.
Qed.

(* Proof that append and cons are commutative. *)
Lemma list_append_cons_commute:
    forall (A : Type) (l1 l2 : List A) (m : A),
        (m :: l1) ++ l2 = m :: (l1 ++ l2).
Proof.
    intros.
    unfold append.
    trivial.
Qed.

(* Proof that succ is associative wrt addition. *)
Lemma nat_succ_plus_assoc:
    forall (n1 n2 : nat),
        S (n1 + n2) = S n1 + n2.
Proof.
    intros.
    unfold plus.
    trivial.
Qed.

(* Proof that the length of two lists appended is the same as their lengths
   added. *)
Lemma list_length_append:
    forall (A : Type) (l1 l2 : List A),
        length (l1 ++ l2) = (length l1) + (length l2).
Proof.
    intros.
    induction l1.
    1: {
        unfold append.
        unfold length.
        trivial.
    }
    1: {
        rewrite list_append_cons_commute.
        rewrite list_length_unroll.
        rewrite list_length_unroll.
        rewrite IHl1.
        rewrite nat_succ_plus_assoc.
        trivial.
    }
Qed.

(* Proof that dropping the length of a list results in an empty list. *)
Lemma list_drop_length_empty:
    forall (A : Type) (l : List A),
        drop (length l) l = [].
Proof.
    intros.
    induction l.
    1: {
        unfold length.
        unfold drop.
        trivial.
    }
    1: {
        rewrite list_length_unroll.
        rewrite list_drop_unroll.
        rewrite IHl.
        trivial.
    }
Qed.

(* Proof that we can append two lists, drop the first list, and get the second
   list. *)
Lemma list_drop_append_length:
    forall (A : Type) (l1 l2 : List A),
        drop (length l1) (l1 ++ l2) = l2.
Proof.
    intros.
    induction l1.
    1: {
        unfold length.
        unfold drop.
        unfold append.
        trivial.
    }
    1: {
        rewrite list_length_unroll.
        rewrite list_append_cons_commute.
        rewrite list_drop_unroll.
        rewrite IHl1.
        trivial.
    }
Qed.

(* Proof that we can unroll take. *)
Lemma list_take_unroll:
    forall (A : Type) (l : List A) (m : A) (n : nat),
        take (S n) (m :: l) = m :: take n l.
Proof.
    intros.
    unfold take.
    trivial.
Qed.

(* Proof that taking the length from a list is that list. *)
Lemma list_take_length:
    forall (A : Type) (l : List A),
        take (length l) l = l.
Proof.
    intros.
    induction l.
    1: {
        unfold length.
        unfold take.
        trivial.
    }
    1: {
        rewrite list_length_unroll.
        rewrite list_take_unroll.
        rewrite IHl.
        trivial.
    }
Qed.

(* Proof that we can take the first list from apending two lists. *)
Lemma list_append_take:
    forall (A : Type) (l1 l2 : List A),
        take (length l1) (l1 ++ l2) = l1.
Proof.
    intros.
    induction l1.
    1: {
        unfold length.
        unfold append.
        unfold take.
        trivial.
    }
    1: {
        rewrite list_append_cons_commute.
        rewrite list_length_unroll.
        rewrite list_take_unroll.
        rewrite IHl1.
        trivial.
    }
Qed.

(* Proof that we can unroll nth. *)
Definition list_nth_unroll:
    forall (A : Type) (n : nat) (l : List A) (m : A),
        nth (S n) (m :: l) = nth n l.
Proof.
    intros.
    unfold nth.
    rewrite list_drop_unroll.
    destruct n.
    unfold drop.
    trivial.
    trivial.
Qed.

(* Proof that we can take the nth item from an arbitrary list. *)
Definition list_nth_append_concat:
    forall (A : Type) (l1 l2 : List A) (m : A),
        nth (length l1) (l1 ++ (m :: l2)) = Just m.
Proof.
    intros.
    unfold nth.
    destruct l1.
    unfold length.
    unfold append.
    unfold head.
    trivial.
    rewrite list_length_unroll.
    rewrite list_append_cons_commute.
    rewrite list_drop_unroll.
    rewrite list_drop_append_length.
    unfold head.
    trivial.
Qed.

(* Proof that we can unroll removeNth by one. *)
Lemma list_remove_nth_unroll:
    forall (A : Type) (n : nat) (l : List A) (m : A),
        removeNth (S n) (m :: l) = m :: removeNth n l.
Proof.
    intros.
    unfold removeNth.
    trivial.
Qed.

(* Proof that we can remove an element from a list. *)
Lemma list_remove_nth:
    forall (A : Type) (l1 l2 : List A) (m : A),
        removeNth (length l1) (l1 ++ (m :: l2)) = l1 ++ l2.
Proof.
    intros.
    induction l1.
    unfold length.
    unfold removeNth.
    unfold tail.
    unfold append.
    trivial.
    rewrite list_length_unroll.
    rewrite list_append_cons_commute.
    rewrite list_append_cons_commute.
    rewrite list_remove_nth_unroll.
    rewrite IHl1.
    trivial.
Qed.

(* Proof that removing the nth element from an empty list returns the empty
   list. *)
Lemma list_remove_nth_empty:
    forall (A : Type) (n : nat),
        removeNth n ([] : List A) = [].
Proof.
    intros.
    unfold removeNth.
    destruct n.
    unfold tail.
    trivial.
    trivial.
Qed.

(* Proof that a list can be destructed as a left append of an empty list and
   itself. *)
Lemma list_empty_left_append:
    forall (A : Type) (l : List A),
        l = [] ++ l.
Proof.
    intros.
    unfold append.
    trivial.
Qed.

(* Proof that a list can be destructed as a right append of an empty list and
   itself. *)
Lemma list_empty_right_append:
    forall (A : Type) (l : List A),
        l = l ++ [].
Proof.
    intros.
    induction l.
    unfold append.
    trivial.
    rewrite list_append_cons_commute.
    rewrite <- IHl.
    trivial.
Qed.

(* Proof that list append follows the Semigroup Associativity Law. *)
Lemma list_append_semigroup_associativity:
    forall (A : Type) (x y z : List A),
        (x <o> y) <o> z = x <o> (y <o> z).
Proof.
    intros.
    unfold op.
    unfold listSemigroup.
    unfold append.
    induction x.
    induction y.
    induction z.
    trivial.
    trivial.
    trivial.
    rewrite IHx.
    trivial.
Qed.

(* Proof that the list append monoid has a left identity. *)
Lemma list_append_monoid_left_identity:
    forall (A : Type) (x : List A),
        mempty <o> x = x.
Proof.
    intros.
    unfold mempty.
    unfold listMonoid.
    unfold op.
    unfold listSemigroup.
    unfold append.
    trivial.
Qed.

(* Proof that the list append monoid has a right identity. *)
Lemma list_append_monoid_right_identity:
    forall (A : Type) (x : List A),
        x <o> mempty = x.
Proof.
    intros.
    unfold mempty.
    unfold listMonoid.
    unfold op.
    unfold listSemigroup.
    unfold append.
    induction x.
    trivial.
    rewrite IHx.
    trivial.
Qed.

End ListTheorems.


Check (forall A:Set, A -> A).

Definition id (A:Set) (a:A) : A := a.

Check (forall A B:Set, (A -> A -> B) -> A -> B).

Definition diag (A B:Set) (f:A -> A -> B) (a:A) : B := f a a.

Check (forall A B C:Set, (A -> B -> C) -> B -> A -> C).

Definition permute (A B C:Set) (f:A -> B -> C) (b:B) (a:A) : C := f a b.

Require Import ZArith.

Check (forall A:Set, (nat -> A) -> Z -> A).

Definition f_nat_Z (A:Set) (f:nat -> A) (z:Z) : A := f (Zabs_nat z).


Require Import Reals.
Require Import Field Psatz.
From mathcomp Require Import all_ssreflect.

Section Edwards.

(* First create a field *)
Variable K : Set.

Variables kO kI : K.
Notation "0" := kO.
Notation "1" := kI.

Hypothesis one_not_zero: 1 <> 0.

Variable kplus kmul ksub kdiv : K -> K -> K.
Notation "x + y" := (kplus x y).
Notation "x * y " := (kmul x y).
Notation "x - y " := (ksub x y).
Notation "x / y" := (kdiv x y).

Variables kopp kinv :  K -> K.
Notation "- x" := (kopp x).
Notation "/ x" := (kinv x).

(* Test to zero *)
Variable is_zero: K -> bool.

Hypothesis is_zero_correct : forall k, is_zero k = true <-> k = 0.

(* It is a field *)
Variable Kfth :  field_theory kO kI kplus kmul ksub kopp kdiv kinv (@eq K).

(* Trick to get the power function *)
Fixpoint pow (k: K) (n: nat) :=
 match n with O => 1 | 1%nat => k | S n1 => k * pow k n1 end.

Notation "x ^ y" := (pow x y).

Lemma pow_S k n : k ^ (S n) = k * k ^ n.
Proof.
case: n => //=.
by rewrite Kfth.(F_R).(Rmul_comm) Kfth.(F_R).(Rmul_1_l).
Qed.

Let Mkmul := rmul_ext3_Proper (Eq_ext kplus kmul kopp).

Lemma Kpower_theory :
  Ring_theory.power_theory 1 kmul (eq (A:=K)) BinNat.nat_of_N pow.
Proof.
constructor => r [|] //=.
elim/BinPos.Pind => // n H.
rewrite Pnat.nat_of_P_succ_morphism pow_S.
rewrite (Ring_theory.pow_pos_succ (Eqsth K) Mkmul) ?H //.
exact Kfth.(F_R).(Rmul_assoc).
Qed.

Ltac iskpow_coef t :=
  match t with
  | (S ?x) => iskpow_coef x
  | O => true
  | _ => false
  end.

Ltac kpow_tac t :=
 match iskpow_coef t with
 | true => constr:(BinNat.N_of_nat t)
 | _ => constr:(NotConstant)
 end.

Add Field Kfth : Kfth (power_tac Kpower_theory [kpow_tac]).

Lemma Kmult_integral x y : x * y = 0 -> x = 0 \/ y = 0.
Proof.
move=> H.
case: (is_zero x) (is_zero_correct x) => [[H1 _]|[_ H1]].
  by left; apply: H1.
right.
apply: trans_equal (_ : (/x) * (x * y) = _); try field.
  by move=> /H1.
rewrite H; ring.
Qed.

Lemma Kdiv_0_l x : 0 / x = 0.
Proof. rewrite (Fdiv_def Kfth); ring. Qed.

Lemma Kdiv_eq_0_compat_r x y : x = 0 -> x / y = 0.
Proof. rewrite (Fdiv_def Kfth)=>->; ring. Qed.

(* We can now start the elliptic part *)

Variables cs d : K.

Definition c := cs * cs.

(* not a non-zero square *)
Definition ns v := forall x, v = x * x -> v = 0.

Lemma nsD v y : ns v -> 1 - v * y * y <> 0.
Proof.
move=> H.
have := is_zero_correct v.
case: is_zero => // [[-> // _]|[_ H1] H2].
  contradict one_not_zero.
  by rewrite -one_not_zero; ring.
have H0 : v * y * y = 1.
  rewrite (_ : 1 = 1 - 0); last by ring.
  by rewrite -H2; ring.
have H3 : y <> 0.
  move=> H3; rewrite H3 in H0.
  case: one_not_zero.
  by rewrite -H0; ring.
suff : false = true by [].
apply/H1/(H (1 / y)).
by field[H0].
Qed.

Hypothesis ns_d : ns d.

(* A point *)
Notation point := (K * K)%type.

Implicit Types p q : point.

Definition dx p q := 1 - d * p.1 * p.2 * q.1 * q.2.

Lemma dxC p q : dx p q = dx q p.
Proof. rewrite /dx; ring. Qed.

Definition dy p q := 1 + d * p.1 * p.2 * q.1 * q.2.

Lemma dyC p q : dy p q = dy q p.
Proof. rewrite /dy; ring. Qed.

Definition dd p q :=
  1 - d * d * p.1 * p.1 * p.2 * p.2 *
              q.1 * q.1 * q.2 * q.2.

Lemma ddE p q : dd p q = dx p q * dy p q.
Proof. rewrite /dd /dx /dy; ring. Qed.

Lemma ddC p q : dd p q = dd q p.
Proof. rewrite !ddE dxC dyC; ring. Qed.

Definition add p q : point :=
 (/(dx p q) * (p.1 * q.1 - c * p.2 * q.2),
  /(dy p q) * (p.1 * q.2 + q.1 * p.2)).

Infix "++" := add.

(* Adding is commutative *)
Lemma addC p q : p ++ q = q ++ p.
Proof. rewrite /add dxC dyC; congr (_, _); ring. Qed.

Definition d0 : point := (1, 0).

Lemma add0C p : d0 ++ p = p.
Proof.
case: p => x y.
by rewrite /add /dx /dy /=; congr (_, _); field.
Qed.

Definition on p :=
  d * p.1 * p.1 * p.2 * p.2 = p.1 * p.1 + c * p.2 * p.2 - 1.

(* 0 is on the curve *)
Lemma on0 : on d0.
Proof. rewrite /on /d0 /=; ring. Qed.

(* Opposite *)
Definition opp p : point := (p.1,-p.2).

Notation "-- x" := (opp x) (at level 10).

(* The opposite is on the curve *)
Lemma on_opp p : on p -> on (-- p).
Proof.
case: p => x y; rewrite /on /= => H; ring[H].
Qed.

(* If we are on the curve, we can divide by dd *)
Lemma on_dd p q : on p -> on q -> dd p q <> 0.
Proof.
case: p => x1 y1; case: q => x2 y2.
have F x : 1 - x = 0 -> x = 1.
  move=> H.
  replace 1 with (1 - x + x) by ring.
  by rewrite H; ring.
pose r := (1 - c * d * y1 * y1 * y2 * y2) *
          (1 - d * y1 * y1 * x2 * x2).
rewrite /on /dd /= => H1 H2 /F H3.
have /Kmult_integral[H|H] : r = 0.
- rewrite /r.
(* here we mimic a grobner computation *)
  ring_simplify [H1 H2] in H3.
  set u := _ * c ^ 2 in H3.
  have: u = u - 1 + 1 by ring.
  rewrite -[in u - _]H3 => H4; ring_simplify in H4; rewrite /u in H4.
  ring_simplify[H1 H2].
  ring_simplify[H4].
  ring_simplify[H1 H2].
  ring[H4].
- case (nsD _ (cs * y1 * y2) ns_d).
  by rewrite -H /c; ring.
case (nsD _ (y1 * x2) ns_d).
by rewrite -H /c; ring.
Time Qed.

(* If we are on the curve, we can divide by dx *)
Lemma on_dx p q : on p -> on q -> dx p q <> 0.
Proof.
intros H1 H2 H.
case (on_dd _ _ H1 H2).
rewrite ddE; ring[H].
Qed.

(* If we are on the curve, we can divide by dy *)
Lemma on_dy p q : on p -> on q -> dy p q <> 0.
Proof.
intros H1 H2 H.
case (on_dd _ _ H1 H2).
rewrite ddE; ring[H].
Qed.

(* Adding the opposite give 0 *)
Lemma addnK p : on p -> p ++ -- p = d0.
Proof.
intro H1.
have H2 := on_opp _ H1.
move: {H2}H1 (on_dx _ _ H1 H2) (on_dy _ _ H1 H2).
case: p => x y.
rewrite  /on /add /dx /dy /= => H1 H2 H3.
by congr (_, _); field[H1].
Qed.

(* Adding two elements of the curve gives an element of the curve *)
Lemma on_add p q : on p -> on q -> on (p ++ q).
Proof.
move=> H1 H2.
move: H1 H2 (on_dx _ _ H1 H2) (on_dy _ _ H1 H2).
case: p => x1 y1; case: q => x2 y2.
rewrite /on /= /dx /dy /= => H1 H2 H3 H4.
field_simplify => //.
congr (_ / _).
ring [H1 H2].
Time Qed.

(* Adding is associative *)
Lemma add_assoc p q r :
   on p -> on q -> on r -> (p ++ q) ++ r = p ++ (q ++ r).
Proof.
move=> H1 H2 H3.
move: H1 H2 H3 (on_dx _ _ H1 H2) (on_dy _ _ H1 H2)
               (on_dx _ _ H2 H3) (on_dy _ _ H2 H3)
               (on_dx _ _  H1 (on_add _ _ H2 H3))
               (on_dy _ _  H1 (on_add _ _ H2 H3))
               (on_dx _ _  (on_add _ _ H1 H2) H3)
               (on_dy _ _  (on_add _ _ H1 H2) H3).
case: p => x1 y1; case: q => x2 y2; case: r => x3 y3.
rewrite /add /on /= /dx /dy /= => H1 H2 H3 H4 H5 H6 H7 H8 H9 H10 H11.
congr (_,_).
  field[H1 H2 H3]; repeat split => //.
    contradict H8; field_simplify; last by split.
    apply: Kdiv_eq_0_compat_r.
    by rewrite -H8; ring.
  contradict H10; field_simplify; last by split.
  apply: Kdiv_eq_0_compat_r.
  by rewrite -H10; ring.
Time field[H1 H2 H3]=> //.
repeat split => //.
  contradict H9; field_simplify; last by split.
  apply: Kdiv_eq_0_compat_r.
  by rewrite -H9; ring.
contradict H11; field_simplify; last by split; auto.
apply: Kdiv_eq_0_compat_r.
rewrite -H11; ring.
Time Qed.

End Edwards.


Require Import EqNat.
Require Import List.
Require Import ListSet.
Require Import PropLogic.

Import ListNotations.

(* define when two assign. agree on the atomic formulas *)
Inductive in_assignment: atomic -> assignment -> Prop :=
| in1 : forall a tv,
          in_assignment a [(a, tv)]
| in2 : forall a b c,
          in_assignment a b -> in_assignment a (c::b).

Inductive suitable_2 : formula -> assignment -> Prop :=
| s1 : forall atm a b,
         in_assignment atm a -> suitable_2 (Atom atm) a -> suitable_2 (Atom atm) (b::a)
| s2 : forall f a b,
         suitable_2 f a -> suitable_2 (Negation f) a -> suitable_2 (Negation f) (b::a)
| s3 : forall f g a b,
         suitable_2 f a /\ suitable_2 g a -> suitable_2 (Disjunction f g) a -> suitable_2 (Disjunction f g) (b::a).

(*   s1 : forall (a : assignment)  (atm : atomic), *)
(*          in_assignment atm a -> suitable_2 (Atom atm) a *)
(* | s2 : forall f a b, *)
(*          suitable_2 f a -> suitable_2 f (b::a). *)
(* | s2 : forall f a, *)
(*          suitable_2 f a -> suitable_2 (Negation f) a *)
(* | s3 : forall f g a, *)
(*          suitable_2 f a -> suitable_2 g a -> suitable_2 (Disjunction f g) a. *)

Inductive agree : assignment -> assignment -> list atomic -> Prop :=
  a1 : forall a b,
         agree a b []
| a2 : forall a b c d,
         agree a b c -> in_assignment d a /\ in_assignment d b -> agree a b (d::c).

Fixpoint atomicfs (f : formula) : list atomic :=
  match f with
    | Atom atm => [atm]
    | Negation f' => atomicfs f'
    | Disjunction f' g => atomicfs f' ++ atomicfs g
  end.

Lemma all_formulae_have_atoms: forall F,
                                 atomicfs F <> [].
Proof.
  unfold not.
  induction F; try (intros; inversion H).
  apply IHF.
  apply H1.
  apply app_eq_nil in H1.
  inversion H1.
  generalize H0.
  apply IHF1.
Qed.

Lemma empty_assignment_not_suitable: forall F,
                                       suitable_2 F [] -> False.
Proof.
  intros.
  inversion H.
Qed.

Lemma suitable_atomic_bidirectional: forall a atm,
                                       suitable_2 (Atom atm) a -> in_assignment atm a.
  induction atm.
  intros.
  inversion H.
  apply in2.
  apply H1.
Qed.

Lemma atoms_negation_invariant: forall F,
                                  atomicfs F = atomicfs (Negation F).
Proof.
  induction F; simpl; reflexivity.
Qed.

Lemma atoms_disjunction_invariant: forall F G,
                                     atomicfs F ++ atomicfs G = atomicfs (Disjunction F G).
Proof.
  induction F; destruct G; simpl; reflexivity.
Qed.

Lemma negation_suitable_invariant: forall F a,
                                     suitable_2 F a <-> suitable_2 (Negation F) a.
Proof.
  induction F.
  split; intros.
  induction a0.
  inversion H.
  apply s2.
Admitted.

Lemma suitable_invariant_under_assignment_aug: forall F a b,
                                                 suitable_2 F a -> suitable_2 F (b::a).
Proof.
  induction a.
  intros.
  inversion H.
  intros.
  induction F; intros; simpl.
  apply s1.
  apply suitable_atomic_bidirectional in H.
  apply H.
  apply H.
  apply s2.
  apply negation_suitable_invariant.
  apply H.
  apply H.
  inversion H.
  apply s3.
  split; inversion H2.
  generalize H5.
  apply IHF1.
  generalize H6.
  apply IHF2.

Lemma suitable_assignment_contains_all_atoms: forall F a atm,
                                                suitable_2 F a -> In atm (atomicfs F) -> in_assignment atm a.
Proof.
  induction F.
  intros.
  apply suitable_atomic_bidirectional.
  unfold atomicfs in H0.
  inversion H0.
  rewrite H1 in H.
  apply H.
  inversion H1.
  intros.
  simpl in H0.
  induction a.
  inversion H.
  generalize H0.
  apply negation_suitable_invariant in H.
  generalize H.
  apply IHF.
  intros.
  inversion H.
  simpl in H0.
  apply in_app_or in H0.
  inversion H0.
  generalize H6.
  inversion H3.

Lemma suitable_extract : forall a F atm,
                           suitable_2 F a -> (In atm (atomicfs F)) -> in_assignment atm a.
Proof.
  intros.
  induction F.
  apply suitable_atomic_bidirectional in H.
  simpl in H0.
  inversion H0.
  rewrite <- H1.
  apply H.
  inversion H1.
  apply IHF.

Theorem hw1_prob3 : forall a b F,
                      (suitable F a) /\ (suitable F b) /\ agree a b (atomicfs F) -> ((eval_formula F a) = (eval_formula F b)).
Proof.
  intros; induction F.


Theorem ex1: forall p q r : Prop,
             (p -> q) -> (((p -> r) -> q) -> q).
Proof.
  Require Import Classical.
  intros. apply NNPP. intro.
  apply H1. apply H0. intro.
  apply NNPP. intro. apply H1.
  apply (H H2).
Qed.

Theorem ex2: forall p q r s : Prop,
             ((p -> q) -> r) -> ((r -> p) -> (s -> p)).
Proof.
  Require Import Classical.
  intros. apply NNPP. intro. apply H2.
  apply H0. apply H. intro. contradiction.
Qed.

Theorem ex3: forall p q r s : Prop,
             ((p -> r) -> (s -> p)) ->
             (((r -> q) -> p) -> (s -> p)).
Proof.
  Require Import Classical.
  intros. apply NNPP. intro. apply H2.
  apply H0. intro. apply NNPP. intro. apply H2.
  apply H. intro. assumption. assumption.
Qed.

Theorem ex4: forall p q r s : Prop,
             ((r -> q) -> (s -> p)) ->
             ((r -> p) -> (s -> p)).
Proof.
  Require Import Classical.
  intros. apply NNPP. intro. apply H2.
  apply H. intro. apply NNPP. intro.
  apply H2. apply (H0 H3).
  assumption.
Qed.

Theorem ex5: forall p q r s : Prop,
             (((r -> p) -> p) -> (s -> p))
             -> (((p -> q) -> r) -> (s -> p)).
Proof.
  Require Import Classical.
  intros. apply NNPP. intro. apply H2.
  apply H. intro. apply H3. apply H0.
  intro. contradiction. assumption.
Qed.

Theorem ex6: forall p q r : Prop,
             (((p -> r) -> q) -> q) ->
             ((q -> r) -> (p -> r)).
Proof.
  Require Import Classical.
  intros. apply NNPP. intro. apply H2.
  apply H0. apply H. intro.
  pose proof (H3 H1) as H4. contradiction.
Qed.

Theorem ex7: forall p s : Prop,
             ((p -> s) -> p) -> ((s -> p) -> p) -> p.
Proof.
  Require Import Classical.
  intros. apply NNPP. intro. apply H1. apply H0.
  intro. apply H. intro. (*contradiction.*)
  assumption.
Qed.

Theorem ex8: forall a b c : Prop,
             ((a -> b) -> c) -> ((a -> c) -> c).
Proof.
  Require Import Classical.
  intros. apply NNPP. intro. apply H1.
  apply H. intro. apply NNPP. intro. apply H1.
  apply (H0 H2).
Qed.


Require Export Relation.

Theorem composition_assoc {f g h : Rel} :
    h ○ (g ○ f) = (h ○ g) ○ f.
Proof.
  apply Extensionality => ad.
  repeat rewrite composition.
  split => [H | H].
  + induction H as [a]; induction H as [c]; induction H as [d].
    induction H as [adad]; induction H as [ac_gf cd_h].
    apply composition in ac_gf.
    induction ac_gf as [x]; induction H as [b]; induction H as [z].
    induction H as [ac_xz]; induction H as [ab_f bc_g].
    apply eq_OrderPair in ac_xz; induction ac_xz; subst x z.
    exists a; exists b; exists d.
    apply (conj adad).
    apply (conj ab_f).
    apply composition.
    exists b; exists c; exists d.
    split.
    - done.
    - apply (conj bc_g cd_h).
  + induction H as [a]; induction H as [b]; induction H as [d].
    induction H as [ad_ad]; induction H as [ab_f bd_hg].
    apply composition in bd_hg.
    induction bd_hg as [b_]; induction H as [c]; induction H as [d_].
    induction H as [bd_bd]; induction H as [bc_g cd_h].
    apply eq_OrderPair in bd_bd; induction bd_bd; subst b_ d_.
    exists a; exists c; exists d.
    apply (conj ad_ad).
    split.
    - rewrite composition.
      exists a; exists b; exists c.
      done.
    - done.
Qed.

Theorem composition_dom {f g A B C : set} :
      f | A → B -> g | B → C -> Dom (g ○ f) = Dom f.
Proof.
  intros fAB gBC.
  induction fAB as [funcf fAB].
  induction fAB as [domf_A ranf_B].
  induction gBC as [funcg gBC].
  induction gBC as [domg_B rang_C].
  apply Extensionality => a.
  split => [H | H].
  + apply dom in H.
    induction H as [c].
    apply composition in H.
    induction H as [a_]; induction H as [b]; induction H as [c_].
    induction H as [acac]; induction H as [ab_f bc_g].
    apply eq_OrderPair in acac; induction acac; subst a_ c_.
    apply dom.
    by exists b.
  + apply dom in H as H0.
    induction H0 as [b ab_f] .
    specialize (ranf_B b).
    move: ranf_B; rewrite ran => ranf_B.
    assert (exists a, (<|a,b|>) ∈ f).
    by exists a.
    specialize (ranf_B H0) as bB  .
    clear H0 ranf_B.
    rewrite <- domg_B in bB.
    apply dom in bB.
    induction bB as [c bc_g].
    apply dom.
    exists c.
    rewrite composition.
    by exists a; exists b; exists c.
Qed.

Theorem composition_ran {f g A B C : set} :
      f | A → B -> g | B → C -> Ran (g ○ f) ⊂ (Ran g).
Proof.
  intros fAB gBC c H.
  induction fAB as [domf_A ranf_B].
  induction gBC as [domg_B rang_C].
  apply ran in H.
  induction H as [a H].
  apply composition in H.
  induction H as [a_]; induction H as [b]; induction H as [c_].
  induction H as [acac]; induction H as [ab_f bc_g].
  apply eq_OrderPair in acac; induction acac; subst a_ c_.
  apply ran.
  by exists b.
Qed.

Theorem composition_func {f g : set} :
  func f -> func g -> func (g ○ f).
Proof.
  intros funcf funcg.
  intros x H.
  apply dom in H.
  induction H as [z H].
  assert (xz_gf : (<|x,z|> ∈ (g ○ f))) by done.
  apply composition in H.
  induction H as [x_]; induction H as [y]; induction H as [z_].
  induction H as [xyxy]; induction H as [xy_f yz_g].
  apply eq_OrderPair in xyxy; induction xyxy; subst x_ z_.
  exists z.
  apply (conj xz_gf).
  intros z_ H.

  assert (x_domf : x ∈ (Dom f)).
  apply dom.
  by exists y.
  specialize (funcf x x_domf).
  induction funcf as [y0 Hf].
  induction Hf as [xy0f Hf].

  assert (y_domg : y ∈ (Dom g)).
  apply dom.
  by exists z.
  specialize (funcg y y_domg).
  induction funcg as [z0 Hg].
  induction Hg as [yz0g Hg].

  apply composition in H.
  induction H as [x1]; induction H as [y1]; induction H as [z1].
  induction H as [xzxz]; induction H as [xyf yzg].
  apply eq_OrderPair in xzxz; induction xzxz; subst x1 z1.
  apply (Hg z) in yz_g.
  apply (Hf y1) in xyf.
  apply (Hf y) in xy_f.
  subst y0 y1 z0.
  by apply (Hg z_) in yzg.
Qed.

Theorem composition_map {f g A B C : set} :
     f | A → B -> g | B → C -> g ○ f | A → C.
Proof.
  intros fAB gBC.
  inversion fAB as [funcf fAB_].
  induction  fAB_ as [domf_A ranf_B].
  inversion gBC as [funcg gBC_].
  induction gBC_ as [domf_B ranf_C].
  apply (conj (composition_func funcf funcg)).
  split.
  + rewrite <- domf_A.
    apply (composition_dom fAB gBC).
  + intros c H.
    apply ran in H.
    induction H as [a H]     .
    apply composition in H.
    induction H as [a_]; induction H as [b]; induction H as [c_].
    induction H as [acac]; induction H as [ab_f bc_g].
    apply eq_OrderPair in acac; induction acac; subst a_ c_.
    specialize (ranf_C c).
    move:ranf_C ; rewrite ran => H.
    by apply (H (ex_intro (fun b => (<| b, c |>) ∈ g) b bc_g)).
Qed.

Theorem dom_reverse {f : set} :
    Dom (Reverse f) = Ran f.
Proof.
  apply Extensionality => x.
  rewrite dom; rewrite ran.
  split => [H | H].
  + induction H as [y xy_f'] .
    apply (reverse f) in xy_f'.
    by exists y.
  + induction H as [y yx_f].
    exists y.
    by apply (reverse f).
Qed.

Theorem ran_reverse {f : set} :
    Ran (Reverse f) = Dom f.
Proof.
  apply Extensionality => x.
  rewrite dom; rewrite ran.
  split => [H | H].
  + induction H as [y yx_f'] .
    apply (reverse f) in yx_f'.
    by exists y.
  + induction H as [y xy_f] .
    exists y.
    by apply (reverse f).
Qed.

Theorem reverse_bijection (f A B : set) :
  Bijection f A B <-> f | A → B /\ Reverse f | B → A.
Proof.
  split => [H | H].
  + induction H as [fAB H].
    induction H as [ranf_B inj].
    induction fAB as [funcf fAB].
    induction fAB as [domf_A ranfB].
    split.
    - apply (conj funcf) .
      apply (conj domf_A ranfB).
    - split.
      * intros b b_ranf.
        rewrite dom_reverse in b_ranf.
        apply ran in b_ranf.
        induction b_ranf as [a abf] .
        exists a.
        split.
        by apply reverse.
        intros a_ ab_f.
        apply (reverse f) in ab_f.
        apply inj.
        apply (eq_value funcf) in abf.
        apply (eq_value funcf) in ab_f.
        by subst b.
      * rewrite dom_reverse.
        rewrite ran_reverse.
        apply (conj ranf_B)         .
        by rewrite domf_A.
  + induction H as [fAB f'BA] .
    induction fAB as [funcf fAB].
    induction fAB as [domf_A ranfB].
    induction f'BA as [funcf' H].
    induction H as [ranf_B domfA].
    rewrite dom_reverse in ranf_B.
    rewrite ran_reverse in domfA.
    split.
    - apply (conj funcf) .
      apply (conj domf_A ranfB).
    - apply (conj ranf_B) .
      intros a a_ H.
      specialize (funcf' (Value f a)).
      assert (H1 : (Value f a) ∈ (Dom (Reverse f))).
      rewrite dom_reverse.
      apply ran.
      exists a.
      apply (value f a funcf).
      apply funcf' in H1.
      induction H1 as [a0 H1].
      induction H1 as [_ H1].
      specialize (value f a funcf) as abf.
      specialize (value f a_ funcf) as a_bf.
      rewrite <- H in a_bf.
      rewrite <- reverse in abf.
      rewrite <- reverse in a_bf.
      apply (H1 a) in abf.
      apply (H1 a_) in a_bf.
      by subst a0.
Qed.

Theorem reverse_ {R : set} :
  forall u, u ∈ (Reverse R) <-> exists x y, u = <|y,x|> /\ <|x,y|> ∈ R.
Proof.
  intros u.
  split => [H | H].
  + apply class in H.
    apply H.
  + inversion H as [x H0]; induction H0 as [y].
    induction H0 as [y_yx xy_R].
    apply class.
    split.
    - apply product.
      exists y; exists x.
      split.
      apply ran.
      by exists x.
      split.
      apply dom.
      by exists y.
      done.
    - by exists x; exists y.
Qed.

Theorem reverse_composition {f g : set} :
  Reverse (g ○ f) = (Reverse f) ○ (Reverse g).
Proof.
  apply Extensionality => u.
  rewrite composition.
  rewrite reverse_.
  split => [H | H].
  + induction H as [x]; induction H as [z] .
    induction H as [u_yx xy_gf].
    apply composition in xy_gf.
    induction xy_gf as [x_]; induction H as [y]; induction H as [z_].
    induction H as [xzxz]; induction  H as [xy_f yz_g].
    apply eq_OrderPair in xzxz; induction xzxz; subst x_ z_.
    exists z; exists y; exists x.
    by repeat rewrite reverse.
  + induction H as [x]; induction H as [y]; induction H as [z].
    move: H.  repeat rewrite reverse.  intro H.
    induction H as [u_xz]; induction H as [yx_g zy_f].
    exists z; exists x.
    apply (conj u_xz).
    apply composition.
    by exists z; exists y; exists x.
Qed.

Theorem domran {f x y} :
    <|x,y|> ∈ f -> x ∈ (Dom f) /\ y ∈ (Ran f).
Proof.
  intro H.
  split.
  by apply dom; exists y.
  by apply ran; exists x.
Qed.

Theorem value_composition  {f g A B C : set} :
  f | A → B -> g | B → C -> forall x, Value g (Value f x)  = Value (g ○ f)x.
Proof.
  intros fAB gBC x.

  induction fAB as [funcf  Hf].
  induction Hf as [domf_A ranf_B].
  specialize (value f x funcf) as xfx_f.
  specialize (domran xfx_f) as dom_ran.
  induction dom_ran as [x_domf fx_ranf].
  specialize (funcf x x_domf) as Hf.
  induction Hf as [y0 Hf].
  induction Hf as [xy0_f Hf].
  specialize (Hf (Value f x) xfx_f) as Hf'.
  subst y0.
  specialize (ranf_B (Value f x) fx_ranf).

  induction gBC as [funcg  Hg].
  induction Hg as [domf_B ranf_C].
  rewrite <- domf_B in ranf_B.
  specialize (funcg (Value f x) ranf_B) as Hz.
  induction Hz as [z0 Hz].
  induction Hz as [fxy_g Hz].
  specialize (value g (Value f x) funcg) as fxgfx_g.
  specialize (Hz (Value g (Value f x)) fxgfx_g) as Hz'.
  subst z0.

  specialize (value (g ○ f) x (composition_func funcf funcg)) as H.
  apply composition in H.
  induction H as [x0]; induction H as [y]; induction H as [z].
  induction H as [xzxz H]; induction H as [xy_f yz_g].
  apply eq_OrderPair in xzxz; induction xzxz; subst x0 z.
  apply (Hf y) in xy_f.
  subst y.
  by apply Hz.
Qed.

Theorem composition_injection {f g A B C} :
    Injection f A B -> Injection g B C -> Injection (g ○ f) A C.
Proof.
  intros injfAB injgBC.
  induction injfAB as [fAB injf].
  induction injgBC as [gBC injg].
  specialize (value_composition fAB gBC) as H0.
  split.
  + apply (composition_map fAB gBC).
  + intros x x' H.
    apply injf.
    apply injg.
    rewrite (H0 x).
    rewrite (H0 x').
    done.
Qed.

Theorem composition_surjection {f g A B C} :
    Surjection f A B -> Surjection g B C -> Surjection (g ○ f) A C.
Proof.
  intros Hf Hg.
  induction Hf as [fAB ranf_B].
  induction Hg as [gBC rang_C].
  split.
  + apply (composition_map fAB gBC).
  + apply Extensionality => c.
    rewrite ran.
    split => [H | H].
    - induction H as [a H].
      apply composition in H.
      induction H as [a0]; induction H as [b]; induction H as [c0].
      induction H as [acac]; induction H as [ab_f bc_g].
      apply eq_OrderPair in acac; induction acac; subst a0 c0.
      apply domran in bc_g.
      induction bc_g.
      by subst C.
    - rewrite <- rang_C in H.
      apply ran in H.
      induction H as [b bc_g].
      apply domran in bc_g as dom_ran.
      induction dom_ran as [b_domg _].
      induction gBC as [_ Hg].
      induction Hg as [domg_B _].
      subst B.
      rewrite domg_B in b_domg.
      apply ran in b_domg.
      induction b_domg as [a ab_f].
      exists a.
      apply composition.
      by exists a; exists b; exists c.
Qed.

Theorem image_subset {f A B P1 P2 : set}
  {P1_A : P1 ⊂ A} {P2_A : P2 ⊂ A} {fAB : f | A → B}:
  P1 ⊂ P2 -> Image f P1 ⊂ (Image f P2).
Proof.
  intros H b a_fP1.
  apply image in a_fP1.
  induction a_fP1 as [a H1].
  induction H1 as [a_P1 ab_f].
  specialize (H a a_P1).
  rewrite image.
  by exists a.
Qed.

Theorem image_cup
  {f A B P1 P2 : set} {fAB : f | A → B}
  {P1_A : P1 ⊂ A} {P2_A : P2 ⊂ A} {P1P2 : P1 ⊂ P2} :
  Image f (P1 ∪ P2) = (Image f P1) ∪ (Image f P2).
Proof.
  apply Extensionality => b.
  rewrite cup.
  repeat rewrite image.
  split => [H | H].
  + induction H as [a].
    induction H as [a_P1P2 ab_f].
    apply cup in a_P1P2.
    induction a_P1P2 as [a_P1 | a_P2].
    - by apply or_introl; exists a.
    - by apply or_intror; exists a.
  + induction H as [H | H].
    - induction H as [a]; induction H as [aP abf].
      exists a.
      rewrite cup.
      apply (conj (or_introl aP) abf).
    - induction H as [a]; induction H as [aP abf].
      exists a.
      rewrite cup.
      apply (conj (or_intror aP) abf).
Qed.

Theorem image_cap
  {f A B P1 P2 : set} {fAB : f | A → B}
  {P1_A : P1 ⊂ A} {P2_A : P2 ⊂ A} {P1P2 : P1 ⊂ P2} :
  Image f (P1 ∩ P2) ⊂ ((Image f P1) ∩ (Image f P2)).
Proof.
  intros b.
  rewrite cap.
  repeat rewrite image.
  intro H.
  induction H as [a]; induction H as [aP1P2 abf].
  apply cap in aP1P2; induction aP1P2 as [aP1 aP2].
  split.
  + by exists a.
  + by exists a.
Qed.

Theorem image_diff
  {f A B P : set} {fAB : f | A → B} {P_A : P ⊂ A} :
  ((Image f A) // (Image f P)) ⊂ (Image f (A // P)).
Proof.
  intro b.
  rewrite diff.
  repeat rewrite image.
  intro H.
  induction H as [L R].
  induction L as [a]; induction H as [aA abf].
  move : R; rewrite <- allnot_notexists; intro H.
  specialize (H a).
  apply DeMorgan_notand in H.
  induction H as [not_aP | not_abf].
  - exists a.
    split.
    * by apply diff.
    * done.
  - case (not_abf abf).
Qed.

Theorem eqclass_refl {R : Rel} {A : set}  (H : equivalence R A) :
    forall a, a ∈ A -> a ∈ (eqClass H a).
Proof.
  intros a aA.
  apply eqclass.
  induction H as [H _].
  by specialize (H a aA).
Qed.

Theorem eqclass_eq {R A : set} (H : equivalence R A) :
  forall a b, a ∈ A -> b ∈ A -> <|a,b|> ∈ R <-> eqClass H a = eqClass H b.
Proof.
  intros a b aA bA.
  inversion H as [refl_ H0].
  induction H0 as [sym_ trans_].
  split => [H0 | H0].
  + apply Extensionality => i.
    repeat rewrite eqclass.
    split => [H1 | H1].
    - induction H1 as [iA ai_R].
      apply (conj iA).
      apply (sym_ a b aA bA) in H0.
      apply (trans_ b a i bA aA iA H0 ai_R).
    - induction H1 as [iA ai_R].
      apply (conj iA).
      apply (trans_ a b i aA bA iA H0 ai_R).
  + specialize (eqclass_refl H a aA) as H1.
    rewrite H0 in H1.
    apply eqclass in H1.
    induction H1 as [_ H1].
    by apply (sym_ b a bA aA ) in H1.
Qed.

Theorem eqclass_contra {R A : set} {H : equivalence R A} :
    forall a b, a ∈ A -> b ∈ A ->
    eqClass H a <> eqClass H b -> (eqClass H a ∩ (eqClass H b)) = ∅.
Proof.
  intros a b aA bA H0.
  apply Extensionality => i.
  rewrite cap.
  repeat rewrite eqclass.
  split => [H1 | H1].
  + induction H1 as [l r] .
    induction l as [iA ai_R].
    induction r as [_ bi_R].
    inversion H as [refl_ H2].
    induction H2 as [sym_ trans_].
    apply (sym_ b i bA iA) in bi_R.
    specialize (trans_ a i b aA iA bA ai_R bi_R).
    apply (eqclass_eq H a b aA bA ) in trans_.
    case (H0 trans_).
  + specialize (empty i) as H2.
    case (H2 H1).
Qed.


Require Export GeoCoq.Elements.OriginalProofs.lemma_betweennotequal.
Require Export GeoCoq.Elements.OriginalProofs.lemma_inequalitysymmetric.

Section Euclid.

Context `{Ax:euclidean_neutral_ruler_compass}.

Lemma lemma_ondiameter :
   forall D F K M N P Q,
   CI K F P Q -> Cong F D P Q -> Cong F M P Q -> BetS D F M -> BetS D N M ->
   InCirc N K.
Proof.
intros.
assert (neq D F) by (forward_using lemma_betweennotequal).
assert (neq F D) by (conclude lemma_inequalitysymmetric).
assert (~ ~ (BetS D N F \/ BetS F N M \/ eq F N)).
 {
 intro.
 assert (~ BetS D F N).
  {
  intro.
  assert (BetS F N M) by (conclude lemma_3_6a).
  contradict.
  }
 assert (eq F N) by (conclude axiom_connectivity).
 contradict.
 }
assert (Cong F N F N) by (conclude cn_congruencereflexive).
assert (InCirc N K).
by cases on (BetS D N F \/ BetS F N M \/ eq F N).
{
 assert (BetS F N D) by (conclude axiom_betweennesssymmetry).
 assert (InCirc N K) by (conclude_def InCirc ).
 close.
 }
{
 assert (InCirc N K) by (conclude_def InCirc ).
 close.
 }
{
 assert (eq N F) by (conclude lemma_equalitysymmetric).
 assert (InCirc N K) by (conclude_def InCirc ).
 close.
 }
(* cases *)
close.
Unshelve.
exact M.
exact M.
Qed.

End Euclid.


From mathcomp Require Import all_ssreflect all_fingroup all_algebra all_solvable.

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

Open Scope ring_scope.
Import GRing.Theory.

Lemma mulmxP (K : fieldType) (m n : nat) (A B : 'M[K]_(m, n)) :
  reflect (forall u : 'rV__, u *m A = u *m B) (A == B).
Proof.
apply: (iffP eqP) => [-> //|eqAB].
apply: (@row_full_inj _ _ _ _ 1%:M); first by rewrite row_full_unit unitmx1.
by apply/row_matrixP => i; rewrite !row_mul eqAB.
Qed.

Section lfunP.
Variable (F : fieldType).
Context {uT vT : vectType F}.
Local Notation m := (\dim {:uT}).
Local Notation n := (\dim {:vT}).

Lemma span_lfunP (U : seq uT) (phi psi : 'Hom(uT,vT)) :
  {in <<U>>%VS, phi =1 psi} <-> {in U, phi =1 psi}.
Proof.
split=> eq_phi_psi u uU; first by rewrite eq_phi_psi ?memv_span.
rewrite [u](@coord_span _ _ _ (in_tuple U))// !linear_sum/=.
by apply: eq_bigr=> i _; rewrite !linearZ/= eq_phi_psi// ?mem_nth.
Qed.

Lemma fullv_lfunP (U : seq uT) (phi psi : 'Hom(uT,vT)) : <<U>>%VS = fullv ->
  phi = psi <-> {in U, phi =1 psi}.
Proof.
by move=> Uf; split=> [->//|/span_lfunP]; rewrite Uf=> /(_ _ (memvf _))-/lfunP.
Qed.
End lfunP.

Module passmx.
Section passmx.
Variable (F : fieldType).

Section vecmx.
Context {vT : vectType F}.
Local Notation n := (\dim {:vT}).

Variables (e : n.-tuple vT).

Definition rowmxof (v : vT) := \row_i coord e i v.
Lemma rowmxof_linear : linear rowmxof.
Proof. by move=> x v1 v2; apply/rowP=> i; rewrite !mxE linearP. Qed.
Canonical rowmxof_is_linear := Linear rowmxof_linear.

Lemma coord_rowof i v : coord e i v = rowmxof v 0 i.
Proof. by rewrite !mxE. Qed.

Definition vecof (v : 'rV_n) := \sum_i v 0 i *: e`_i.

Lemma vecof_delta i : vecof (delta_mx 0 i) = e`_i.
Proof.
rewrite /vecof (bigD1 i)//= mxE !eqxx scale1r big1 ?addr0// => j neq_ji.
by rewrite mxE (negPf neq_ji) andbF scale0r.
Qed.

Lemma vecof_linear : linear vecof.
Proof.
move=> x v1 v2; rewrite linear_sum -big_split/=.
by apply: eq_bigr => i _/=; rewrite !mxE scalerDl scalerA.
Qed.
Canonical vecof_is_linear := Linear vecof_linear.

Variable e_basis : basis_of {:vT} e.

Lemma rowmxofK : cancel rowmxof vecof.
Proof.
move=> v; rewrite [v in RHS](coord_basis e_basis) ?memvf//.
by apply: eq_bigr => i; rewrite !mxE.
Qed.

Lemma vecofK : cancel vecof rowmxof.
Proof.
move=> v; apply/rowP=> i; rewrite !(lfunE, mxE).
by rewrite coord_sum_free ?(basis_free e_basis).
Qed.

Lemma rowmxofE (i : 'I_n) : rowmxof e`_i = delta_mx 0 i.
Proof.
apply/rowP=> k; rewrite !mxE.
by rewrite eqxx coord_free ?(basis_free e_basis)// eq_sym.
Qed.

Lemma coord_vecof i v : coord e i (vecof v) = v 0 i.
Proof. by rewrite coord_rowof vecofK. Qed.

Lemma rowmxof_eq0 v : (rowmxof v == 0) = (v == 0).
Proof. by rewrite -(inj_eq (can_inj vecofK)) rowmxofK linear0. Qed.

Lemma vecof_eq0 v : (vecof v == 0) = (v == 0).
Proof. by rewrite -(inj_eq (can_inj rowmxofK)) vecofK linear0. Qed.

End vecmx.

Section hommx.
Context {uT vT : vectType F}.
Local Notation m := (\dim {:uT}).
Local Notation n := (\dim {:vT}).

Variables (e : m.-tuple uT) (f : n.-tuple vT).

Definition mxof (h : 'Hom(uT, vT)) := lin1_mx (rowmxof f \o h \o vecof e).

Lemma mxof_linear : linear mxof.
Proof.
move=> x h1 h2; apply/matrixP=> i j; do !rewrite ?lfunE/= ?mxE.
by rewrite linearP.
Qed.
Canonical mxof_is_linear := Linear mxof_linear.

Definition funmx (M : 'M[F]_(m, n)) u := vecof f (rowmxof e u *m M).

Lemma funmx_is_linear M : linear (funmx M).
Proof.
by rewrite /funmx => x u v; rewrite linearP mulmxDl -scalemxAl linearP.
Qed.
Canonical funmx_linear M := Linear (funmx_is_linear M).

Definition hommx M : 'Hom(uT, vT) := linfun (funmx M).

Lemma hommx_linear : linear hommx.
Proof.
rewrite /hommx; move=> x A B; apply/lfunP=> u; do !rewrite lfunE/=.
by rewrite /funmx mulmxDr -scalemxAr linearP.
Qed.
Canonical hommx_is_linear := Linear hommx_linear.

Hypothesis e_basis: basis_of {:uT} e.
Hypothesis f_basis: basis_of {:vT} f.

Lemma mxofK : cancel mxof hommx.
Proof.
by move=> h; apply/lfunP=> u; rewrite lfunE/= /funmx mul_rV_lin1/= !rowmxofK.
Qed.

Lemma hommxK : cancel hommx mxof.
Proof.
move=> M; apply/matrixP => i j; rewrite !mxE/= lfunE/=.
by rewrite /funmx vecofK// -rowE coord_vecof// mxE.
Qed.

Lemma mul_mxof phi u : u *m mxof phi = rowmxof f (phi (vecof e u)).
Proof. by rewrite mul_rV_lin1/=. Qed.

Lemma hommxE M u : hommx M u = vecof f (rowmxof e u *m M).
Proof. by rewrite -[M in RHS]hommxK mul_mxof !rowmxofK//. Qed.

Lemma rowmxof_mul M u : rowmxof e u *m M = rowmxof f (hommx M u).
Proof. by rewrite hommxE vecofK. Qed.

Lemma hom_vecof (phi : 'Hom(uT, vT)) u :
   phi (vecof e u) = vecof f (u *m mxof phi).
Proof. by rewrite mul_mxof rowmxofK. Qed.

Lemma rowmxof_app (phi : 'Hom(uT, vT)) u :
  rowmxof f (phi u) = rowmxof e u *m mxof phi.
Proof. by rewrite mul_mxof !rowmxofK. Qed.

Lemma vecof_mul M u : vecof f (u *m M) = hommx M (vecof e u).
Proof. by rewrite hommxE vecofK. Qed.

Lemma mxof_eq0 phi : (mxof phi == 0) = (phi == 0).
Proof. by rewrite -(inj_eq (can_inj hommxK)) mxofK linear0. Qed.

Lemma hommx_eq0 M : (hommx M == 0) = (M == 0).
Proof. by rewrite -(inj_eq (can_inj mxofK)) hommxK linear0. Qed.

End hommx.

Section hommx_comp.

Context {uT vT wT : vectType F}.
Local Notation m := (\dim {:uT}).
Local Notation n := (\dim {:vT}).
Local Notation p := (\dim {:wT}).

Variables (e : m.-tuple uT) (f : n.-tuple vT) (g : p.-tuple wT).
Hypothesis e_basis: basis_of {:uT} e.
Hypothesis f_basis: basis_of {:vT} f.
Hypothesis g_basis: basis_of {:wT} g.

Lemma mxof_comp (phi : 'Hom(uT, vT)) (psi : 'Hom(vT, wT)) :
  mxof e g (psi \o phi)%VF = mxof e f phi *m mxof f g psi.
Proof.
apply/matrixP => i k; rewrite !(mxE, comp_lfunE, lfunE) /=.
rewrite [phi _](coord_basis f_basis) ?memvf// 2!linear_sum/=.
by apply: eq_bigr => j _ /=; rewrite !mxE !linearZ/= !vecof_delta.
Qed.

Lemma hommx_mul (A : 'M_(m,n)) (B : 'M_(n, p)) :
  hommx e g (A *m B) = (hommx f g B \o hommx e f A)%VF.
Proof.
by apply: (can_inj (mxofK e_basis g_basis)); rewrite mxof_comp !hommxK.
Qed.

End hommx_comp.

Section vsms.

Context {vT : vectType F}.
Local Notation n := (\dim {:vT}).

Variables (e : n.-tuple vT).

Definition msof (V : {vspace vT}) : 'M_n := mxof e e (projv V).
(* alternative *)
(* (\sum_(v <- vbasis V) <<rowmxof e v>>)%MS. *)

Definition vsof (M : 'M[F]_n) := limg (hommx e e M).
(* alternative *)
(* <<[seq vecof e (row i M) | i : 'I_n]>>%VS. *)

Lemma mxof1 : free e -> mxof e e \1 = 1%:M.
Proof.
by move=> eF; apply/matrixP=> i j; rewrite !mxE vecof_delta lfunE coord_free.
Qed.

Hypothesis e_basis: basis_of {:vT} e.

Lemma hommx1 : hommx e e 1%:M = \1%VF.
Proof. by rewrite -mxof1 ?(basis_free e_basis)// mxofK. Qed.

Lemma msofK : cancel msof vsof.
Proof. by rewrite /msof /vsof; move=> V; rewrite mxofK// limg_proj. Qed.

Lemma mem_vecof u (V : {vspace vT}) : (vecof e u \in V) = (u <= msof V)%MS.
Proof.
apply/idP/submxP=> [|[v ->{u}]]; last by rewrite -hom_vecof// memv_proj.
rewrite -[V in X in X -> _]msofK => /memv_imgP[v _].
by move=> /(canRL (vecofK _)) ->//; rewrite -rowmxof_mul//; eexists.
Qed.

Lemma rowmxof_sub u M : (rowmxof e u <= M)%MS = (u \in vsof M).
Proof.
apply/submxP/memv_imgP => [[v /(canRL (rowmxofK _)) ->//]|[v _ ->]]{u}.
  by exists (vecof e v); rewrite ?memvf// -vecof_mul.
by exists (rowmxof e v); rewrite -rowmxof_mul.
Qed.

Lemma vsof_sub M V : (vsof M <= V)%VS = (M <= msof V)%MS.
Proof.
apply/subvP/rV_subP => [MsubV _/submxP[u ->]|VsubM _/memv_imgP[u _ ->]].
  by rewrite -mem_vecof MsubV// -rowmxof_sub vecofK// submxMl.
by rewrite -[V]msofK -rowmxof_sub VsubM// -rowmxof_mul// submxMl.
Qed.

Lemma msof_sub V M : (msof V <= M)%MS = (V <= vsof M)%VS.
Proof.
apply/rV_subP/subvP => [VsubM v vV|MsubV _/submxP[u ->]].
  by rewrite -rowmxof_sub VsubM// -mem_vecof rowmxofK.
by rewrite mul_mxof rowmxof_sub MsubV// memv_proj.
Qed.

Lemma vsofK M : (msof (vsof M) == M)%MS.
Proof. by rewrite msof_sub -vsof_sub subvv. Qed.

Lemma sub_msof : {mono msof : V V' / (V <= V')%VS >-> (V <= V')%MS}.
Proof. by move=> V V'; rewrite msof_sub msofK. Qed.

Lemma sub_vsof : {mono vsof : M M' / (M <= M')%MS >-> (M <= M')%VS}.
Proof. by move=> M M'; rewrite vsof_sub (eqmxP (vsofK _)). Qed.

Lemma msof0 : msof 0 = 0.
Proof.
apply/eqP; rewrite -submx0; apply/rV_subP => v.
by rewrite -mem_vecof memv0 vecof_eq0// => /eqP->; rewrite sub0mx.
Qed.

Lemma vsof0 : vsof 0 = 0%VS.
Proof. by apply/vspaceP=> v; rewrite memv0 -rowmxof_sub submx0 rowmxof_eq0. Qed.

Lemma msof_eq0 V : (msof V == 0) = (V == 0%VS).
Proof. by rewrite -(inj_eq (can_inj msofK)) msof0. Qed.

Lemma vsof_eq0 M : (vsof M == 0%VS) = (M == 0).
Proof.
rewrite (sameP eqP eqmx0P) -!(eqmxP (vsofK M)) (sameP eqmx0P eqP) -msof0.
by rewrite (inj_eq (can_inj msofK)).
Qed.

End vsms.

Section eigen.

Context {uT : vectType F}.

Definition leigenspace (phi : 'End(uT)) a := lker (phi - a *: \1%VF).
Definition leigenvalue phi a := leigenspace phi a != 0%VS.

Local Notation m := (\dim {:uT}).
Variables (e : m.-tuple uT).
Hypothesis e_basis: basis_of {:uT} e.
Let e_free := basis_free e_basis.

Lemma lker_ker phi : lker phi = vsof e (kermx (mxof e e phi)).
Proof.
apply/vspaceP => v; rewrite memv_ker -rowmxof_sub// (sameP sub_kermxP eqP).
by rewrite -rowmxof_app// rowmxof_eq0.
Qed.

Lemma limgE phi : limg phi = vsof e (mxof e e phi).
Proof.
apply/vspaceP => v; rewrite -rowmxof_sub//.
apply/memv_imgP/submxP => [[u _ ->]|[u /(canRL (rowmxofK _)) ->//]].
  by exists (rowmxof e u); rewrite -rowmxof_app.
by exists (vecof e u); rewrite ?memvf// -hom_vecof.
Qed.

Lemma leigenspaceE f a :
   leigenspace f a = vsof e (eigenspace (mxof e e f) a).
Proof.
by rewrite /leigenspace /eigenspace lker_ker linearB linearZ/= mxof1// scalemx1.
Qed.

End eigen.
End passmx.
End passmx.


Require Import ProofCheckingEuclid.euclidean_axioms.
Require Import ProofCheckingEuclid.euclidean_defs.
Require Import ProofCheckingEuclid.euclidean_tactics.
Require Import ProofCheckingEuclid.lemma_betweennotequal.
Require Import ProofCheckingEuclid.lemma_collinear_ABC_ABD_BCD.
Require Import ProofCheckingEuclid.lemma_collinearorder.
Require Import ProofCheckingEuclid.lemma_inequalitysymmetric.
Require Import ProofCheckingEuclid.lemma_s_ncol_n_col.

Section Euclid.

Context `{Ax:euclidean_neutral_ruler_compass}.

Lemma lemma_s_intersecting_triangles_ncol_ADE :
	forall A B D E F,
	Triangle A B D ->
	Triangle B A E ->
	BetS A F D ->
	BetS B F E ->
	nCol A D E.
Proof.
	intros A B D E F.
	intros Triangle_ABD.
	intros Triangle_BAE.
	intros BetS_A_F_D.
	intros BetS_B_F_E.

	assert (nCol_A_B_D := Triangle_ABD).
	unfold Triangle in nCol_A_B_D.

	assert (nCol_B_A_E := Triangle_BAE).
	unfold Triangle in nCol_B_A_E.

	destruct Triangle_ABD as (_ & neq_A_D & _ & _ & _ & _).
	destruct Triangle_BAE as (_ & _ & neq_A_E & _ & _ & _).
	pose proof (lemma_s_ncol_n_col _ _ _ nCol_A_B_D) as n_Col_A_B_D.
	pose proof (lemma_s_ncol_n_col _ _ _ nCol_B_A_E) as n_Col_B_A_E.

	pose proof (lemma_betweennotequal _ _ _ BetS_A_F_D) as (neq_F_D & _ & _).
	pose proof (lemma_betweennotequal _ _ _ BetS_B_F_E) as (neq_F_E & _ & _).
	pose proof (lemma_inequalitysymmetric _ _ neq_A_D) as neq_D_A.

	assert (Col A F D) as Col_A_F_D by (unfold Col; one_of_disjunct BetS_A_F_D).
	assert (Col B F E) as Col_B_F_E by (unfold Col; one_of_disjunct BetS_B_F_E).
	pose proof (lemma_collinearorder _ _ _ Col_A_F_D) as (_ & Col_F_D_A & Col_D_A_F & _ & _).
	pose proof (lemma_collinearorder _ _ _ Col_B_F_E) as (_ & Col_F_E_B & _ & _ & _).

	assert (~ eq D E) as neq_D_E.
	{
		intros eq_D_E.

		assert (Col F D B) as Col_F_D_B by (rewrite eq_D_E; exact Col_F_E_B).
		pose proof (lemma_collinear_ABC_ABD_BCD _ _ _ _ Col_F_D_A Col_F_D_B neq_F_D) as Col_D_A_B.
		pose proof (lemma_collinearorder _ _ _ Col_D_A_B) as (_ & Col_A_B_D & _ & _ & _).

		contradict Col_A_B_D.
		exact n_Col_A_B_D.
	}

	assert (~ BetS A D E) as nBetS_A_D_E.
	{
		intros BetS_A_D_E.

		assert (Col A D E) as Col_A_D_E by (unfold Col; one_of_disjunct BetS_A_D_E).
		pose proof (lemma_collinearorder _ _ _ Col_A_D_E) as (Col_D_A_E & _ & _ & _ & _).

		pose proof (lemma_collinear_ABC_ABD_BCD _ _ _ _ Col_D_A_E Col_D_A_F neq_D_A) as Col_A_E_F.
		pose proof (lemma_collinearorder _ _ _ Col_A_E_F) as (_ & _ & _ & _ & Col_F_E_A).
		pose proof (lemma_collinear_ABC_ABD_BCD _ _ _ _ Col_F_E_A Col_F_E_B neq_F_E) as Col_E_A_B.
		pose proof (lemma_collinearorder _ _ _ Col_E_A_B) as (_ & _ & _ & _ & Col_B_A_E).

		contradict Col_B_A_E.
		exact n_Col_B_A_E.
	}

	assert (~ BetS A E D) as nBetS_A_E_D.
	{
		intros BetS_A_E_D.
		assert (Col A E D) as Col_A_E_D by (unfold Col; one_of_disjunct BetS_A_E_D).

		pose proof (lemma_collinearorder _ _ _ Col_A_E_D) as (_ & _ & Col_D_A_E & _ & _).

		pose proof (lemma_collinear_ABC_ABD_BCD _ _ _ _ Col_D_A_E Col_D_A_F neq_D_A) as Col_A_E_F.
		pose proof (lemma_collinearorder _ _ _ Col_A_E_F) as (_ & _ & _ & _ & Col_F_E_A).
		pose proof (lemma_collinear_ABC_ABD_BCD _ _ _ _ Col_F_E_A Col_F_E_B neq_F_E) as Col_E_A_B.
		pose proof (lemma_collinearorder _ _ _ Col_E_A_B) as (_ & _ & _ & _ & Col_B_A_E).

		contradict Col_B_A_E.
		exact n_Col_B_A_E.
	}

	assert (~ BetS D A E) as nBetS_D_A_E.
	{
		intros BetS_D_A_E.

		assert (Col D A E) as Col_D_A_E by (unfold Col; one_of_disjunct BetS_D_A_E).

		pose proof (lemma_collinear_ABC_ABD_BCD _ _ _ _ Col_D_A_E Col_D_A_F neq_D_A) as Col_A_E_F.
		pose proof (lemma_collinearorder _ _ _ Col_A_E_F) as (_ & _ & _ & _ & Col_F_E_A).
		pose proof (lemma_collinear_ABC_ABD_BCD _ _ _ _ Col_F_E_A Col_F_E_B neq_F_E) as Col_E_A_B.
		pose proof (lemma_collinearorder _ _ _ Col_E_A_B) as (_ & _ & _ & _ & Col_B_A_E).

		contradict Col_B_A_E.
		exact n_Col_B_A_E.
	}

	unfold nCol.
	repeat split.
	exact neq_A_D.
	exact neq_A_E.
	exact neq_D_E.
	exact nBetS_A_D_E.
	exact nBetS_A_E_D.
	exact nBetS_D_A_E.
Qed.

End Euclid.