From HB Require Import structures.
From mathcomp Require Import ssreflect ssrfun ssrbool eqtype choice order.
From mathcomp Require Import ssrnat bigop.
Require Import HB_wrappers.

(******************************************************************************)
(* The algebraic structures of semi-rings and dioids, as described in:        *)
(*   Michel Minoux, Michel Gondran.                                           *)
(*   'Graphs, Dioids and Semirings. New Models and Algorithms.'               *)
(*   Springer, 2008                                                           *)
(*                                                                            *)
(* This file defines for each structure (SemiRing, Dioid, etc...) its type,   *)
(* its packers and its canonical properties:                                  *)
(*                                                                            *)
(*   * SemiRing (non commutative semi-rings):                                 *)
(*         SemiRing.type == interface type for semi-ring structure            *)
(* SemiRing_of_WrapChoice.Build T addA addC add0l mulA mul1l mul1r mulDl      *)
(*     mulDr mul0l mul0r == builds a SemiRing structure from the algebraic    *)
(*                          properties of its operations.                     *)
(*                          The carrier type T must have a WrapChoice         *)
(*                          canonical structure (see HB_wrappers.v).          *)
(*                     0 == the zero element (aditive identity)               *)
(*                     1 == the unit element (multiplicative identity)        *)
(*                 x + y == the addition of x and y in a semiRing             *)
(*                 x * y == the multiplication of x and y in a semiRing       *)
(*         addd_closed S <-> collective predicate S is closed under           *)
(*                          finite sums (0 and x + y in S, for x, y in S)     *)
(*         muld_closed S <-> collective predicate S is closed under finite    *)
(*                          multiplication (0 and x * y in S, for x, y in S)  *)
(*     semiring_closed S <-> collective predicate S is closed under finite    *)
(*                          addition and multiplication. This property        *)
(*                          coerces to addd_closed and muld_closed.           *)
(*          AddPred addS == packs addS : addd_closed S into an addPred S      *)
(*                          interface structure associating this property to  *)
(*                          the canonical pred_key S, i.e the k for wich S    *)
(*                          has a Canonical keyed_pred k structure.           *)
(*                          (see file ssrbool.v)                              *)
(*          MulPred mulS == packs mulS : muld_closed S into a mulPred S       *)
(*                          interface structure associating this property to  *)
(*                          the canonical pred_key S                          *)
(*     SemiRingPred mulS == packs mulS : muld_closed S into a semiringPred S  *)
(*                          interface structure associating the               *)
(*                          semiring_closed property to the canonical         *)
(*                          pred_key S (see above), wich must already be an   *)
(*                          AddPred.                                          *)
(* [SemiRing of U by <:] == semiRingType mixin for a subType whose base type  *)
(*                          is a semiRingType and whose predicate's canonical *)
(*                          pred_key is a semiRingPred.                       *)
(*                                                                            *)
(*   * ComSemiRing (multiplication is commutative):                           *)
(*      ComSemiRing.type == interface type for commutative semi ring          *)
(*                          structure                                         *)
(* ComSemiRing_of_SemiRing.Build R mulC                                       *)
(*                       == packs mulC into a comSemiRing; the carrier type R *)
(*                          must have a SemiRing canonical structure.         *)
(* ComSemiRing_of_WrapChoice.Build T addA addC add0l mulA mulC mul1l mulDl    *)
(*                 mul0l == builds a ComSemiRing structure using the          *)
(*                          commutativity to reduce the number of proof       *)
(*                          obligations.                                      *)
(*                          The carrier type T must have a WrapChoice         *)
(*                          canonical structure (see HB_wrappers.v).          *)
(* [ComSemiRing of R by <:] == commutativity mixin axiom for R when it is a   *)
(*                          subType of a commutative semi-ring.               *)
(*                                                                            *)
(*   * Dioid (idempotent semi-rings):                                         *)
(*            Dioid.type == interface type for dioid structure.               *)
(* Dioid_of_SemiRing_and_WrapPOrder.build D addxx le_def                      *)
(*                       == packs addxx into a Dioid; the carrier type R must *)
(*                          have both a SemiRing and a WrapPOrder canonical   *)
(*                          structure.                                        *)
(* Dioid_of_WrapPOrder.Build D addA addC add0l addxx mulA mul1l mul1r mulDl   *)
(*   mulDr mul0l mul0r addxx le_def                                           *)
(*                       == build a Dioid structure from the algebraic        *)
(*                          properties of its operations.                     *)
(*                          The carrier type T must have a WrapPOrder         *)
(*                          canonical structure (see HB_wrappers.v).          *)
(* Dioid_of_WrapChoice.Build D addA addC add0l addxx mulA mul1l mul1r mulDl   *)
(*   mulDr mul0l mul0r addxx == build a Dioid structure from the algebraic    *)
(*                          properties of its operations.                     *)
(*                          The carrier type T must have a WrapChoice         *)
(*                          canonical structure (see HB_wrappers.v).          *)
(*    [Dioid of R by <:] == idempotent mixin axiom for R when it is a         *)
(*                          subType of a dioid.                               *)
(*                                                                            *)
(*   * ComDioid:                                                              *)
(*         ComDioid.yype == interface type for commutative dioid structure    *)
(* ComDioid_of_Dioid.Build D mulC == packs mulC into a ComDioidType; the      *)
(*                          carrier type D must have a Dioid canonical        *)
(*                          structure.                                        *)
(* ComDioid_of_ComSemiRing_and_WrapPOrder.Build D addxx le_def                *)
(*                       == packs addxx into a ComDioid; the carrier type D   *)
(*                          must have both a Dioid and a WrapPOrder canonical *)
(*                          structure.                                        *)
(* ComDioid_of_WrapPOrder.Build D addA addC add0l addxx mulA mulC mul1l mulDl *)
(*          mul0l le_def == builds a ComDioid structure using the             *)
(*                          commutativity to reduce the number of proof       *)
(*                          obligations.                                      *)
(*                          The carrier type T must have a WrapPOrder         *)
(*                          canonical structure (see HB_wrappers.v).          *)
(* ComDioid_of_WrapChoice.Build D addA addC add0l addxx mulA mulC mul1l mulDl *)
(*                 mul0l == builds a ComDioid structure using the             *)
(*                          commutativity to reduce the number of proof       *)
(*                          obligations.                                      *)
(*                          The carrier type T must have a WrapChoice         *)
(*                          canonical structure (see HB_wrappers.v).          *)
(* [ComDioid of D by <:] == commutativity mixin axiom for S when it is a      *)
(*                          subType of a commutative dioid.                   *)
(*                                                                            *)
(* --> After declaring an instance of (Com)Dioid on T using                   *)
(*     (Com)Dioid_of_WrapChoice.Build the new porderType instance must be     *)
(*     made canonical by hand:                                                *)
(*     <<                                                                     *)
(*     Canonical T_porderType := [porderType of T for T_is_a_WrapPOrder].     *)
(*     >>                                                                     *)
(*   Notations are defined in scope dioid_scope (delimiter %D).               *)
(******************************************************************************)

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

Declare Scope dioid_scope.
Delimit Scope dioid_scope with D.
Local Open Scope dioid_scope.

Import Order.Theory.

HB.mixin Record SemiRing_of_WrapChoice R of WrapChoice R := {
  zero : R;
  one : R;
  add : R -> R -> R;
  mul : R -> R -> R;
  adddA : associative add;
  adddC : commutative add;
  add0d : left_id zero add;
  muldA : associative mul;
  mul1d : left_id one mul;
  muld1 : right_id one mul;
  muldDl : left_distributive mul add;
  muldDr : right_distributive mul add;
  mul0d : left_zero zero mul;
  muld0 : right_zero zero mul;
}.

HB.structure Definition SemiRing :=
  { R of WrapChoice R & SemiRing_of_WrapChoice R }.

Coercion SemiRing_to_Equality (T : SemiRing.type) :=
  Eval hnf in [eqType of T for T].
Canonical SemiRing_to_Equality.
Coercion SemiRing_to_Choice (T : SemiRing.type) :=
  Eval hnf in [choiceType of T for T].
Canonical SemiRing_to_Choice.

Section SemiRingTheory.

Variables R : SemiRing.type.

Lemma addd0 : right_id (@zero R) add.
Proof. by move=> x; rewrite adddC add0d. Qed.

Canonical add_monoid := Monoid.Law adddA add0d addd0.
Canonical add_comoid := Monoid.ComLaw adddC.
Canonical mul_monoid := @Monoid.Law R _ _ muldA mul1d muld1.
Canonical muloid := @Monoid.MulLaw R _ _ mul0d muld0.
Canonical addoid := Monoid.AddLaw muldDl muldDr.

Local Notation "0" := zero : dioid_scope.
Local Notation "1" := one : dioid_scope.
Local Notation "+%D" := (@add _) : dioid_scope.
Local Infix "+" := (@add _) : dioid_scope.
Local Infix "*" := (@mul _) : dioid_scope.

Lemma adddAC : right_commutative (S := R) +%D.
Proof. by move=> x y z; rewrite -adddA (adddC y) adddA. Qed.

Lemma adddCA : left_commutative (S := R) +%D.
Proof. by move=> x y z; rewrite adddC -adddA (adddC x). Qed.

Lemma adddACA : interchange (S := R) +%D +%D.
Proof. by move=> a b c d; rewrite adddAC adddA -adddA (adddC d). Qed.

Section ClosedPredicates.

Variable S : predPredType R.

Definition addd_closed := 0 \in S /\ {in S &, forall u v, u + v \in S}.
Definition muld_closed := 1 \in S /\ {in S &, forall u v, u * v \in S}.
Definition semiring_closed := addd_closed /\ muld_closed.

Lemma semiring_closedA : semiring_closed -> addd_closed.
Proof. by case. Qed.
Lemma semiring_closedM : semiring_closed -> muld_closed.
Proof. by case. Qed.

End ClosedPredicates.

End SemiRingTheory.

HB.mixin Record ComSemiRing_of_SemiRing R of SemiRing R := {
  muldC : @commutative R _ mul;
}.

HB.structure Definition ComSemiRing :=
  { R of ComSemiRing_of_SemiRing R & SemiRing R }.

HB.factory Record ComSemiRing_of_WrapChoice R of WrapChoice R := {
  zero : R;
  one : R;
  add : R -> R -> R;
  mul : R -> R -> R;
  adddA : associative add;
  adddC : commutative add;
  add0d : left_id zero add;
  muldA : associative mul;
  muldC : commutative mul;
  mul1d : left_id one mul;
  muldDl : left_distributive mul add;
  mul0d : left_zero zero mul;
}.

HB.builders Context R (f : ComSemiRing_of_WrapChoice R).

  Lemma muld1 : right_id one mul.
  Proof. by move=> x; rewrite muldC mul1d. Qed.

  Lemma muldDr : right_distributive mul add.
  Proof. by move=> x y z; rewrite muldC muldDl !(muldC x). Qed.

  Lemma muld0 : right_zero zero mul.
  Proof. by move=> x; rewrite muldC mul0d. Qed.

  HB.instance Definition to_SemiRing_of_WrapChoice :=
    SemiRing_of_WrapChoice.Build
      R adddA adddC add0d
      muldA mul1d muld1 muldDl muldDr mul0d muld0.

  HB.instance Definition to_ComSemiRing_of_SemiRing :=
    ComSemiRing_of_SemiRing.Build R muldC.

HB.end.

Coercion ComSemiRing_to_Equality (T : ComSemiRing.type) :=
  Eval hnf in [eqType of T for T].
Canonical ComSemiRing_to_Equality.
Coercion ComSemiRing_to_Choice (T : ComSemiRing.type) :=
  Eval hnf in [choiceType of T for T].
Canonical ComSemiRing_to_Choice.

Section ComSemiRingTheory.

Variables R : ComSemiRing.type.

Local Notation "*%D" := (@mul _) : dioid_scope.
Local Infix "*" := (@mul _) : dioid_scope.

Lemma muldAC : right_commutative (S := R) *%D.
Proof. by move=> x y z; rewrite -muldA (muldC y) muldA. Qed.

Lemma muldCA : left_commutative (S := R) *%D.
Proof. by move=> x y z; rewrite muldC -muldA (muldC x). Qed.

Lemma muldACA : interchange (S := R) *%D *%D.
Proof. by move=> a b c d; rewrite muldAC muldA -muldA (muldC d). Qed.

End ComSemiRingTheory.

HB.mixin Record Dioid_of_SemiRing_and_WrapPOrder D
         of SemiRing D & WrapPOrder D := {
  adddd : @idempotent D add;
  le_def : forall (a b : D),
      (Order.POrder.le wrap_porderMixin a b)
      = (Equality.op wrap_eqMixin (add a b) b);
}.

HB.structure Definition Dioid :=
  { D of Dioid_of_SemiRing_and_WrapPOrder D & SemiRing D & WrapPOrder D }.

HB.factory Record Dioid_of_WrapPOrder D of WrapPOrder D := {
  zero : D;
  one : D;
  add : D -> D -> D;
  mul : D -> D -> D;
  adddA : associative add;
  adddC : commutative add;
  add0d : left_id zero add;
  adddd : idempotent add;
  muldA : associative mul;
  mul1d : left_id one mul;
  muld1 : right_id one mul;
  muldDl : left_distributive mul add;
  muldDr : right_distributive mul add;
  mul0d : left_zero zero mul;
  muld0 : right_zero zero mul;
  le_def : forall (a b : D),
      (Order.POrder.le wrap_porderMixin a b)
      = (Equality.op wrap_eqMixin (add a b) b);
}.

HB.builders Context D (f : Dioid_of_WrapPOrder D).

  HB.instance Definition to_SemiRing_of_WrapChoice :=
    SemiRing_of_WrapChoice.Build
      D adddA adddC add0d
      muldA mul1d muld1 muldDl muldDr mul0d muld0.

  HB.instance Definition to_Dioid_of_SemiRing_and_WrapPOrder :=
    Dioid_of_SemiRing_and_WrapPOrder.Build D adddd le_def.

HB.end.

HB.factory Record Dioid_of_WrapChoice D of WrapChoice D := {
  zero : D;
  one : D;
  add : D -> D -> D;
  mul : D -> D -> D;
  adddA : associative add;
  adddC : commutative add;
  add0d : left_id zero add;
  adddd : idempotent add;
  muldA : associative mul;
  mul1d : left_id one mul;
  muld1 : right_id one mul;
  muldDl : left_distributive mul add;
  muldDr : right_distributive mul add;
  mul0d : left_zero zero mul;
  muld0 : right_zero zero mul;
}.

HB.builders Context D (f : Dioid_of_WrapChoice D).

  HB.instance Definition to_SemiRing_of_WrapChoice :=
    SemiRing_of_WrapChoice.Build
      D adddA adddC add0d
      muldA mul1d muld1 muldDl muldDr mul0d muld0.

  Canonical D_is_a_eqType := [eqType of D for D_is_a_WrapChoice].

  Definition le_dioid a b := add a b == b.

  Definition lt_dioid a b := (b != a) && le_dioid a b.

  Lemma lt_def_dioid a b : lt_dioid a b = (b != a) && le_dioid a b.
  Proof. by []. Qed.

  Lemma le_refl_dioid : reflexive le_dioid.
  Proof. by move=> a; rewrite /le_dioid adddd. Qed.

  Lemma le_anti_dioid : antisymmetric le_dioid.
  Proof.
  by move=> a b /andP[]; rewrite /le => /eqP ? /eqP; rewrite adddC => <-.
  Qed.

  Lemma le_trans_dioid : transitive le_dioid.
  Proof.
  move=> a b c; rewrite /le_dioid => /eqP H /eqP <-.
  by rewrite -[in X in _ == X]H adddA.
  Qed.

  Definition dioid_porderMixin :=
    LePOrderMixin lt_def_dioid le_refl_dioid le_anti_dioid le_trans_dioid.

  HB.instance Definition to_WrapPOrder_of_WrapChoice :=
    WrapPOrder_of_WrapChoice.Build D dioid_porderMixin.

  Lemma le_def (a b : D) :
    Order.POrder.le wrap_porderMixin a b =
    Equality.op wrap_eqMixin (SemiRing.Exports.add a b) b.
  Proof. by []. Qed.

  HB.instance Definition to_Dioid_of_SemiRing_and_WrapPOrder :=
    Dioid_of_SemiRing_and_WrapPOrder.Build D adddd le_def.

HB.end.

Coercion Dioid_to_Equality (T : Dioid.type) :=
  Eval hnf in [eqType of T for T].
Canonical Dioid_to_Equality.
Coercion Dioid_to_Choice (T : Dioid.type) :=
  Eval hnf in [choiceType of T for T].
Canonical Dioid_to_Choice.
Coercion Dioid_to_POrder (T : Dioid.type) :=
  Eval hnf in [porderType of T for T].
Canonical Dioid_to_POrder.

Section DioidTheory.

Variables D : Dioid.type.

Implicit Type a b c : D.

Local Notation "0" := zero : dioid_scope.
Local Notation "1" := one : dioid_scope.
Local Notation "+%D" := (@add _) : dioid_scope.
Local Notation "*%D" := (@mul _) : dioid_scope.
Local Infix "+" := (@add _) : dioid_scope.
Local Infix "*" := (@mul _) : dioid_scope.
Local Infix "<=" := (@Order.le _ _) : dioid_scope.
Local Notation "a <= b :> T" := ((a : T) <= (b : T)) (only parsing) : dioid_scope.

Lemma le_def a b : (a <= b) = (a + b == b).
Proof. by rewrite /Order.le le_def. Qed.

Lemma le0d a : 0 <= a :> D.
Proof. by rewrite le_def add0d. Qed.

Lemma led_add2r c : {homo +%D^~ c : a b / a <= b }.
Proof.
move => a b; rewrite !le_def => /eqP H.
by rewrite adddCA -adddA adddd adddA (adddC b) H.
Qed.

Lemma led_add2l c : {homo +%D c : a b / a <= b }.
Proof. move=> a b; rewrite !(adddC c); exact: led_add2r. Qed.

Lemma led_add a b c d : a <= c -> b <= d -> a + b <= c + d.
Proof. move=> Hac Hbd; exact/(le_trans (led_add2r _ Hac)) /led_add2l. Qed.

Lemma led_addl a b : a <= b + a.
Proof. by rewrite le_def adddCA adddd. Qed.

Lemma led_addr a b : a <= a + b.
Proof. by rewrite le_def adddA adddd. Qed.

Lemma led_add_eqv a b c :  (b + c <= a) = ((b <= a) && (c <= a)).
Proof.
apply/idP/idP => [Ha | /andP[]].
- apply/andP; split.
  + exact/(le_trans _ Ha) /led_addr.
  + exact/(le_trans _ Ha) /led_addl.
- rewrite 2!le_def => /eqP <- /eqP <-.
  by rewrite adddCA adddA led_addr.
Qed.

Lemma led_mul2l c : {homo *%D c : a b / a <= b }.
Proof. by move=> a b; rewrite le_def => /eqP <-; rewrite muldDr led_addr. Qed.

Lemma led_mul2r c : {homo *%D^~ c : a b / a <= b }.
Proof. by move=> a b; rewrite le_def => /eqP <-; rewrite muldDl led_addr. Qed.

Lemma led_mul a b c d : a <= c -> b <= d -> a * b <= c * d.
Proof. move=> Hac Hbd; exact/(le_trans (led_mul2r _ Hac)) /led_mul2l. Qed.

End DioidTheory.

HB.structure Definition ComDioid :=
  { D of ComSemiRing_of_SemiRing D & Dioid D }.

HB.factory Record ComDioid_of_WrapPOrder D of WrapPOrder D := {
  zero : D;
  one : D;
  add : D -> D -> D;
  mul : D -> D -> D;
  adddA : associative add;
  adddC : commutative add;
  add0d : left_id zero add;
  adddd : idempotent add;
  muldA : associative mul;
  muldC : commutative mul;
  mul1d : left_id one mul;
  muldDl : left_distributive mul add;
  mul0d : left_zero zero mul;
  le_def : forall (a b : D),
      (Order.POrder.le wrap_porderMixin a b)
      = (Equality.op wrap_eqMixin (add a b) b);
}.

HB.builders Context D (f : ComDioid_of_WrapPOrder D).

  Lemma muld1 : right_id one mul.
  Proof. by move=> x; rewrite muldC mul1d. Qed.

  Lemma muldDr : right_distributive mul add.
  Proof.
  Proof. by move=> x y z; rewrite muldC muldDl !(muldC x). Qed.

  Lemma muld0 : right_zero zero mul.
  Proof. by move=> x; rewrite muldC mul0d. Qed.

  HB.instance Definition to_Dioid_of_WrapPOrder :=
    Dioid_of_WrapPOrder.Build
      D adddA adddC add0d adddd
      muldA mul1d muld1 muldDl muldDr mul0d muld0 le_def.

  HB.instance Definition to_ComDioid_of_Dioid :=
    ComSemiRing_of_SemiRing.Build D muldC.

HB.end.

HB.factory Record ComDioid_of_WrapChoice D of WrapChoice D := {
  zero : D;
  one : D;
  add : D -> D -> D;
  mul : D -> D -> D;
  adddA : associative add;
  adddC : commutative add;
  add0d : left_id zero add;
  adddd : idempotent add;
  muldA : associative mul;
  muldC : commutative mul;
  mul1d : left_id one mul;
  muldDl : left_distributive mul add;
  mul0d : left_zero zero mul;
}.

HB.builders Context D (f : ComDioid_of_WrapChoice D).

  Lemma muld1 : right_id one mul.
  Proof. by move=> x; rewrite muldC mul1d. Qed.

  Lemma muldDr : right_distributive mul add.
  Proof.
  Proof. by move=> x y z; rewrite muldC muldDl !(muldC x). Qed.

  Lemma muld0 : right_zero zero mul.
  Proof. by move=> x; rewrite muldC mul0d. Qed.

  HB.instance Definition to_Dioid_of_WrapChoice :=
    Dioid_of_WrapChoice.Build
      D adddA adddC add0d adddd
      muldA mul1d muld1 muldDl muldDr mul0d muld0.

  HB.instance Definition to_ComDioid_of_Dioid :=
    ComSemiRing_of_SemiRing.Build D muldC.

HB.end.

Coercion ComDioid_to_Equality (T : ComDioid.type) :=
  Eval hnf in [eqType of T for T].
Canonical ComDioid_to_Equality.
Coercion ComDioid_to_Choice (T : ComDioid.type) :=
  Eval hnf in [choiceType of T for T].
Canonical ComDioid_to_Choice.
Coercion ComDioid_to_POrder (T : ComDioid.type) :=
  Eval hnf in [porderType of T for T].
Canonical ComDioid_to_POrder.

(* Interface structures for algebraically closed predicates. *)
Module Pred.

Structure add V S := Add {add_key : pred_key S; _ : @addd_closed V S}.
Structure mul R S := Mul {mul_key : pred_key S; _ : @muld_closed R S}.
Structure semiring R S :=
  SemiRing {semiring_add : add S; _ : @muld_closed R S}.

Section Subtyping.

Fact semiring_mulr R S : @semiring R S -> muld_closed S.
Proof. by case. Qed.

Definition semiring_mul R S (ringS : @semiring R S) :=
  Mul (add_key (semiring_add ringS)) (semiring_mulr ringS).

End Subtyping.

Section Extensionality.
(* This could be avoided by exploiting the Coq 8.4 eta-convertibility.        *)

Lemma add_ext (U : SemiRing.type) S k (kS : @keyed_pred U S k) :
  addd_closed kS -> addd_closed S.
Proof.
by case=> S0 addS; split=> [|x y]; rewrite -!(keyed_predE kS) //; apply: addS.
Qed.

Lemma mul_ext (R : SemiRing.type) S k (kS : @keyed_pred R S k) :
  muld_closed kS -> muld_closed S.
Proof.
by case=> S1 mulS; split=> [|x y]; rewrite -!(keyed_predE kS) //; apply: mulS.
Qed.

End Extensionality.

Module Exports.

Notation addd_closed := addd_closed.
Notation muld_closed := muld_closed.
Notation semiring_closed := semiring_closed.

Coercion semiring_closedA : semiring_closed >-> addd_closed.
Coercion semiring_closedM : semiring_closed >-> muld_closed.
Coercion add_key : add >-> pred_key.
Coercion mul_key : mul >-> pred_key.
Coercion semiring_add : semiring >-> add.
Coercion semiring_mul : semiring >-> mul.
Canonical semiring_mul.

Notation addPred := add.
Notation mulPred := mul.
Notation semiringPred := semiring.

Definition AddPred U S k kS DkS := Add k (@add_ext U S k kS DkS).
Definition MulPred R S k kS MkS := Mul k (@mul_ext R S k kS MkS).
Definition SemiRingPred R S k kS MkS := SemiRing k (@mul_ext R S k kS MkS).

End Exports.

End Pred.
Import Pred.Exports.

Section SemiRingPred.

Variables (V : SemiRing.type) (S : predPredType V).

Section Add.

Variables (addS : addPred S) (kS : keyed_pred addS).

Lemma rpred0D : addd_closed kS.
Proof. split=> [|x y]; rewrite !keyed_predE; case: addS=> _ [_]//; exact. Qed.

Lemma rpred0 : (@zero V) \in kS.
Proof. by case: rpred0D. Qed.

Lemma rpredD : {in kS &, forall u v, (@add V u v) \in kS}.
Proof. by case: rpred0D. Qed.

End Add.

Section Mul.

Variables (mulS : mulPred S) (kS : keyed_pred mulS).

Lemma rpred1M : muld_closed kS.
Proof.
split=> [ | x y]; rewrite !keyed_predE; case: mulS => _ [_] //; exact.
Qed.

Lemma rpred1 : (@one V) \in kS.
Proof. by case: rpred1M. Qed.

Lemma rpredM : {in kS &, forall u v, (@mul V u v) \in kS}.
Proof. by case: rpred1M. Qed.

End Mul.

End SemiRingPred.

Module SubType.

Section SemiRing.

Variables (V : SemiRing.type) (S : predPredType V).
Variables (subS : semiringPred S) (kS : keyed_pred subS).
Variable U : subType (mem kS).

Let inU v Sv : U := Sub v Sv.
Let zeroU := inU (rpred0 kS).
Let oneU := inU (rpred1 kS).
Let addU (u1 u2 : U) := inU (rpredD (valP u1) (valP u2)).
Let mulU (u1 u2 : U) := inU (rpredM (valP u1) (valP u2)).

Fact adddA : associative addU.
Proof. by move=> a b c; apply: val_inj; rewrite !SubK adddA. Qed.

Fact adddC : commutative addU.
Proof. by move=> a b; apply: val_inj; rewrite !SubK adddC. Qed.

Fact add0d : left_id zeroU addU.
Proof. by move=> a; apply: val_inj; rewrite !SubK add0d. Qed.

Fact muldA : associative mulU.
Proof. by move=> a b c; apply: val_inj; rewrite !SubK muldA. Qed.

Fact mul1d : left_id oneU mulU.
Proof. by move=> a; apply: val_inj; rewrite !SubK mul1d. Qed.

Fact muld1 : right_id oneU mulU.
Proof. by move=> a; apply: val_inj; rewrite !SubK muld1. Qed.

Fact muldDl : @left_distributive U U mulU addU.
Proof. by move=> a b c; apply: val_inj; rewrite !SubK muldDl. Qed.

Fact muldDr : right_distributive mulU addU.
Proof. by move=> a b c; apply: val_inj; rewrite !SubK muldDr. Qed.

Lemma mul0d : left_zero zeroU mulU.
Proof. by move=> a; apply: val_inj; rewrite !SubK mul0d. Qed.

Lemma muld0 : right_zero zeroU mulU.
Proof. by move=> a; apply: val_inj; rewrite !SubK muld0. Qed.

Definition semiRingMixin of phant U :=
  SemiRing_of_WrapChoice.Build
    _ adddA adddC add0d muldA mul1d muld1 muldDl muldDr mul0d muld0.

End SemiRing.

Lemma comSemiRingMixin (R : ComSemiRing.type) (T : SemiRing.type) (f : T -> R) :
phant T -> injective f -> {morph f : x y / mul x y} -> commutative (@mul T).
Proof. by move=> _ inj_f fM x y; apply: inj_f; rewrite !fM muldC. Qed.

Lemma dioidMixin (R : Dioid.type) (T : SemiRing.type) (f : T -> R) :
phant T -> injective f -> {morph f : x y / add x y} -> @idempotent T add.
Proof. by move=> _ inj_f fM x; apply: inj_f; rewrite !fM adddd. Qed.

Lemma dioidMixin' (R : Dioid.type) (T : SemiRing.type) (f : T -> R)
  (_ : phant T) (eM : Equality.mixin_of T) (oM : @Order.POrder.mixin_of T eM) :
injective f -> {morph f : x y / add x y} ->
{mono f : x y / Equality.op eM x y >-> x == y} ->
{mono f : x y / Order.POrder.le oM x y >-> (x <= y)%O} ->
forall (a b : T), (Order.POrder.le oM a b) = (Equality.op eM (add a b) b).
Proof. by move=> inj_f fM fM' fM'' x y; rewrite -fM'' le_def -fM fM'. Qed.

Lemma comDioidMixin (R : ComDioid.type) (T : Dioid.type) (f : T -> R) :
phant T -> injective f -> {morph f : x y / mul x y} -> commutative (@mul T).
Proof. by move=> _ inj_f fM x y; apply: inj_f; rewrite !fM muldC. Qed.

Module Exports.

Notation "[ 'SemiRing' 'of' U 'by' <: ]" := (semiRingMixin (Phant U))
  (at level 0, format "[ 'SemiRing' 'of' U 'by' <: ]") : form_scope.

Notation "[ 'ComSemiRing' 'of' R 'by' <: ]" :=
  (ComSemiRing_of_SemiRing.Build
     _ (comSemiRingMixin (Phant R) val_inj (rrefl _)))
  (at level 0, format "[ 'ComSemiRing' 'of' R 'by' <: ]") : form_scope.

Notation "[ 'Dioid' 'of' R 'by' <: ]" :=
  (Dioid_of_SemiRing_and_WrapPOrder.Build
     R%type (dioidMixin (Phant R) val_inj (rrefl _))
     (@dioidMixin' _ _ _ (Phant R) wrap_eqMixin wrap_porderMixin
                  val_inj (rrefl _) (rrefl _) (rrefl _)))
  (at level 0, format "[ 'Dioid' 'of' R 'by' <: ]") : form_scope.

Notation "[ 'ComDioid' 'of' R 'by' <: ]" :=
  (ComSemiRing_of_SemiRing.Build _ (comDioidMixin (Phant R) val_inj (rrefl _)))
  (at level 0, format "[ 'ComDioid' 'of' R 'by' <: ]") : form_scope.

End Exports.

End SubType.

Export Pred.Exports SubType.Exports.

Notation "0" := zero : dioid_scope.
Notation "1" := one : dioid_scope.
Notation "+%D" := (@add _) : dioid_scope.
Notation "*%D" := (@mul _) : dioid_scope.
Infix "+" := (@add _) : dioid_scope.
Infix "*" := (@mul _) : dioid_scope.

Notation led := (@Order.le dioid_display _) (only parsing).
Notation "@ 'led' R" :=
  (@Order.le dioid_display R) (at level 10, R at level 8, only parsing).
Notation ltd := (@Order.lt dioid_display _) (only parsing).
Notation "@ 'ltd' R" :=
  (@Order.lt dioid_display R) (at level 10, R at level 8, only parsing).
Notation ged := (@Order.ge dioid_display _) (only parsing).
Notation "@ 'ged' R" :=
  (@Order.ge dioid_display R) (at level 10, R at level 8, only parsing).
Notation gtd := (@Order.gt dioid_display _) (only parsing).
Notation "@ 'gtd' R" :=
  (@Order.gt dioid_display R) (at level 10, R at level 8, only parsing).

Notation "<=%D" := led : dioid_scope.
Notation ">=%D" := ged : dioid_scope.
Notation "<%D" := ltd : dioid_scope.
Notation ">%D" := gtd : dioid_scope.

Notation "<= b" := (ged b) : dioid_scope.
Notation "<= b :> T" := (<= (b : T)) (only parsing) : dioid_scope.
Notation ">= b" := (led b) : dioid_scope.
Notation ">= b :> T" := (>= (b : T)) (only parsing) : dioid_scope.

Notation "< b" := (gtd b) : dioid_scope.
Notation "< b :> T" := (< (b : T)) (only parsing) : dioid_scope.
Notation "> b" := (ltd b) : dioid_scope.
Notation "> b :> T" := (> (b : T)) (only parsing) : dioid_scope.

Notation "a <= b" := (led a b) : dioid_scope.
Notation "a <= b :> T" := ((a : T) <= (b : T)) (only parsing) : dioid_scope.
Notation "a >= b" := (b <= a) (only parsing) : dioid_scope.
Notation "a >= b :> T" := ((a : T) >= (b : T)) (only parsing) : dioid_scope.

Notation "a < b" := (ltd a b) : dioid_scope.
Notation "a < b :> T" := ((a : T) < (b : T)) (only parsing) : dioid_scope.
Notation "a > b" := (b < a) (only parsing) : dioid_scope.
Notation "a > b :> T" := ((a : T) > (b : T)) (only parsing) : dioid_scope.

Notation "a <= b <= c" := ((led a b) && (led b c)) : dioid_scope.
Notation "a < b <= c"  := ((ltd a b) && (led b c)) : dioid_scope.
Notation "a <= b < c"  := ((led a b) && (ltd b c)) : dioid_scope.
Notation "a < b < c"   := ((ltd a b) && (ltd b c)) : dioid_scope.


From QuickChick Require Import QuickChick.
Inductive natural : Type := Succ : natural -> natural |  Zero : natural.
Derive Show for natural. Derive Arbitrary for natural.  Instance Dec_Eq_natural : Dec_Eq natural. Proof. dec_eq. Qed.
Inductive lst : Type := Cons : natural -> lst -> lst |  Nil : 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 append (append_arg0 : lst) (append_arg1 : lst) : lst
           := match append_arg0, append_arg1 with
              | Nil, x => x
              | Cons x y, z => Cons x (append y z)
              end.

Fixpoint rev (rev_arg0 : lst) : lst
           := match rev_arg0 with
              | Nil => Nil
              | Cons x y => append (rev y) (Cons x Nil)
              end.

Lemma append_assoc: forall l1 l2 l3,
  append l1 (append l2 l3) = append (append l1 l2) l3.
Proof.
induction l1.
  - simpl. intros. rewrite IHl1. reflexivity.
  - reflexivity.
Qed.

Lemma lem3: forall l, append l Nil = l.
Proof.
induction l.
  - simpl. rewrite IHl. reflexivity.
  - reflexivity.
Qed.

Theorem theorem0 : forall (x : lst) (y : lst), eq (rev (append (rev x) y)) (append (rev y) x).
Proof.
induction x.
  - intros. simpl. rewrite <- append_assoc. rewrite IHx. simpl.
    rewrite <- append_assoc. simpl. reflexivity.
  - intros. simpl. rewrite lem3. reflexivity.
Qed.


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

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

Unset Positivity Checking.
Unset Guard Checking.

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

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

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

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

Definition synth (lf1 : natural) (lf3 : natural) (z : natural) (lf2 : natural)
  : natural := mult (Succ Zero) lf1.


Require Export TopologicalSpaces.
Require Export Neighborhoods.
From ZornsLemma Require Export InverseImage.
Require Export OpenBases.
Require Export NeighborhoodBases.
Require Export Subbases.

Section continuity.

Variable X Y:TopologicalSpace.
Variable f:X -> Y.

Definition continuous : Prop :=
  forall V:Ensemble Y, open V ->
  open (inverse_image f V).

Definition continuous_at (x:X) : Prop :=
  forall V:Ensemble Y,
  neighborhood V (f x) -> neighborhood (inverse_image f V) x.

Lemma continuous_at_open_neighborhoods:
  forall x:X,
  (forall V:Ensemble Y,
  open_neighborhood V (f x) -> neighborhood (inverse_image f V) x) ->
  continuous_at x.
Proof.
intros.
red; intros.
destruct H0 as [V' [? ?]].
pose proof (H V' H0).
destruct H2 as [U' [? ?]].
exists U'; split; trivial.
apply (inverse_image_increasing f) in H1; auto with sets.
Qed.

Lemma pointwise_continuity :
  (forall x:point_set X, continuous_at x) -> continuous.
Proof.
intros.
red; intros.
replace (inverse_image f V) with (interior (inverse_image f V)).
{ apply interior_open. }
apply Extensionality_Ensembles; split.
{ apply interior_deflationary. }
red; intros.
destruct H1.
assert (neighborhood V (f x)).
{ exists V; repeat split; auto with sets. }
pose proof (H x V H2).
destruct H3 as [U].
destruct H3.
destruct H3.
assert (Included U (interior (inverse_image f V))).
{ apply interior_maximal; trivial. }
auto.
Qed.

Lemma continuous_func_continuous_everywhere:
  continuous -> forall x:point_set X, continuous_at x.
Proof.
intros.
apply continuous_at_open_neighborhoods.
intros.
apply open_neighborhood_is_neighborhood.
destruct H0; split; try constructor; auto.
Qed.

Lemma continuous_at_neighborhood_basis:
  forall (x:X) (NB:Family Y),
  neighborhood_basis NB (f x) ->
  (forall V:Ensemble Y,
  In NB V -> neighborhood (inverse_image f V) x) ->
  continuous_at x.
Proof.
intros.
red; intros.
destruct H.
apply neighborhood_basis_cond in H1.
destruct H1 as [N [? ?]].
pose proof (H0 N H).
destruct H2 as [U [? ?]].
exists U; split; trivial.
assert (Included (inverse_image f N) (inverse_image f V));
  auto with sets.
Qed.

Lemma continuous_open_basis:
  forall (B:Family Y), open_basis B ->
  (forall V:Ensemble Y,
    In B V -> open (inverse_image f V)) -> continuous.
Proof.
intros.
apply pointwise_continuity.
intro.
pose proof (open_basis_to_open_neighborhood_basis B (f x) H).
apply open_neighborhood_basis_is_neighborhood_basis in H1.
apply (continuous_at_neighborhood_basis _ _ H1).
intros.
destruct H2 as [[? ?]].
apply open_neighborhood_is_neighborhood.
split; try constructor; auto.
Qed.

Lemma continuous_subbasis:
  forall (SB:Family Y), subbasis SB ->
  (forall V:Ensemble Y,
     In SB V -> open (inverse_image f V)) -> continuous.
Proof.
intros.
apply (continuous_open_basis _
  (finite_intersections_of_subbasis_form_open_basis _ _ H)).
intros.
destruct H1.
destruct H1 as [A [? [V' []]]].
rewrite H3.
rewrite inverse_image_indexed_intersection.
apply open_finite_indexed_intersection; trivial.
intros.
apply H0.
apply H2.
Qed.

Lemma continuous_closed :
  continuous <-> forall U, closed U -> closed (inverse_image f U).
Proof.
  split.
  - intros. red.
    rewrite <- inverse_image_complement.
    apply H. assumption.
  - intros.
    red. intros.
    apply closed_complement_open.
    rewrite <- inverse_image_complement.
    apply H. red. rewrite Complement_Complement.
    assumption.
Qed.

Lemma continuous_interior :
  continuous <->
  forall A, Included (inverse_image f (interior A))
                (interior (inverse_image f A)).
Proof.
split.
- intros. red; intros.
  assert (open (inverse_image f (interior A))).
  { apply H. apply interior_open. }
  apply (interior_maximal _ _ H1).
  + intros ? ?.
    destruct H2. constructor.
    apply interior_deflationary. assumption.
  + assumption.
- intros. red; intros.
  specialize (H V).
  rewrite interior_fixes_open in H; auto.
  assert (inverse_image f V = interior (inverse_image f V)).
  { apply Extensionality_Ensembles. split.
    - assumption.
    - apply interior_deflationary.
  }
  rewrite H1.
  apply interior_open.
Qed.

Lemma continuous_closure :
  continuous <->
  (forall A, Included (Im (closure A) f)
                 (closure (Im A f))).
Proof.
rewrite continuous_closed.
split.
- intros.
  remember (inverse_image f (closure (Im A f))) as B.
  assert (closed B).
  { subst B. apply H. apply closure_closed. }
  assert (Included (closure A) B).
  { subst B. apply closure_minimal; auto.
    intros ? ?.
    constructor. apply closure_inflationary.
    exists x; auto.
  }
  intros ? ?.
  destruct H2; subst.
  apply H1 in H2.
  destruct H2.
  assumption.
- intros.
  assert (inverse_image f U = closure (inverse_image f U)).
  2: { rewrite H1. apply closure_closed. }
  apply Extensionality_Ensembles; split.
  { apply closure_inflationary. }
  specialize (H (inverse_image f U)).
  assert (Included (Im (closure (inverse_image f U)) f) U).
  + apply (Inclusion_is_transitive _ _ (closure (Im (inverse_image f U) f)));
      auto.
    apply closure_fixes_closed in H0.
    rewrite <- H0 at 2.
    apply closure_increasing.
    apply image_inverse_image_included.
  + apply (inverse_image_increasing f) in H1.
    apply (Inclusion_is_transitive
             _ _ (inverse_image f (Im (closure (inverse_image f U)) f)));
      auto.
    apply inverse_image_image_included.
Qed.

End continuity.

Arguments continuous {X} {Y}.
Arguments continuous_at {X} {Y}.

Lemma continuous_composition_at: forall {X Y Z:TopologicalSpace}
  (f:Y -> Z) (g:X -> Y)
  (x:X),
  continuous_at f (g x) -> continuous_at g x ->
  continuous_at (fun x:X => f (g x)) x.
Proof.
intros.
red; intros.
rewrite inverse_image_composition.
auto.
Qed.

Lemma continuous_composition: forall {X Y Z:TopologicalSpace}
  (f:Y -> Z) (g:X -> Y),
  continuous f -> continuous g ->
  continuous (fun x:X => f (g x)).
Proof.
intros.
red; intros.
rewrite inverse_image_composition.
auto.
Qed.

Lemma continuous_identity: forall (X:TopologicalSpace),
  continuous (fun x:X => x).
Proof.
intros.
red; intros.
rewrite inverse_image_id.
assumption.
Qed.

Lemma continuous_constant: forall (X Y:TopologicalSpace)
  (y0:Y), continuous (fun x:X => y0).
Proof.
intros.
pose (f := fun _:X => y0).
fold f.
red; intros.
destruct (classic (In V y0)).
- replace (inverse_image f V) with (@Full_set X).
  { apply open_full. }
  apply Extensionality_Ensembles; split; red; intros.
  + constructor; trivial.
  + constructor.
- replace (inverse_image f V) with (@Empty_set X).
  { apply open_empty. }
  apply Extensionality_Ensembles; split; auto with sets;
    red; intros.
  destruct H1.
  contradiction H0.
Qed.

Lemma continuous_at_is_local: forall (X Y:TopologicalSpace)
  (x0:X) (f g:X -> Y)
  (N:Ensemble X),
  neighborhood N x0 -> (forall x:point_set X, In N x -> f x = g x) ->
  continuous_at f x0 -> continuous_at g x0.
Proof.
intros.
red; intros.
destruct H as [U1 [[]]].
rewrite <- H0 in H2.
2: { auto. }
apply H1 in H2.
destruct H2 as [U2 [[]]].
exists (Intersection U1 U2).
repeat split; trivial.
- apply open_intersection2; trivial.
- destruct H7.
  rewrite <- H0.
  + apply H6 in H8.
    destruct H8; trivial.
  + auto.
Qed.

Lemma dense_image_surjective {X Y : TopologicalSpace} {f : X -> point_set Y}
  (S : Ensemble X) :
  continuous f ->
  surjective f ->
  dense S ->
  dense (Im S f).
Proof.
intros.
apply Extensionality_Ensembles.
split; red; intros; constructor.
intros U [[? H4]].
destruct (H0 x) as [x0 H5].
assert (In (closure S) x0) as H6 by now rewrite H1.
destruct H6.
rewrite <- H5.
apply in_inverse_image, H6.
repeat split.
- red.
  rewrite <- inverse_image_complement.
  auto.
- apply H4.
  now econstructor; trivial.
Qed.

(* This fact is trivial, given function-extensionality. But in the usual
  "setoid-hell" and "constructive math" sense, it can be useful instead of
  doing rewrites. *)
Lemma continuous_funext {X Y : TopologicalSpace} (f g : X -> Y) :
  (forall x, f x = g x) ->
  continuous f -> continuous g.
Proof.
  intros Hfg Hf U HU.
  replace (inverse_image g U) with (inverse_image f U);
    auto.
  extensionality_ensembles; constructor;
    rewrite Hfg in *; assumption.
Qed.


Require Export GeoCoq.Elements.OriginalProofs.lemma_3_6a.

Section Euclid.

Context `{Ax:euclidean_neutral}.

Lemma lemma_betweennotequal :
   forall A B C,
   BetS A B C ->
   neq B C /\ neq A B /\ neq A C.
Proof.
intros.
assert (~ eq B C).
 {
 intro.
 assert (BetS A C B) by (conclude cn_equalitysub).
 assert (BetS B C B) by (conclude lemma_3_6a).
 assert (~ BetS B C B) by (conclude axiom_betweennessidentity).
 contradict.
 }
assert (~ eq A B).
 {
 intro.
 assert (BetS B A C) by (conclude cn_equalitysub).
 assert (BetS A B A) by (conclude axiom_innertransitivity).
 assert (~ BetS A B A) by (conclude axiom_betweennessidentity).
 contradict.
 }
assert (~ eq A C).
 {
 intro.
 assert (BetS A B A) by (conclude cn_equalitysub).
 assert (~ BetS A B A) by (conclude axiom_betweennessidentity).
 contradict.
 }
close.
Qed.

End Euclid.


Require Export a_base Bool.
Export ListNotations.
Set Implicit Arguments.

Module Type sound_mod (X: base_mod).
Import X.

(** * Definitions

definition of Propositional Formulas*)
Inductive PropF : Set :=
 | Var : PropVars -> PropF
 | Bot : PropF
 | Conj : PropF -> PropF -> PropF
 | Disj : PropF -> PropF -> PropF
 | Impl : PropF -> PropF -> PropF
.

Notation "# P" := (Var P) (at level 1) : My_scope.
Notation "A ∨ B" := (Disj A B) (at level 15, right associativity) : My_scope.
Notation "A ∧ B" := (Conj A B) (at level 15, right associativity) : My_scope.
Notation "A → B" := (Impl A B) (at level 16, right associativity) : My_scope.
Notation "⊥" := Bot (at level 0)  : My_scope.
Definition Neg A := A → ⊥.
Notation "¬ A" := (Neg A) (at level 5) : My_scope.
Definition Top := ¬⊥.
Notation "⊤" := Top (at level 0) : My_scope.
Definition BiImpl A B := (A→B)∧(B→A).
Notation "A ↔ B" := (BiImpl A B) (at level 17, right associativity) : My_scope.

(** Validness *)

(** Valuations are maps PropVars -> bool sending ⊥ to false*)
Fixpoint TrueQ v A : bool := match A with
 | # P   => v P
 | ⊥     => false
 | B ∨ C => (TrueQ v B) || (TrueQ v C)
 | B ∧ C => (TrueQ v B) && (TrueQ v C)
 | B → C => (negb (TrueQ v B)) || (TrueQ v C)
end.
Definition Satisfies v Γ := forall A, In A Γ -> Is_true (TrueQ v A).
Definition Models Γ A := forall v,Satisfies v Γ->Is_true (TrueQ v A).
Notation "Γ ⊨ A" := (Models Γ A) (at level 80).
Definition Valid A := [] ⊨ A.

(** Provability *)

Reserved Notation "Γ ⊢ A" (at level 80).
Inductive Nc : list PropF-> PropF->Prop :=
| Nax   : forall Γ A  ,    In A Γ                           -> Γ ⊢ A
| ImpI  : forall Γ A B,  A::Γ ⊢ B                           -> Γ ⊢ A → B
| ImpE  : forall Γ A B,     Γ ⊢ A → B -> Γ ⊢ A              -> Γ ⊢ B
| BotC  : forall Γ A  , ¬A::Γ ⊢ ⊥                              -> Γ ⊢ A
| AndI  : forall Γ A B,     Γ ⊢ A     -> Γ ⊢ B              -> Γ ⊢ A∧B
| AndE1 : forall Γ A B,     Γ ⊢ A∧B                        -> Γ ⊢ A
| AndE2 : forall Γ A B,     Γ ⊢ A∧B                        -> Γ ⊢ B
| OrI1  : forall Γ A B,     Γ ⊢ A                           -> Γ ⊢ A∨B
| OrI2  : forall Γ A B,     Γ ⊢ B                           -> Γ ⊢ A∨B
| OrE   : forall Γ A B C,   Γ ⊢ A∨B -> A::Γ ⊢ C -> B::Γ ⊢ C -> Γ ⊢ C
where "Γ ⊢ A" := (Nc Γ A) : My_scope.

Definition Provable A := [] ⊢ A.

(**The Theorems we are going to prove*)
Definition Prop_Soundness := forall A,Provable A->Valid A.
Definition Prop_Completeness := forall A,Valid A->Provable A.

(** * Theorems *)

Ltac mp := eapply ImpE.
Ltac AddnilL := match goal with
| |- _ ?Γ _ => change Γ with ([]++Γ)
end.
Ltac in_solve := intros;repeat
 (eassumption
||match goal with
   | H:In _ (_::_) |- _ => destruct H;[subst;try discriminate|]
   | H:In _ (_++_) |- _ => apply in_app_iff in H as [];subst
   | |- In _ (_++_) => apply in_app_iff;(left;in_solve;fail)||(right;in_solve;fail)
  end
||(once constructor;reflexivity)
||constructor 2).
Ltac is_ass := once econstructor;in_solve.

Ltac case_bool v A := let HA := fresh "H" in
(case_eq (TrueQ v A);intro HA;try rewrite HA in *;simpl in *;try trivial;try contradiction).

Local Ltac prove_satisfaction :=
intros ? K;destruct K;[subst;simpl;
match goal with
| [ H : TrueQ _ _ = _  |-  _ ] => rewrite H
end;exact I|auto].

Lemma PropFeq_dec : forall (x y : PropF), {x = y}+{x <> y}.
induction x;destruct y;try (right;discriminate);
 try (destruct (IHx1 y1);[destruct (IHx2 y2);[left;f_equal;assumption|]|];
  right;injection;intros;contradiction).
 destruct (Varseq_dec p p0).
   left;f_equal;assumption.
   right;injection;intro;contradiction.
 left;reflexivity.
Qed.

Lemma Excluded_Middle : forall Γ A, Γ ⊢ A∨¬A.
intros;apply BotC;mp;[is_ass|apply OrI2;apply ImpI;mp;[is_ass|apply OrI1;is_ass]].
Qed.

Lemma weakening2 : forall Γ A, Γ ⊢ A -> forall Δ, (forall B, In B Γ -> In B Δ) -> Δ ⊢ A.
induction 1;[constructor|constructor 2|econstructor 3|constructor 4|constructor 5|econstructor 6
|econstructor 7|constructor 8|constructor 9|econstructor 10];try eauto;
[apply IHNc..|apply IHNc2|try apply IHNc3];intros;in_solve;eauto.
Qed.

Lemma weakening : forall Γ Δ A, Γ ⊢ A -> Γ++Δ ⊢ A.
intros;eapply weakening2;[eassumption|in_solve].
Qed.

Lemma deduction : forall Γ A B, Γ ⊢ A → B -> A::Γ ⊢ B.
intros;eapply ImpE with A;[eapply weakening2;[eassumption|in_solve]|is_ass].
Qed.

Lemma prov_impl : forall A B, Provable (A → B)->forall Γ, Γ ⊢ A -> Γ ⊢ B.
intros. mp.
  AddnilL;apply weakening. apply H.
  assumption.
Qed.

(* This tactic applies prov_impl in IH (apply prov_impl in IH doesn't work, because I want to keep the Γ quantified)*)
Ltac prov_impl_in IH := let H := fresh "K" in
try (remember (prov_impl IH) as H eqn:HeqH;clear IH HeqH).

(** Soundness *)

Theorem Soundness_general : forall A Γ, Γ ⊢ A -> Γ ⊨ A.
intros A Γ H0 v;induction H0;simpl;intros;auto;
 try simpl in IHNc;try simpl in IHNc1;try simpl in IHNc2;
  case_bool v A;try (case_bool v B;fail);
   try (apply IHNc||apply IHNc2;prove_satisfaction);
    case_bool v B;apply IHNc3;prove_satisfaction.
Qed.

Theorem Soundness : Prop_Soundness.
intros ? ? ? ?;eapply Soundness_general;eassumption.
Qed.

End sound_mod.


(** This module contains a set of basic definitions
    that will be of use but do not depend upon the
    specifics of the problem at hand.               *)
(** ---- *)

Require Import List Arith.
Require Import FSets FSetAVL FSetFacts FSetEqProperties FSetProperties.

(** * Tactics *)
Ltac blast := solve [ auto |  discriminate | contradiction ].
Ltac cauto := try blast.

(** * Sets *)

Module Nat <: OrderedType.
  Definition t := nat.
  Definition eq (a b : t) := a=b.
  Definition lt (a b : t) := a<b.

  Lemma eq_refl : forall x : t, eq x x.
  Proof.
    intro; unfold eq; auto.
  Qed.

  Lemma eq_sym : forall x y : t, eq x y -> eq y x.
  Proof.
    intro;unfold eq;auto.
  Qed.

  Lemma eq_trans : forall x y z : t, eq x y -> eq y z -> eq x z.
  Proof.
    intros x y z h h';unfold eq in *; rewrite h in *;auto.
  Qed.

  Definition lt_trans : forall x y z : t, lt x y -> lt y z -> lt x z :=
    lt_trans.

  Definition lt_not_eq : forall x y : t, lt x y -> ~ eq x y :=
    NPeano.Nat.lt_neq.

  Definition compare : forall x y : t, Compare lt eq x y.
  Proof.
    SearchAbout ({ _ } +  { _ } + { _ } ).
    intros x y; case (lt_eq_lt_dec x y) as [[h|h]|h];
    [apply LT
    |apply EQ
    |apply GT];auto.
  Qed.
  Definition eq_dec := eq_nat_dec.
End Nat.

Module NSet := FSetAVL.Make(Nat).
Module NF := FSetFacts.Facts NSet.
Module NP := FSetProperties.Properties NSet.

Lemma Equal_add : forall x s s', NSet.eq s s' ->
                                 NSet.eq (NSet.add x s) (NSet.add x s').
Proof.
  intros x s s' he.
  apply NP.Add_Equal;simpl; intro y;
  case (eq_nat_dec x y) as [->|h];split;intro h';
  [left
  |apply NSet.add_1
  |right;apply he;apply NSet.add_3 in h'
  |case h' as [->|h'];
    [absurd (y = y)
    |apply NSet.add_2;apply he]
  ]; auto.
Qed.

(** * Lists *)
Lemma strong_induction :
  forall n P,
    P 0 -> (forall n, (forall m, m<n -> P m) -> P n)
    -> P n.
Proof.
  cut (forall n P, (forall k, k <= 0 -> P k) ->
                   (forall n, (forall m, m <= n -> P m)
                              -> (forall m, m<= S n -> P m))
                ->  (forall m, m<= n -> P m)).
  intros h n P p0 hind.
  apply (h n);auto.
  intros k hk;apply le_n_0_eq in hk as <-;auto.
  intros m hind2 k hk.
  apply hind;intros l hl.
  apply hind2;
  apply lt_n_Sm_le;apply (lt_le_trans _ k);auto.

  intros n P p0 hind.
  induction n.
  intros;auto.
  apply hind;auto.
Qed.

Lemma strong_induction_list {A}  :
  forall f (P : A -> Prop), (forall l, f l = 0 -> P l) ->
            (forall l, (forall m, f m < f l -> P m) -> P l)
            -> forall l, P l.
Proof.
  intros f P h0 hind l; set (ln := f l);
  assert (f l = ln) as hln; auto.
  cut (forall l, f l = ln -> P l).
  intros h1;auto.
  apply (strong_induction ln).
  apply h0.
  intros n hi m hm.
  apply hind.
  intros k hk; apply (hi (f k)).
  rewrite <- hm;auto.
  auto.
Qed.

Lemma app_prop_dec {A} :
  forall (u : list A) P,
  (forall u1 u2, Decidable.decidable (P u1 u2)) ->
    Decidable.decidable (exists u1 u2, u = u1 ++ u2 /\ P u1 u2).
Proof.
  induction u;intros P hd.
  case (hd nil nil) as [h|h].
  left;exists nil;exists nil;auto.
  right;intros (u1 & u2 & hu & hp).
  destruct u1;destruct u2; cauto.
  case (IHu (fun u1 u2 => P (a::u1) u2)) as [(u1 & u2 & hu & hp)|h].
  intros u1 u2;apply hd.
  left;exists (a::u1); exists u2;split.
  simpl;f_equal;auto.
  auto.
  case (hd nil (a::u)) as [hnil|hnil].
  left;exists nil;exists (a::u);split;auto.
  right;intros (u1 & u2 & hu & hp).
  destruct u1;simpl in *.
  rewrite hu in *;cauto.
  apply h;exists u1;exists u2.
  inversion hu;auto.
Qed.

(** A mesure is just a list homomorphism. *)
Definition mesure {A} mes :=
  (forall u1 u2 : list A, mes (u1 ++ u2) = mes u1 + mes u2).

(** Usefull thing *)
Lemma inv_rev {A} (u1 u2 : list A) (o1 o2 : A) :
  u1++o1::nil = u2++o2::nil -> u1 = u2 /\ o1 = o2.
Proof.
  intro h.
  assert (rev (u1++o1::nil) = rev (u2++o2::nil)) as hr.
  rewrite h;auto.
  repeat rewrite rev_unit in hr;inversion hr.
  rewrite <- (rev_involutive u1);
  rewrite <- (rev_involutive u2);rewrite H1;auto.
Qed.

Lemma decomposition {A} : forall u1 u2 u3 u4 : list A, u1++u2 = u3++u4 ->
exists u5, (u1=u3++u5 /\ u4=u5++u2) \/ (u3=u1++u5 /\ u2=u5++u4).
Proof.
induction u1.
intros; exists u3; right;split; simpl; auto.
destruct u3.
intros; exists (a::u1); left;split; simpl; auto.
intros.
repeat rewrite<- app_comm_cons in *.
inversion H.
rewrite<- H1 in *.
apply IHu1 in H2.
destruct H2.
exists x; case H0;intros;destruct H2;
[left|right]; rewrite H2;rewrite H3; auto.
Qed.

Ltac decomp h :=
let x := fresh "u" in
let h0 :=fresh "h" in
let h1 := fresh "h" in
let h2 := fresh "h" in
case (decomposition _ _ _ _ h); intros x h0; case h0; clear h0; intro h1;
destruct h1 as (h1,h2); rewrite h1 in *;rewrite h2 in *;
simpl in *;clear h.

Lemma app_inv_tail {A} u v w (x : A) :
  u ++ v = w ++ x :: nil
  -> v <> nil
  -> exists z, w = u ++ z /\ v = z ++ x::nil.
Proof.
  intros h hv.
  decomp h.
  destruct u0;simpl in *.
  exists nil;
  repeat rewrite<- app_nil_end in *; simpl;
    rewrite<- h2 in *;auto.
  inversion h2;
  symmetry in H1;apply app_eq_nil in H1;destruct H1;cauto.
  exists u0;split;auto.
Qed.


(*
   We would like to define the notion of an algebra with given operations satisfying given
   equations. For example, a group has of three operations (unit, multiplication, inverse)
   and five equations (associativity, unit left, unit right, inverse left, inverse right).
*)

(* We start by defining operation signatures. These describe the operations
   of an algebra.

   The main trick is that the arity of an operation is *not* a number
   but rather a type. For instance, the arity of a binary operation
   is a type with two elements. (And nothing prevents us from having
   an infinite type as arity.)
 *)

(*the following libraries are important to manipualte algebras more easily in our proofs, and allow rewrite tactics*)
Require Import Setoid.
Require Import Morphisms.

(*the signature is a set of operation names with an arity function*)
Record OpSignature :=
  {
    operation : Type ; (* (Names of) operations. *)
    arity : operation -> Type (* Each operation has an arity. *)
  }.

Arguments arity {_} _.

(* We shall consider algebras with given operations, but without equations.
   We call these "operation algebras". *)

Record OpAlgebra (S : OpSignature) :=
  {
    carrier :> Type ;
    op : forall o : operation S, (arity o -> carrier) -> carrier;
    (* no equations *)
  }.

Arguments op {_} _ _ _.

Check op.

(*then we define inductively the type of terms : it takes on argument an OpSignature and a type for the base case (infered_generator) *)

Inductive Tree (S : OpSignature) (X : Type) : Type :=
  | generator : X -> Tree S X
  | node : forall (o : operation S), (arity o -> Tree S X) -> Tree S X.

Arguments generator {_} {_} _.
Arguments node {_} {_} _.

(* Now given some operations, described by an operation signature S,
   we can define an equation signature which specifies some equations.
*)
Record EqSignature (S : OpSignature) :=
  {
  equ :> Type ; (* (names of) equations *)
  X : Type ;

    (* Next we specify the equations. Note that they are polymorphic in the underlying algebra. *)
  lhs : equ -> Tree S X ; (* left-hand sides *)
  rhs : equ -> Tree S X ; (* right-hand sides *)
  }.

Arguments lhs {_} _ _.
Arguments rhs {_} _ _.

(* We define how to interpret trees as elements of A *)
Fixpoint inter {S : OpSignature} {A : OpAlgebra S} {X : Type} (val : X -> A) (t : Tree S X) :=
  match t with
  | generator x => val x
  | node o args => op A o (fun x => inter val (args x))
  end.

(* We define the congruence relation used for the algebras *)
Record CongRelation {S : OpSignature} (A : OpAlgebra S) :=
  {
    cong_rel :> A -> A -> Prop; (* the equality relation *)
    cong_rel_refl : forall x, cong_rel x x;
    cong_rel_sym : forall x y, cong_rel x y -> cong_rel y x;
    cong_rel_trans : forall x y z, cong_rel x y -> cong_rel y z -> cong_rel x z;
    cong_rel_cong : forall (o : operation S) (args1 args2 : arity o -> A), (forall (n : arity o), cong_rel (args1 n) (args2 n)) -> cong_rel (op A o args1) (op A o args2);
}.

(* We can now define what it means to have an algebra for a signature S satisfying
   equations E. *)
Record Algebra (S : OpSignature) (E : EqSignature S) :=
  {
  M :> OpAlgebra S ;
  equal : CongRelation M;
  equations : forall (e : E) (val : X S E -> M), equal (inter val (lhs E e)) (inter val (rhs E e))
  }.

(* We define the type of homomorphism between algebras A and B. *)

Record Hom {S : OpSignature} {E : EqSignature S} (A : Algebra S E) (B : Algebra S E)  :=
  {
    map :> A -> B ; (* The underlying map *)
    (* The underlying map commutes with operations: *)
    op_respect : forall (x y : A), (equal S E A) x y -> (equal S E B) (map x) (map y);
    op_commute : forall (o : operation S) (args : arity o -> A),
                   (equal S E B) (map (op A o args)) (op B o (fun x => map (args x)))
  }.

Definition isomorphic {S : OpSignature} {E : EqSignature S} (A B : Algebra S E) :=
exists (f: Hom A B) (g : Hom B A), (forall x : A, (equal S E A) (g (f x))  x) /\ (forall x : B, (equal S E B) (f (g x)) x).

(*finally, a useful lemma*)
Lemma equal_setoid {S : OpSignature} {E : EqSignature S} (A : Algebra S E) : Setoid_Theory A (equal S E A).
Proof.
unfold Setoid_Theory.
split.
unfold Reflexive.
apply (cong_rel_refl (M S E A) (equal S E A)).
unfold Symmetric.
apply (cong_rel_sym (M S E A) (equal S E A)).
unfold Transitive.
apply (cong_rel_trans (M S E A) (equal S E A)).
Qed.

Section free_is_unique.
(* in this section we are going to define what is freeness and to proove that 2 free object over the same type are isomorphic*)

(*the commuting property*)

(*we then say that an algebra A is free over (X, q) relatively to an algebra B and a function f iff there is only one f_tilde
in HOM(A, B) such that it makes the diagramm commute :

           f
       X ----->B
       |      /
       |     /
      q|    /f_tilde
       |   /
       |  /
       | /
       A

*)

Definition commute {S : OpSignature} {E : EqSignature S} (A B : Algebra S E) (X : Type) (q : X -> A) (f : X -> B) (f_tilde : Hom A B)  :=
forall (x : X), (equal S E B) (((map A B) f_tilde) (q x)) (f x).

Record free_relative {S : OpSignature} {E : EqSignature S} (A B : Algebra S E) (X : Type) (q : X -> A) (f : X -> B) :=
{ f_tilde : Hom A B ;
  it_commutes : commute A B X q f f_tilde ;
  uniqueness  : forall (g : Hom A B), commute A B X q f g /\ commute A B X q f f_tilde -> (forall (x  : A), (equal S E B) (f_tilde x) (g x)) }.

(*then, we define free : an Algebra is free over (X, q) if for all algebra B and function f X -> B, we have the relative freeness*)
Definition free {S : OpSignature} {E : EqSignature S} (A: Algebra S E) (X : Type) (q : X -> A) :=
 forall (B : Algebra S E) (f : X -> B), free_relative A B X q f.

Definition identite {S : OpSignature} {E : EqSignature S} (A : Algebra S E) : Hom A A.
Proof.
split with (fun (x : A) => x).
intros.
auto.
intros.
assert (args = fun x => args x).
auto.
rewrite H.
apply (cong_rel_cong A).
intros n ; apply (cong_rel_refl A).
Defined.

Definition composition {S : OpSignature} {E : EqSignature S} (A B C: Algebra S E) (f : Hom A B) (g : Hom B C) : Hom A C.
Proof.
split with (fun x => g (f x)).
intros.
apply ((op_respect B C) g).
apply ((op_respect A B) f).
auto.
intros.
apply (cong_rel_trans) with (y := g (op B o (fun x => f (args x)))).
apply ((op_respect B C) g).
apply ((op_commute A B) f).
apply (op_commute).
Defined.

(*rewrite using specialize tactic*)

Lemma uniqueness_of_free (X : Type) {S : OpSignature} {E : EqSignature S} (A B : Algebra S E) (q : X -> A) (q' : X -> B) :
free A X q -> free B X q' -> isomorphic A B.
intros.
unfold isomorphic.
assert (free_relative A B X q q').
apply X0.
assert (free_relative B A X q' q).
apply X1.
exists ((f_tilde A B X q q') X2).
exists ((f_tilde B A X q' q) X3).
remember ((f_tilde A B X q q') X2) as f_hom.
remember ((f_tilde B A X q' q) X3) as g_hom.
split.
+
intros.
assert (free_relative A A X q q).
apply X0.
assert ((forall (x  : A), (equal S E A) ((f_tilde A A X q q X4) x) (identite A x))).
apply (uniqueness A A X q q X4).
split.
unfold commute.
intros.
simpl.
apply (cong_rel_refl A).
apply (it_commutes A A X q q X4).
assert (forall (x : A), (equal S E A) ((f_tilde A A X q q X4) x) ((((composition A B A) f_hom g_hom)) x)).
apply (uniqueness A A X q q X4).
split.
unfold commute.
intros.
assert (commute A B X q q' f_hom).
rewrite Heqf_hom.
apply ((it_commutes A B X q q') X2).
unfold commute in H0.
assert (commute B A X q' q g_hom).
rewrite Heqg_hom.
apply ((it_commutes B A X q' q) X3).
unfold commute in H1.
assert (forall x0, (equal S E A) (g_hom (f_hom (q x0))) (g_hom (q' x0))).
intros.
apply (op_respect).
auto.
simpl.
apply (cong_rel_trans A) with (y := g_hom (q' x0)).
auto.
auto.
apply (it_commutes).
apply (cong_rel_trans A) with (y := f_tilde A A X q q X4 x).
apply (cong_rel_sym A).
simpl in H0.
auto.
simpl in H.
auto.
+
intros.
assert (free_relative B B X q' q').
apply X1.
assert ((forall (x  : B), (equal S E B) ((f_tilde B B X q' q' X4) x) (identite B x))).
apply (uniqueness B B X q' q' X4).
split.
unfold commute.
intros.
simpl.
apply (cong_rel_refl B).
apply (it_commutes B B X q' q' X4).
assert (forall (x : B), (equal S E B) ((f_tilde B B X q' q' X4) x) ((((composition B A B) g_hom f_hom)) x)).
apply (uniqueness B B X q' q' X4).
split.
unfold commute.
intros.
assert (commute B A X q' q g_hom).
rewrite Heqg_hom.
apply ((it_commutes B A X q' q) X3).
unfold commute in H0.
assert (commute A B X q q' f_hom).
rewrite Heqf_hom.
apply ((it_commutes A B X q q') X2).
unfold commute in H1.
assert (forall x0, (equal S E B) (f_hom (g_hom (q' x0))) (f_hom (q x0))).
intros.
apply (op_respect).
auto.
simpl.
apply (cong_rel_trans B) with (y := f_hom (q x0)).
auto.
auto.
apply (it_commutes).
apply (cong_rel_trans B) with (y := f_tilde B B X q' q' X4 x).
apply (cong_rel_sym B).
simpl in H0.
auto.
simpl in H.
auto.
Qed.
End free_is_unique.

(*this section is about the definition and properties of the term algebra*)
Section TermAlgebra_definition.
(*we contextualise the object in this section : to use the definitions here outside of this section,
we will need to provie an OpSignature S and an E an EqSignature over S**)
Context (S : OpSignature).
Context (E : EqSignature S).
Check generator.
Definition infered_generator:= X S E.
Check infered_generator.

(*propagation of the substition in a tree : it is to use the substition rule in a tree*)
Fixpoint application_subst (T : Tree S infered_generator) (theta : infered_generator -> Tree S infered_generator) : Tree S infered_generator :=
match T with
|generator x => theta x
|node o args => node o (fun x =>
 application_subst (args x) (theta))
end.

(*the A |- p = q relation : this will be the equality (i.e the CongRelation here) over the terms
(i.e trees) here, and this will define a setoid, as we will proove it later *)

(*changer le type de cong relation de type to prop*)

Inductive quotient_relation : Tree S infered_generator -> Tree S infered_generator -> Prop :=
|cas_base : forall (e : E), quotient_relation (lhs E e) (rhs E e)
|cas_refl : forall (T : Tree S infered_generator), quotient_relation T T
|cas_sym : forall (T T': Tree S infered_generator), quotient_relation T' T -> quotient_relation T T'
|cas_trans : forall (T T' T'' : Tree S infered_generator), quotient_relation T T' -> quotient_relation T' T'' -> quotient_relation T T''
|cas_passage_contexte : forall (op : operation S) (args args' : arity op -> Tree S infered_generator),
(forall (n : arity op), quotient_relation (args n) (args' n)) -> quotient_relation (node op (fun i => args i)) (node op (fun i => args' i))
|cas_subst : forall (T T' : Tree S infered_generator ) (theta : infered_generator -> Tree S infered_generator),
quotient_relation T T' -> quotient_relation (application_subst T theta) (application_subst T' theta).

(*we are going to declare the type of trees with quotient relation as a setoid. We need to provide a proof
that quotient_relation is indeed an equivalence relation *)
Lemma tree_setoid : Setoid_Theory (Tree S infered_generator ) quotient_relation.
Proof.
unfold Setoid_Theory.
split.
unfold Reflexive.
apply cas_refl.
unfold Symmetric.
intros.
apply cas_sym.
exact H.
unfold Transitive.
intros.
apply cas_trans with (T := x) (T' := y) (T'' := z).
auto. auto.
Qed.

Add Setoid (Tree S infered_generator ) quotient_relation tree_setoid as setoid_term_algebra.

(*then, the term algebra is simply the OpAlgebra with carrier the type of trees and the interpretation of an
operation is the associated node*)

Definition Term_algebra : OpAlgebra S :=
{|carrier := Tree S infered_generator  ;
op := (fun (o : operation S) => (fun (args : arity o -> Tree S infered_generator ) => node o args))|}.

(*we then need, in order to build an algebra, to define a CongRelation over the Term_algebra. We are going to use quotient_relation *)

Definition eqtree : CongRelation Term_algebra.
split with (quotient_relation).
apply cas_refl.
intros ;  rewrite H ; apply cas_refl.
intros. rewrite H. exact H0.
intros. apply cas_passage_contexte with (op := o) (args := args1) (args' := args2).
auto.
Defined.

(*We need this lemma, it will maybe be redone in the future, but as for now, I will keep it :
an amelioration would be to define substition directly by using inter, but it makes things less clear thatn defining
properly substition and then showging that indeed it is the same thing*)

Lemma egalité_utile : forall (T : Tree S infered_generator ) (theta : infered_generator -> Tree S infered_generator ),
quotient_relation (application_subst T theta) (inter (A := Term_algebra) theta T).
Proof.
intros.
induction T.
simpl ; reflexivity.
simpl.
apply cas_passage_contexte.
exact H.
Qed.

(*now, lets show that the term algebra, with the congrelation eqtree (built over quotient_relation) is
an algebra of the equationnal theory E*)

Definition Term_algebra_model : Algebra S E.
split with Term_algebra eqtree.
intros.
simpl.
rewrite <- ? egalité_utile.
apply cas_subst.
apply cas_base.
Defined.

(*indeed, the term algebra is a model of what it is supposed to represent*)

(*now let's show that the term algebra is free *)

Context  (A : Algebra S E).
Context (f : infered_generator -> A).

(*To manipulate more easily the definitions, we decalre A equal S E A as a setoid*)
Check cong_rel_refl.

Add Setoid A (equal S E A) (equal_setoid A) as A_is_setoid.

(*what we want is a function q (that does not depend of f) called the free map and
an unique homomorphism f_tilde that makes this diagramm commute :

                     f
infered_generator ------> A
       |                 /
       |                /
      q|               /f_tilde
       |              /
       |             /
       |            /
      term_algebra
                  *)

(*we define q*)
Definition q (x : infered_generator) : Term_algebra :=
generator x.

(*we define now the function that is an homomorphism from term_algebra to A by induction over the terms*)

Fixpoint f_tilde_term (t : Term_algebra) : A := match t with
|generator x => f x
|node operation args => ((op A) operation) (fun x => f_tilde_term (args x))
end.

Lemma lemme_utile_2 : forall (x : Term_algebra),  (equal S E A) (f_tilde_term x) (inter f x).
Proof.
intros.
induction x.
simpl.
reflexivity.
simpl.
apply (cong_rel_cong A).
intros.
apply H.
Qed.

Lemma is_the_same : forall (T : Term_algebra) (f : infered_generator -> A) (theta : infered_generator -> Tree S infered_generator),
equal S E A (inter f (application_subst T theta)) (inter (fun x => inter f (theta x)) T).
Proof.
intros.
induction T.
simpl.
reflexivity.
intros.
simpl.
apply (cong_rel_cong).
exact H.
Qed.

Lemma equal_is_equal : forall (x y : Term_algebra)(f : infered_generator -> A),
quotient_relation x y -> (equal S E A) (inter f x) (inter f y).
Proof.
intros.
generalize dependent f0.
induction H.
intros.
apply (equations S E A) with (e := e) (val := f0).
intros.
apply cong_rel_refl.
intros.
apply cong_rel_sym.
auto.
intros.
apply cong_rel_trans with (y := inter f0 T').
auto.
auto.
intros.
simpl.
apply (cong_rel_cong).
intros.
auto.
intros.
rewrite 2 is_the_same.
apply IHquotient_relation with (f0 := fun x => inter f0 (theta x)).
Qed.

Definition is_an_homomorphism : Hom (Term_algebra_model) A.
Proof.
exists f_tilde_term.
intros.
+
rewrite ? lemme_utile_2.
apply equal_is_equal.
auto.
+
intros.
simpl.
apply cong_rel_cong.
intros.
apply reflexivity.
Defined.

Lemma makes_the_diagramm_commute : forall (x : infered_generator ), (equal S E A) (f x) (f_tilde_term (q x)).
Proof.
intros.
simpl.
reflexivity.
Qed.

Lemma unicité : forall (f' g' : Hom Term_algebra_model A),
(forall (x : infered_generator ), (equal S E A) (f' (generator x)) (g' (generator x)))-> (forall (t : Term_algebra), (equal S E A) (f' t) (g' t)).
Proof.
intros.
induction t.
auto.
assert ((equal S E A) (f' (node o t)) (op A o (fun x => f' (t x)))).
apply (op_commute Term_algebra_model A).
assert ((equal S E A) (g' (node o t)) (op A o (fun x => g' (t x)))).
apply (op_commute Term_algebra_model A ).
apply (cong_rel_trans A (equal S E  A)) with (x :=  (f' (node o t))) (y := (op A o (fun x : arity o => f' (t x)))) (z := (g' (node o t))).
auto.
apply (cong_rel_trans A (equal S E A)) with (x := (op A o (fun x : arity o => f' (t x)))) (y := (op A o (fun x : arity o => g' (t x)))) (z := (g' (node o t))).
apply (cong_rel_cong A (equal S E A)).
auto.
symmetry.
auto.
Qed.

End TermAlgebra_definition.

Section TermALgebra_is_free.
Context (S : OpSignature).
Context (E : EqSignature S).
Check Term_algebra.
Check f_tilde_term.

Definition is_free_term_algebra : free (Term_algebra_model S E) (X S E) (fun x => generator x).
Proof.
unfold free.
intros.
split with (is_an_homomorphism S E B f).
unfold commute.
intro.
simpl.
apply (cong_rel_sym).
unfold is_an_homomorphism.
apply (cong_rel_refl).
intros.
apply unicité.
intros.
unfold is_an_homomorphism.
simpl.
destruct H.
unfold commute in H.
unfold commute in H0.
apply (cong_rel_trans B) with (y := is_an_homomorphism S E B f (generator x0)).
apply (cong_rel_sym B).
auto.
apply (cong_rel_trans B) with (y := f x0).
auto.
apply (cong_rel_sym B).
auto.
Defined.

End TermALgebra_is_free.

Section iso_caracterisation.
Context (S : OpSignature).
Context (E : EqSignature S).
Context (A B : Algebra S E).

Definition injective (f : Hom A B) : Type := forall (x y : A), (equal S E B) (f x) (f y) -> (equal S E A) x y.

Definition surjective (f : Hom A B) : Type := forall x, {t | f t = x}.

Context (f : Hom A B).
Hypothesis injectf : injective f.
Hypothesis surjectf : surjective f.

Definition f_inv (x : B) :  A.
Proof.
unfold surjective in surjectf.
pose proof surjectf x.
destruct X0.
exact x0.
Defined.

Print f_inv.

Lemma un_sens: forall (x : A), (equal S E A) (f_inv (f x)) x.
Proof.
intros.
unfold surjective in surjectf.
unfold injective in injectf.
unfold f_inv.
destruct (surjectf (f x)) as [x0 H].
apply injectf.
rewrite H.
apply cong_rel_refl.
Qed.

Lemma autre_sens : forall (x : B), (equal S E B) (f (f_inv x)) x.
Proof.
intros.
unfold surjective in surjectf.
unfold injective in injectf.
unfold f_inv.
destruct (surjectf x) as [x0 e].
rewrite e.
apply cong_rel_refl.
Qed.

Lemma respect_rel : forall (x y : B), (equal S E B) x y -> (equal S E A) (f_inv x) (f_inv y).
Proof.
intros.
unfold f_inv.
unfold surjective in surjectf.
destruct (surjectf x) as [x0 e].
destruct (surjectf y) as [x1 e'].
unfold injective in injectf.
apply injectf.
rewrite e.
rewrite e'.
auto.
Qed.

Definition iso_back : Hom B A.
Proof.
split with (f_inv).
intros.
apply respect_rel.
auto.
intros.
apply cong_rel_trans with (y := f_inv (op B o (fun x => f (f_inv (args x))))).
apply respect_rel.
apply cong_rel_cong.
intros.
apply cong_rel_sym.
apply autre_sens with (x := args n).
apply cong_rel_trans with (y := f_inv (f (op A o (fun x => f_inv (args x))))).
apply respect_rel.
apply cong_rel_sym.
apply op_commute.
apply un_sens.
Qed.


(**  Well ordered sets (after Schutte) *)

(**  Pierre Casteran LaBRI, Universite de Bordeaux  *)

From Coq Require Import Relations  Classical  Classical_sets RelationClasses
     Wf_nat.

From hydras Require Import PartialFun.
Import MoreEpsilonIota.

Arguments In [U].
Arguments Included [U].

Set Implicit Arguments.
#[global] Hint Unfold In : core.

Section the_context.

  (* begin snippet MDecl *)
  Variables (M:Type)
            (Lt : relation M).

  Definition Le (a b:M) :=  a = b \/ Lt a b.

  Definition least_member  (X:Ensemble M) (a:M) :=
    In X a /\ forall x,  In X x -> Le a x.
  (* end snippet MDecl *)

  Definition least_fixpoint (f : M -> M) (x:M) :=
    f x = x /\ forall y: M,  f y = y -> Le x y.

  (** Well Ordering *)

  (* begin snippet WODef *)
  Class WO : Type:=
    {
    Lt_trans : Transitive  Lt;
    Lt_irreflexive : forall a:M, ~ Lt a a;
    well_order : forall (X:Ensemble M)(a:M),
        In X a ->
        exists a0:M, least_member  X a0
    }.
  (* end snippet WODef *)

  (* Some derived properties of well ordered sets *)

  Section About_WO.
    Context (Wo : WO).

    Lemma  Lt_connect : forall a b,  Lt a b \/ a = b \/ Lt b a.
    Proof.
      intros a b ; generalize (well_order  (Couple _ a b) a ).
      destruct 1 as [ c H1].
      - left.
      -  destruct H1  as [H2 H3].
         destruct H2.
         +  destruct (H3 b);auto; now right.
         +  destruct (H3 a);auto; now left.
    Qed.

    Lemma Le_refl : forall x:M, Le x x.
    Proof.
      red;unfold Le;auto.
    Qed.

    Lemma Le_antisym : forall a b,  Le a b -> Le b a -> a = b.
    Proof.
      intros a b  H H'; case H; case H' ; try tauto.
      - symmetry; tauto.
      - intros;case (Lt_irreflexive (a:=a)); eapply (Lt_trans );eauto.
    Qed.

    #[global] Instance  Le_trans : Transitive  Le.
    Proof.
      unfold Transitive, Le;intros.
      case H;case H0.
      - intros; left ; congruence.
      -  intros H1 H2; right;subst x;auto.
      -  intros H1 H3; right ; subst y; auto.
      -  right;apply Lt_trans with y;eauto.
    Qed.

    Lemma Le_Lt_trans : forall x y z, Le x y -> Lt y z -> Lt x z.
    Proof.
      intros x y z Hxy Hyz; case Hxy;intros.
      -  now subst y.
      - eapply Lt_trans; eauto.
    Qed.

    Lemma Lt_Le_trans : forall x y z, Lt x y -> Le y z -> Lt x z.
    Proof.
      intros x y z Hxy Hyz; destruct Hyz as [H0 | H].
      - now subst.
      -  eapply Lt_trans; eauto.
    Qed.

    Lemma Lt_not_Gt : forall x y,  Lt x y -> ~ Lt y x.
    Proof.
      intros x y  H H'; case (Lt_irreflexive (a:=x)).
      eapply Lt_trans; eauto.
    Qed.

    Lemma least_member_lower_bound : forall X a,
        least_member  X a -> forall b, In X b ->  Le a b.
    Proof.
      intros X a H; case H.
      unfold In; intuition.
    Qed.

    Lemma least_member_glb :
      forall X a,
        least_member  X a ->
        forall b, (forall c, In X c ->  Le b c) ->
                  Le b a.
    Proof.
      intros X a H b H0; case H;intros H1 H2;  apply H0; auto.
    Qed.

    Theorem least_member_unicity : forall  X a b,
        least_member  X a -> least_member  X b -> a = b.
    Proof.
      intros X a b H H0;  case H;case H0;intros.
      - apply Le_antisym;auto.
    Qed.

    Theorem least_member_ex_unique :
      forall   X  x
               (inhX: In X x),
      exists! a,  least_member  X a.
    Proof.
      intros;destruct (well_order X x); auto.
      exists x0; split; auto.
      intros; eapply least_member_unicity;eauto.
    Qed.

    Theorem least_member_of_eq : forall (X Y : Ensemble M) a b ,
        Included X Y -> Included Y X ->
        least_member  X a ->
        least_member  Y b ->
        a = b.
    Proof.
      intros X Y a b H H0  [H3 H4 ] [H6 H7].  apply Le_antisym;auto.
    Qed.

  End About_WO.

End the_context.

(* begin snippet theLeast *)

Definition the_least {M: Type} {Lt}
           {inh : InH M} {WO: WO Lt} (X: Ensemble M)  : M :=
  the (least_member Lt X ).

(* end snippet theLeast *)

Lemma  the_least_unicity {M: Type} {Lt}
       {inh : InH M} {WO: WO Lt} (X: Ensemble M)
       (HX: Inhabited _ X )
  : exists! l , least_member   Lt X l.
Proof.
  destruct HX as [x Hx].
  case  WO; intros.
  destruct (well_order0 X x Hx) as [x0 H0].
  exists x0; split; auto.
  intros; eapply least_member_unicity;eauto .
Qed.

#[ global ] Instance WO_nat : WO Peano.lt.
split.
- red. intros; now  transitivity y.
- intros; apply PeanoNat.Nat.lt_irrefl.
-  intros X a; pattern a; apply well_founded_induction with Peano.lt.
   + apply lt_wf.
   + intros;
       destruct (classic (least_member lt X x)).
     * exists x; auto.
     * unfold least_member in H1;     destruct (not_and_or _ _ H1).
       contradiction.
       destruct (not_all_ex_not _ _ H2).
       destruct (imply_to_and _ _ H3).
       assert (lt x0 x). {
         destruct (Compare_dec.lt_eq_lt_dec x0 x).
         - destruct s; auto.
           + subst x0; unfold Le in H5.
             destruct H5; auto.
         - destruct H5; now right.
       }
       destruct (H x0 H6 H4);  exists x1;  auto.
Qed.


Require Import ZArith.
Require Import Classical.
Require Import List.

Open Scope list_scope.
Open Scope Z_scope.

Dp_debug.
Dp_timeout 3.
Require Export zenon.

Definition neg (z:Z) : Z := match z with
  | Z0 => Z0
  | Zpos p => Zneg p
  | Zneg p => Zpos p
  end.

Goal forall z, neg (neg z) = z.
  Admitted.

Open Scope nat_scope.
Print plus.

Goal forall x, x+0=x.
  induction x; ergo.
  (* simplify resoud le premier, pas le second *)
  Admitted.

Goal 1::2::3::nil = 1::2::(1+2)::nil.
  zenon.
  Admitted.

Definition T := nat.
Parameter fct : T -> nat.
Goal fct O = O.
 Admitted.

Fixpoint even (n:nat) : Prop :=
  match n with
  O => True
  | S O => False
  | S (S p) => even p
  end.

Goal even 4%nat.
  try zenon.
  Admitted.

Definition p (A B:Set) (a:A) (b:B) : list (A*B) := cons (a,b) nil.

Definition head :=
fun (A : Set) (l : list A) =>
match l with
| nil => None (A:=A)
| x :: _ => Some x
end.

Goal forall x, head _ (p _ _ 1 2) = Some x -> fst x = 1.

Admitted.

(*
BUG avec head prédéfini : manque eta-expansion sur A:Set

Goal forall x, head _ (p _ _ 1 2) = Some x -> fst x = 1.

Print value.
Print Some.

zenon.
*)

Inductive IN (A:Set) : A -> list A -> Prop :=
  | IN1 : forall x l, IN A x (x::l)
  | IN2: forall x l, IN A x l -> forall y, IN A x (y::l).
Implicit Arguments IN [A].

Goal forall x, forall (l:list nat), IN x l -> IN x (1%nat::l).
  zenon.
Print In.


Require Coq.extraction.Extraction.
Extraction Language OCaml.

Inductive term : Type :=
| Var : nat -> term
| Abs : term -> term
| App : term -> term -> term.

Notation beta_ShiftNum := 0.

Fixpoint shift (d c: nat) (t: term) : term :=
  match t with
  | Var k =>
    if Nat.leb c k then
      match d with
      | beta_ShiftNum => Var (k - 1)
      | _ => Var (k + d)
      end
    else Var k
  | Abs t1 => Abs (shift d (c + 1) t1)
  | App t1 t2 => App (shift d c t1) (shift d c t2)
  end.

Definition up (n: nat) (t: term) : term := shift n 0 t.

Compute ( up 2 (Abs (Abs (App (Var 1) (App (Var 0) (Var 2) ))))). (* = Abs (Abs (App (Var 1) (App (Var 0) (Var 4)))) *)
Compute ( up 2 (Abs (App (Var 0) (App (Var 1)(Abs (App (Var 0)(App (Var 1)(Var 2)))))))). (* = Abs (App (Var 0) (App (Var 3) (Abs (App (Var 0) (App (Var 1) (Var 4)))))) *)

Fixpoint subst (j: nat) (s t: term) : term :=
  match t with
  | Var k =>
    if Nat.eqb j k then s else Var k
  | Abs t1 =>
    Abs (subst (j + 1) (up 1 s) t1)
  | App t1 t2 =>
    App (subst j s t1) (subst j s t2)
  end.

Compute (subst 0 (Var 1) (App (Var 0) (Abs(Abs (Var 2))))).  (* = App (Var 1) (Abs (Abs (Var 3))) *)
Compute (subst 0 (App (Var 1) (Abs (Var 2))) (App (Var 0) (Abs (Var 1)))). (* = App (App (Var 1) (Abs (Var 2))) (Abs (App (Var 2) (Abs (Var 3)))) *)

Reserved Notation " t '-->' t' " (at level 40).

Inductive value : term -> Prop :=
  | v_abs : forall n,
      value (Abs n).

Notation "'[' x ':=' s ']' t" := (subst x s t) (at level 20).

Inductive eval : term -> term -> Prop :=
  | E_App1 : forall t1 t1' t2,
      t1 --> t1' ->
      App t1 t2 --> App t1' t2
  | E_App2 : forall v1 t2 t2',
      value v1 ->
      t2 --> t2' ->
      App v1 t2 --> App v1 t2'
  | E_AppAbs : forall t1 v2,
      value v2 ->
      App (Abs t1) v2 -->
          up beta_ShiftNum ([0 := up 1 (v2)] t1)

  where " t '-->' t' " := (eval t t').

Definition relation (X : Type) := X -> X -> Prop.

Inductive multi {X : Type} (R : relation X) : relation X :=
  | multi_refl : forall (x : X), multi R x x
  | multi_step : forall (x y z : X),
                    R x y ->
                    multi R y z ->
                    multi R x z.

Notation multieval := (multi eval).
Notation "t1 '-->*' t2" := (multieval t1 t2) (at level 40).

Definition vb (t: term) :=
  match t with
  | Abs _ => true
  | _ => false
  end.

Lemma vbValue : forall t,
    vb t = true <-> value t.
Proof.
  destruct t; split; intros; inversion H; auto.
  apply v_abs.
Qed.

Inductive optiont : Type :=
| Some (t: term)
| None.

Fixpoint step (t: term) : optiont :=
  match t with
  | App t1 t2 =>
    match t1 with
    | Abs t3 =>
      if vb t2 then
        Some (up beta_ShiftNum ([0 := up 1 (t2)] t3)) else
        match step t2 with
        | Some t2' => Some (App t1 t2')
        | None => None
        end
    | _ =>
      match step t1 with
      | Some t1' =>
        Some (App t1' t2)
      | None => None
      end
    end
  | _ => None
  end.
Extraction "ocaml/chap6/src/eval.ml" step.

Lemma stepeval : forall t t',
    t --> t' <-> step t = Some t'.
Proof.
  split; intros.
  -
    induction H.
    +
      simpl. destruct t1. inversion H. inversion H.
      rewrite IHeval. reflexivity.
    +
      simpl. inversion H; subst. destruct t2. inversion H0. inversion H0. rewrite IHeval. simpl. reflexivity.
    +
      inversion H; subst. simpl. reflexivity.
  -
    generalize dependent t'.
    induction t; intros. inversion H. inversion H.
    simpl in H.
    destruct t1. inversion H. destruct (vb t2) eqn:IH2. inversion H. apply E_AppAbs. apply vbValue; auto.
    destruct (step t2) eqn:IHH. inversion H.
    apply E_App2. apply v_abs. apply IHt2. reflexivity.
    inversion H.
    destruct (step (App t1_1 t1_2)). inversion H. apply E_App1. apply IHt1. reflexivity.
    inversion H.
Qed.

(*評価の一意性*)
Lemma determine : forall t t' t'',
    t --> t' -> t --> t'' -> t' = t''.
Proof.
  intros; generalize dependent t''. induction H; intros.
  -
    inversion H0; subst.
    apply IHeval in H4. rewrite H4; reflexivity.
    inversion H3; subst. inversion H.
    inversion H.
  -
    inversion H1; subst. inversion H; subst; inversion H5.
    apply IHeval in H6. rewrite H6; reflexivity.
    inversion H5; subst; inversion H0.
  -
    inversion H; inversion H0; subst.
    inversion H5. inversion H6.
    reflexivity.
Qed.

Fixpoint size (t: term) : nat :=
  match t with
  | Var _ => 1
  | Abs t1 => 1 + (size t1)
  | App t1 t2 => (size t1) + (size t2)
  end.

Fixpoint eqb_nat (n1 n2: nat) :=
  match n1 with
  | 0 =>
    match n2 with
    | 0 => true
    | _ => false
    end
  | S n1' =>
    match n2 with
    | 0 => false
    | S n2' => eqb_nat n1' n2'
    end
  end.

Lemma eqb_eq : forall n1 n2,
    eqb_nat n1 n2 = true <-> eq n1 n2.
Proof.
  split. generalize dependent n2.
  induction n1; induction n2; intros; auto. inversion H. inversion H.

  generalize dependent n2; induction n1; induction n2; intros; auto; simpl.
  inversion H. inversion H. apply IHn1. inversion H. auto.
Qed.

Fixpoint leb (n1 n2: nat) :=
  if eqb_nat n1 n2 then true else
    match n2 with
    | 0 => false
    | S n2' => leb n1 n2'
    end.

Fixpoint fv_card (t: term) (n: nat) :=
  match t with
  | Var n1 =>
    if leb n n1 then 1 else 0
  | Abs t1 =>
    fv_card (t1) (n + 1)
  | App t1 t2 =>
    (fv_card t1 n) + (fv_card t2 n)
  end.

Lemma leb_le : forall n1 n2,
    n1 <= n2 -> leb n1 n2 = true.
Proof.
  intros. induction H; simpl.
  -
    induction n1; auto. simpl.
    assert (eqb_nat n1 n1 = true). apply eqb_eq. auto.
    rewrite H. reflexivity.
  -
    destruct (eqb_nat n1 (S m)); auto.
Qed.

Lemma le_leb : forall n1 n2,
    leb n1 n2 = true -> n1 <= n2.
Proof.
  destruct n1; intros.
  apply le_0_n.
  induction n2. inversion H. inversion H.
  destruct (eqb_nat n1 n2) eqn: IH1. apply eqb_eq in IH1. rewrite IH1; auto.
  apply IHn2 in H1. apply le_S. apply H1.
Qed.

Lemma le_trance : forall n1 n2 n3,
    n1 <= n2 -> n2 <= n3 -> n1 <= n3.
Proof.
  intros. generalize dependent n3. induction H; intros; auto.
  destruct H0. apply IHle. apply le_S. apply le_n.
  apply IHle. apply le_S. apply le_S_n. apply le_S. apply H0.
Qed.

From Coq Require Import Strings.String.

Lemma fv_le : forall t n,
  fv_card t (n + 1) <= fv_card t n.
Proof.
  induction t; intros; simpl; auto.
  destruct (leb n0 n) eqn:IH1; destruct (leb (n0 + 1) n) eqn:IH2; auto.
  apply le_leb in IH2. rewrite PeanoNat.Nat.add_1_r in IH2. apply Le.le_Sn_le in IH2. apply leb_le in IH2. rewrite IH1 in IH2. inversion IH2.
  apply PeanoNat.Nat.add_le_mono; auto.
Qed.

Lemma e5_3_3 : forall t,
    fv_card t 0 <= (size (t)).
Proof.
  induction t; simpl; auto.
  -
    destruct (leb 0 n); auto.
  -
    apply le_trance with (fv_card t 0); auto. apply (fv_le t 0).
  -
    apply PeanoNat.Nat.add_le_mono; auto.
Qed.