Require Import SfLib.

(* Syntax of binary choice calculus with sharing and Selection.
   The object language is binary trees. *)
Section Syntax.

  Definition Dim := id.
  Definition Tag := bool.
  Definition Var := id.
  Definition L : Tag := true.
  Definition R : Tag := false.

  (* Choice calculus expressions. *)
  Inductive CC : Type :=
    | Leaf : nat -> CC
    | Node : nat -> CC -> CC -> CC
    | Decl : Dim -> CC -> CC
    | Chc  : Dim -> CC -> CC -> CC
    | Sel  : Dim -> Tag -> CC -> CC
    | Shr  : Var -> CC -> CC -> CC
    | Ref  : Var -> CC.

  (* Configuration types. *)
  Inductive CT : Type :=
    | Full : CT               (* Fully configured *)
    | Cons : Dec -> CT -> CT  (* Add a required decision *)
  with Dec : Type := Req : Dim -> CT -> CT -> Dec.

  (* The dimension associated with a decision. *)
  Definition decDim (dec:Dec) :=
    match dec with
      | Req d _ _ => d
    end.

  (* Sequence of two configuration types. *)
  Inductive Seq : CT -> CT -> CT -> Type :=
    | Seq_Full : forall r,
                 Seq Full r r
    | Seq_Cons : forall d l' r r',
                 Seq l' r r' ->
                 Seq (Cons d l') r (Cons d r').
  Hint Constructors Seq.

  Lemma Seq_Full_l : forall t, Seq Full t t.
  Proof. induction t; apply Seq_Full. Qed.

  Lemma Seq_Full_r : forall t, Seq t Full t.
  Proof.
    induction t as [| d t iH].
      apply Seq_Full.
      apply Seq_Cons. apply iH.
  Qed.

  Tactic Notation "CC_cases" tactic(first) ident(c) := first;
    [ Case_aux c "Leaf" | Case_aux c "Node"
    | Case_aux c "Decl" | Case_aux c "Chc"
    | Case_aux c "Sel"
    | Case_aux c "Shr"  | Case_aux c "Ref" ].
  Tactic Notation "CT_cases" tactic(first) ident(c) := first;
    [ Case_aux c "Full" | Case_aux c "Cons"  ].

End Syntax.

(* Type system for choice calculus expressions. *)
Section TypeSystem.

  (* Dimension environment D: Dim -> Tag. *)
  Definition denv := partial_map Tag.

  (* Typing environment G: Var -> CT. *)
  Definition tenv := partial_map CT.

  (* Configuration typing rules *)
  Inductive hasType (D:denv) (G:tenv) : CC -> CT -> Prop :=
    | CT_Leaf : forall a,
                hasType D G (Leaf a) Full
    | CT_Node : forall a l r Tl Tr T,
                Seq Tl Tr T ->
                hasType D G l Tl ->
                hasType D G r Tr ->
                hasType D G (Node a l r) T
    | CT_Decl : forall d e Tl Tr,
                hasType (extend D d L) G e Tl ->
                hasType (extend D d R) G e Tr ->
                hasType D G (Decl d e) (Cons (Req d Tl Tr) Full)
    | CT_ChcL : forall d l r T,
                D d = Some L ->
                hasType D G l T ->
                hasType D G (Chc d l r) T
    | CT_ChcR : forall d l r T,
                D d = Some R ->
                hasType D G r T ->
                hasType D G (Chc d l r) T
    | CT_Sel  : forall d t e dec T,
                not (d = decDim dec) ->
                hasType D G (Sel d t e) T ->
                hasType D G (Sel d t e) (Cons dec T)
    | CT_SelL : forall d e Tl Tr Tt T,
                Seq Tl Tt T ->
                hasType D G e (Cons (Req d Tl Tr) Tt) ->
                hasType D G (Sel d L e) T
    | CT_SelR : forall d e Tl Tr Tt T,
                Seq Tr Tt T ->
                hasType D G e (Cons (Req d Tl Tr) Tt) ->
                hasType D G (Sel d R e) T
    | CT_Shr  : forall v e' e T' T,
                hasType D G e' T' ->
                hasType D (extend G v T') e T ->
                hasType D G (Shr v e' e) T
    | CT_Ref  : forall v T,
                G v = Some T ->
                hasType D G (Ref v) T.

  (* A well-formed expression is typable in an empty enivoronment. *)
  Definition wellFormed (e:CC) : Prop :=
    exists T, hasType empty empty e T.

  (* An expression is fully configured in some enivornment if its
     configuration type is Full. *)
  Definition fullConfig (D:denv) (G:tenv) (e:CC) : Prop :=
    hasType D G e Full.

  (* An expression is singular if it is fully configured in an
     empty environment. *)
  Definition singular (e:CC) : Prop :=
    hasType empty empty e Full.

  Tactic Notation "hasType_cases" tactic(first) ident(c) := first;
    [ Case_aux c "CT_Leaf" | Case_aux c "CT_Node"
    | Case_aux c "CT_Decl" | Case_aux c "CT_ChcL" | Case_aux c "CT_ChcR"
    | Case_aux c "CT_Sel"  | Case_aux c "CT_SelL" | Case_aux c "CT_SelR"
    | Case_aux c "CT_Shr"  | Case_aux c "CT_Ref"  ].
  Hint Constructors hasType.

End TypeSystem.

Section Examples.

  Definition A := (Id 0). Hint Unfold A.
  Definition B := (Id 1). Hint Unfold B.
  Definition v := (Id 0). Hint Unfold v.
  Definition w := (Id 1). Hint Unfold w.

  Definition e1 := Decl A (Chc A (Leaf 1) (Leaf 2)).
  Definition t1 := Cons (Req A Full Full) Full.

  Lemma e1_hasType_t1 : hasType empty empty e1 t1.
  Proof.
    apply CT_Decl.
      apply CT_ChcL. auto. apply CT_Leaf.
      apply CT_ChcR. auto. apply CT_Leaf.
  Qed.

  Lemma e1_is_wellFormed : wellFormed e1.
  Proof.
    unfold wellFormed.
    exists t1. apply e1_hasType_t1.
  Qed.

  Definition e2 := Shr v e1 (Node 0 (Sel A L (Ref v)) (Sel A R (Ref v))).
  Definition t2 := Full.

  Lemma e2_hasType_t2 : hasType empty empty e2 t2.
  Proof.
    unfold e2. unfold t2.
    apply CT_Shr with t1. apply e1_hasType_t1.
    apply CT_Node with Full Full. apply Seq_Full.
      apply CT_SelL with Full Full Full. apply Seq_Full.
        apply CT_Ref. auto.
      apply CT_SelR with Full Full Full. apply Seq_Full.
        apply CT_Ref. auto.
  Qed.

  Lemma e2_is_singular : singular e2.
  Proof.
    unfold singular.
    apply e2_hasType_t2.
  Qed.

  Definition e3 := Shr v e1 (Sel A L (Node 0 (Leaf 3) (Node 4 (Ref v) (Ref v)))).
  Definition t3 := Cons (Req A Full Full) Full.

  Lemma e3_hasType_t3 : hasType empty empty e3 t3.
  Proof.
    unfold e3. unfold t3.
    apply CT_Shr with t1. apply e1_hasType_t1.
    apply CT_SelL with Full Full t1. apply Seq_Full.
    apply CT_Node with Full (Cons (Req A Full Full) t1). apply Seq_Full.
      apply CT_Leaf.
      apply CT_Node with t1 t1. apply Seq_Cons. apply Seq_Full.
        apply CT_Ref. auto.
        apply CT_Ref. auto.
  Qed.

  (*
  Definition e4 := Shr v e1 (Sel A L (Node 0 (Decl B (Chc B (Leaf 3) (Leaf 4))) (Ref v))).
  Definition t4 := Cons (Req B Full Full) Full.

  Lemma e4_hasType_t4 : hasType empty empty e4 t4.
  Proof.
    unfold e4. unfold t4.
    apply CT_Shr with t1. apply e1_hasType_t1.
    apply CT_Sel. apply beq_id_false_not_eq. auto.
    apply CT_SelL with Full Full t1. apply Seq_Full.
  *)

End Examples.


Require Export Str.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Inductive Reg : Σ -> Prop :=
    | reg0 : Reg ∅
    | regnil : Reg [set nil : finStr]
    | rega (a : symbol) :  Reg [set ([:: a] : finStr)]
    | regU X Y : Reg X -> Reg Y -> Reg (X ∪ Y)
    | regA X Y : Reg X -> Reg Y -> Reg (X ⋅ Y)
    | regK X : Reg X -> Reg (X ^*).

Record reg : Type := mkReg {
    str :> Σ;
    axiom :  Reg str
}.

Lemma cat1A (x y : finStr) :
    [set x ++ y : finStr] = [set x] ⋅ [set y].
Proof.
    apply extension; apply /subsetP => a.
    move /set1P ->; apply /setAP; exists x, y;
        repeat split;apply /set1P => //.
    move /setAP => [x0 [y0 [/set1P Hx0 [/set1P Hy0 Ha]]]];
        subst; apply /set1P => //.
Qed.

Lemma reg1 a : Reg [set a].
Proof.
    induction a; first constructor.
    suff : a :: a0 = [::a] ++ a0.
        move ->.
        rewrite cat1A; constructor => //; constructor.
    induction a0 => //.
Qed.

Lemma regI : forall (R S : Σ),
    Reg R -> Reg S -> Reg (R ∩ S).
Proof.
    move => R S HR HS.
    move : S HS => /=.
    rewrite -(set_enum R).
    induction (enum R) => S HS.
    +   rewrite -enum_set0.
        rewrite (set_enum ∅).
        rewrite set0I; constructor.
    +   rewrite set_cons setIUl; constructor; first last.
        apply IHl => //.
        remember (a ∈ S).
        destruct b.
        -   suff : [set a] ∩ S = [set a].
                move ->; apply reg1.
            apply extension; apply /subsetP => x.
            *   case /setIP => //.
            *   move /set1P ->; apply /setIP; split => //; apply /set1P => //.
        -   suff : [set a] ∩ S = ∅.
                move ->; constructor.
            apply extension; apply /subsetP => x.
            *   case /setIP; move /set1P ->; rewrite -Heqb => //.
            *   rewrite (in_set0 x) => //.
Qed.

Lemma regD (R S : Σ) :
    Reg R -> Reg S -> Reg (R // S).
Proof.
    move => HR HS; move : S HS.
    rewrite -(set_enum R).
    induction (enum R) => S HS.
    +   rewrite -enum_set0.
        rewrite (set_enum ∅).
        rewrite set0D; constructor.
    +   rewrite set_cons setDUl; constructor.
        -   remember (a ∈ S).
            destruct b.
            *   suff : [set a] // S = ∅.
                    move ->; constructor.
                apply extension; apply /subsetP => x.
                +   case /setDP.
                    move /set1P ->.
                    rewrite -Heqb => //.
                +   rewrite (in_set0) => //.
            *   have : [set a] // S = [set a].
                    apply extension; apply /subsetP => b.
                    +   case /setDP; move /set1P -> => _; apply /set1P => //.
                    +   move /set1P ->; apply /setDP; split.
                        -   apply /set1P => //.
                        -   rewrite -Heqb => //.
                move ->; apply reg1.
        -   apply IHl => //.
Qed.

Lemma regT : Reg setT.
Proof.
    rewrite -(set_enum setT).
    induction (enum setT).
    +   rewrite -enum_set0.
        rewrite (set_enum ∅).
        constructor.
    +   rewrite set_cons; constructor => //.
        apply reg1.
Qed.

Lemma regTD R : Reg R -> Reg (setT // R).
Proof.
    move => H; apply regD => //; apply regT.
Qed.

Lemma regC R : Reg R -> Reg (¬ R).
Proof.
    rewrite -setTD; apply regTD.
Qed.

Lemma regE R n :  Reg R -> Reg (R^n).
Proof.
    induction n => /= H.
    +   apply reg1.
    +   constructor => //; apply IHn => //.
Qed.

Lemma regK' R : Reg R -> Reg (R^+).
Proof.
    move => H.
    apply regD.
    +   by apply regK.
    +   by apply reg1.
Qed.


Require Import init.

Require Import set.
Require Import unordered_list.

Require Import module_category.
Require Import algebra_category.
Require Import linear_bilinear_form.

Require Export geometric_construct.
Require Export exterior_construct.
Require Export exterior_to_geometric.
Require Export geometric_to_exterior.

(* begin hide *)
Section GeometricExteriorIso.

(* end hide *)
Context {F : CRingObj} {V : ModuleObj F}.
(* begin hide *)

Let UP := cring_plus F.
Let UZ := cring_zero F.
Let UN := cring_neg F.
Let UPC := cring_plus_comm F.
Let UPZ := cring_plus_lid F.
Let UPN := cring_plus_linv F.
Let UM := cring_mult F.
Let UO := cring_one F.
Let UMC := cring_mult_comm F.

Existing Instances UP UZ UN UPC UPZ UPN UM UO UMC.

Let VP := module_plus V.
Let VS := module_scalar V.

Existing Instances VP VS.

(* end hide *)
Context (B : set_type bilinear_form).

(* begin hide *)
Let EP := ext_plus V.
Let EZ := ext_zero V.
Let EN := ext_neg V.
Let EPA := ext_plus_assoc V.
Let EPC := ext_plus_comm V.
Let EPZ := ext_plus_lid V.
Let EPN := ext_plus_linv V.
Let EM := ext_mult V.
Let EL := ext_ldist V.
Let ER := ext_rdist V.
Let EO := ext_one V.
Let EMA := ext_mult_assoc V.
Let ES := ext_scalar V.
Let ESL := ext_scalar_ldist V.
Let ESR := ext_scalar_rdist V.

Existing Instances EP EZ EN EPA EPC EPZ EPN EM EL ER EO EMA ES ESL ESR.

Let GP := geo_plus B.
Let GZ := geo_zero B.
Let GN := geo_neg B.
Let GPA := geo_plus_assoc B.
Let GPC := geo_plus_comm B.
Let GPZ := geo_plus_lid B.
Let GPN := geo_plus_linv B.
Let GM := geo_mult B.
Let GL := geo_ldist B.
Let GR := geo_rdist B.
Let GS := geo_scalar B.
Let GSL := geo_scalar_ldist B.
Let GSC := geo_scalar_comp B.
Let GSMR := geo_scalar_rmult B.

Existing Instances GP GZ GN GPA GPC GPZ GPN GM GL GR GS GSL GSC GSMR.

(* end hide *)
Lemma ext_inner_inner : ∀ a b (x : ext V),
    ext_inner B a (ext_inner B b x) + ext_inner B b (ext_inner B a x) = 0.
Proof.
    intros a b x.
    symmetry; apply plus_0_ab_a_nb.
    pose proof (ext_sum V x) as [l l_eq]; subst x.
    induction l as [|[α x] l] using ulist_induction.
    {
        rewrite ulist_image_end, ulist_sum_end.
        do 4 rewrite ext_inner_rzero.
        symmetry; apply neg_zero.
    }
    rewrite ulist_image_add, ulist_sum_add; cbn.
    do 4 rewrite ext_inner_rplus.
    rewrite IHl; clear IHl.
    rewrite neg_plus.
    apply rplus; clear l.
    do 4 rewrite ext_inner_rscalar.
    rewrite <- scalar_rneg.
    apply f_equal.
    induction x as [|u l].
    {
        rewrite list_image_end; cbn.
        rewrite list_prod_end.
        rewrite <- scalar_to_ext_one.
        do 2 rewrite ext_inner_scalar.
        do 2 rewrite ext_inner_rzero.
        symmetry; apply neg_zero.
    }
    rewrite list_image_add; cbn.
    do 2 rewrite ext_inner_add.
    do 2 rewrite ext_inner_rplus.
    rewrite neg_plus.
    do 2 rewrite ext_inner_rneg.
    rewrite neg_neg.
    do 2 rewrite ext_inner_add.
    rewrite IHl; clear IHl.
    rewrite mult_rneg.
    rewrite neg_neg.
    rewrite neg_plus.
    do 2 rewrite plus_assoc.
    apply rplus.
    do 2 rewrite ext_inner_rscalar.
    apply plus_comm.
Qed.

Lemma geo_mult_inner_inner : ∀ a b (x : geo B),
    geo_mult_inner B a (geo_mult_inner B b x) +
    geo_mult_inner B b (geo_mult_inner B a x) = 0.
Proof.
    intros a b x.
    symmetry; apply plus_0_ab_a_nb.
    pose proof (geo_sum B x) as [l l_eq]; subst x.
    induction l as [|[α x] l] using ulist_induction.
    {
        rewrite ulist_image_end, ulist_sum_end.
        do 4 rewrite geo_mult_inner_rzero.
        symmetry; apply neg_zero.
    }
    rewrite ulist_image_add, ulist_sum_add; cbn.
    do 4 rewrite geo_mult_inner_rplus.
    rewrite IHl; clear IHl.
    rewrite neg_plus.
    apply rplus; clear l.
    do 4 rewrite geo_mult_inner_rscalar.
    rewrite <- scalar_rneg.
    apply f_equal.
    induction x as [|u l].
    {
        rewrite list_image_end; cbn.
        rewrite list_prod_end.
        rewrite <- scalar_to_geo_one.
        do 2 rewrite geo_mult_inner_scalar.
        do 2 rewrite geo_mult_inner_rzero.
        symmetry; apply neg_zero.
    }
    rewrite list_image_add; cbn.
    do 2 rewrite geo_mult_inner_add.
    do 2 rewrite geo_mult_inner_rplus.
    rewrite neg_plus.
    do 2 rewrite geo_mult_inner_rneg.
    rewrite neg_neg.
    do 2 rewrite geo_mult_inner_add.
    rewrite IHl; clear IHl.
    rewrite mult_rneg.
    rewrite neg_neg.
    rewrite neg_plus.
    do 2 rewrite plus_assoc.
    apply rplus.
    do 2 rewrite geo_mult_inner_rscalar.
    apply plus_comm.
Qed.

Lemma geo_to_ext_inner : ∀ a (x : geo B),
    geo_to_ext B (geo_mult_inner B a x) = ext_inner B a (geo_to_ext B x).
Proof.
    intros a x.
    pose proof (geo_sum B x) as [l l_eq]; subst x.
    induction l as [|[α x] l] using ulist_induction.
    {
        rewrite ulist_image_end, ulist_sum_end.
        rewrite geo_mult_inner_rzero.
        do 2 rewrite geo_to_ext_zero.
        symmetry; apply ext_inner_rzero.
    }
    rewrite ulist_image_add, ulist_sum_add; cbn.
    rewrite geo_mult_inner_rplus.
    do 2 rewrite geo_to_ext_plus.
    rewrite ext_inner_rplus.
    rewrite IHl; clear IHl.
    apply rplus.
    rewrite geo_mult_inner_rscalar.
    do 2 rewrite geo_to_ext_scalar.
    rewrite ext_inner_rscalar.
    apply f_equal.
    clear α l.
    induction x as [|b l].
    {
        rewrite list_image_end; cbn.
        rewrite list_prod_end.
        rewrite <- scalar_to_geo_one.
        rewrite geo_to_ext_of_scalar.
        rewrite geo_mult_inner_scalar.
        rewrite ext_inner_scalar.
        apply geo_to_ext_zero.
    }
    rewrite list_image_add; cbn.
    rewrite geo_mult_inner_add.
    rewrite geo_to_ext_add.
    rewrite geo_to_ext_plus, geo_to_ext_neg.
    rewrite ext_inner_rplus.
    rewrite geo_to_ext_add.
    rewrite IHl; clear IHl.
    rewrite ext_inner_add.
    rewrite neg_plus.
    do 2 rewrite plus_assoc.
    apply rplus.
    rewrite geo_to_ext_scalar.
    rewrite plus_comm.
    apply rplus.
    apply plus_0_ab_na_b.
    symmetry; apply ext_inner_inner.
Qed.

Lemma ext_to_geo_inner : ∀ a (x : ext V),
    ext_to_geo B (ext_inner B a x) = geo_mult_inner B a (ext_to_geo B x).
Proof.
    intros a x.
    pose proof (ext_sum V x) as [l l_eq]; subst x.
    induction l as [|[α x] l] using ulist_induction.
    {
        rewrite ulist_image_end, ulist_sum_end.
        rewrite ext_inner_rzero.
        do 2 rewrite ext_to_geo_zero.
        symmetry; apply geo_mult_inner_rzero.
    }
    rewrite ulist_image_add, ulist_sum_add; cbn.
    rewrite ext_inner_rplus.
    do 2 rewrite ext_to_geo_plus.
    rewrite geo_mult_inner_rplus.
    rewrite IHl; clear IHl.
    apply rplus.
    rewrite ext_inner_rscalar.
    do 2 rewrite ext_to_geo_scalar.
    rewrite geo_mult_inner_rscalar.
    apply f_equal.
    clear α l.
    induction x as [|b l].
    {
        rewrite list_image_end; cbn.
        rewrite list_prod_end.
        rewrite <- scalar_to_ext_one.
        rewrite ext_to_geo_of_scalar.
        rewrite ext_inner_scalar.
        rewrite geo_mult_inner_scalar.
        apply ext_to_geo_zero.
    }
    rewrite list_image_add; cbn.
    rewrite ext_inner_add.
    rewrite ext_to_geo_add.
    rewrite ext_to_geo_plus, ext_to_geo_neg.
    rewrite geo_mult_inner_rplus.
    rewrite ext_to_geo_add.
    rewrite IHl; clear IHl.
    rewrite geo_mult_inner_add.
    rewrite neg_plus.
    do 2 rewrite plus_assoc.
    apply rplus.
    rewrite ext_to_geo_scalar.
    rewrite plus_comm.
    apply rplus.
    rewrite neg_neg.
    rewrite geo_mult_inner_rneg.
    apply plus_0_ab_a_nb.
    symmetry; apply geo_mult_inner_inner.
Qed.

Theorem geo_to_ext_to_geo : ∀ x, geo_to_ext B (ext_to_geo B x) = x.
Proof.
    intros x.
    pose proof (ext_sum V x) as [l l_eq]; subst x.
    induction l as [|[α x] l] using ulist_induction.
    {
        rewrite ulist_image_end, ulist_sum_end.
        rewrite ext_to_geo_zero.
        apply geo_to_ext_zero.
    }
    rewrite ulist_image_add, ulist_sum_add; cbn.
    rewrite (ext_to_geo_plus B).
    rewrite (geo_to_ext_plus B).
    rewrite IHl; clear IHl.
    apply rplus; clear l.
    rewrite (ext_to_geo_scalar B).
    rewrite (geo_to_ext_scalar B).
    apply f_equal.
    induction x as [|a l].
    {
        rewrite list_image_end; cbn.
        rewrite list_prod_end.
        replace (ext_to_geo B 1) with (@one _ (geo_one B))
            by (symmetry; apply (ext_to_geo_one B)).
        apply geo_to_ext_one.
    }
    rewrite list_image_add; cbn.
    rewrite ext_to_geo_add.
    rewrite (geo_to_ext_plus B).
    rewrite geo_to_ext_add.
    rewrite IHl.
    rewrite (geo_to_ext_neg B).
    rewrite plus_assoc.
    apply plus_0_a_ab_b.
    rewrite plus_0_nab_a_b.
    rewrite geo_to_ext_inner.
    rewrite IHl.
    reflexivity.
Qed.

Theorem ext_to_geo_to_ext : ∀ x, ext_to_geo B (geo_to_ext B x) = x.
Proof.
    intros x.
    pose proof (geo_sum B x) as [l l_eq]; subst x.
    induction l as [|[α x] l] using ulist_induction.
    {
        rewrite ulist_image_end, ulist_sum_end.
        rewrite geo_to_ext_zero.
        apply ext_to_geo_zero.
    }
    rewrite ulist_image_add, ulist_sum_add; cbn.
    rewrite geo_to_ext_plus.
    rewrite ext_to_geo_plus.
    rewrite IHl; clear IHl.
    apply rplus; clear l.
    rewrite geo_to_ext_scalar.
    rewrite ext_to_geo_scalar.
    apply f_equal.
    induction x as [|a l].
    {
        rewrite list_image_end; cbn.
        rewrite list_prod_end.
        rewrite geo_to_ext_one.
        apply ext_to_geo_one.
    }
    rewrite list_image_add; cbn.
    rewrite geo_to_ext_add.
    rewrite (ext_to_geo_plus B).
    rewrite ext_to_geo_add.
    rewrite IHl.
    rewrite plus_assoc.
    apply plus_0_a_ab_b.
    rewrite ext_to_geo_inner.
    rewrite IHl.
    rewrite plus_rinv.
    reflexivity.
Qed.

Definition ext_to_geo_homo := make_module_homomorphism
    F
    (algebra_module (exterior_algebra V))
    (algebra_module (geometric_algebra B))
    (ext_to_geo B)
    (ext_to_geo_plus B)
    (ext_to_geo_scalar B) : cat_morphism (MODULE F) _ _.

Definition geo_to_ext_homo := make_module_homomorphism
    F
    (algebra_module (geometric_algebra B))
    (algebra_module (exterior_algebra V))
    (geo_to_ext B)
    (geo_to_ext_plus B)
    (geo_to_ext_scalar B) : cat_morphism (MODULE F) _ _.

Theorem ext_to_geo_to_ext_homo : ext_to_geo_homo ∘ geo_to_ext_homo = 𝟙.
Proof.
    apply module_homomorphism_eq.
    intros x.
    cbn.
    apply ext_to_geo_to_ext.
Qed.
Theorem geo_to_ext_to_geo_homo : geo_to_ext_homo ∘ ext_to_geo_homo = 𝟙.
Proof.
    apply module_homomorphism_eq.
    intros x.
    cbn.
    apply geo_to_ext_to_geo.
Qed.

Theorem ext_to_geo_iso : isomorphism ext_to_geo_homo.
Proof.
    exists geo_to_ext_homo.
    split.
    -   exact ext_to_geo_to_ext_homo.
    -   exact geo_to_ext_to_geo_homo.
Qed.
Theorem geo_to_ext_iso : isomorphism geo_to_ext_homo.
Proof.
    exists ext_to_geo_homo.
    split.
    -   exact geo_to_ext_to_geo_homo.
    -   exact ext_to_geo_to_ext_homo.
Qed.

Theorem geo_ext_iso : isomorphic (C0 := MODULE F)
    (algebra_module (geometric_algebra B))
    (algebra_module (exterior_algebra V)).
Proof.
    exists geo_to_ext_homo.
    exact geo_to_ext_iso.
Qed.

Theorem scalar_to_geo_eq : ∀ a b, scalar_to_geo B a = scalar_to_geo B b → a = b.
Proof.
    intros a b eq.
    apply (f_equal (geo_to_ext B)) in eq.
    do 2 rewrite geo_to_ext_of_scalar in eq.
    apply scalar_to_ext_eq in eq.
    exact eq.
Qed.

Theorem vector_to_geo_eq : ∀ a b, vector_to_geo B a = vector_to_geo B b → a = b.
Proof.
    intros a b eq.
    apply (f_equal (geo_to_ext B)) in eq.
    do 2 rewrite geo_to_ext_vector in eq.
    apply vector_to_ext_eq in eq.
    exact eq.
Qed.
(* begin hide *)

End GeometricExteriorIso.
(* end hide *)


Require Export Reals Psatz Fourier.
From discprob.basic Require Export exp_ext.
From discprob.prob Require Export prob countable stochastic_order markov indep bernoulli.
From mathcomp Require Import ssreflect ssrbool ssrfun eqtype choice fintype bigop.
From Coquelicot Require Import Derive Continuity.
From Coquelicot Require AutoDerive.
From Interval Require Import Tactic.

(* See Chapter 4 of Mitzenmacher-Upfal, 2nd edition. *)

Lemma generic_chernoff_upper {A} {Ω: distrib A} (X: rrvar Ω) t a:
  t > 0 →
  ex_Ex (rvar_comp X (λ x, exp (t * x))) →
  pr_ge X a <= Ex (rvar_comp X (λ x, exp (t * x))) / (exp (t * a)).
Proof.
  intros Ht Hex.
  transitivity (pr_ge (rvar_comp X (λ x, exp (t * x))) (exp (t * a))).
  - right. apply pr_eq_pred' => x.
    destruct (Rge_dec) as [Hge|Hnge] => //=.
    * apply Rgt_lt in Ht.
      apply Rge_le in Hge.
      apply (Rmult_le_compat_l t) in Hge; last by nra.
      apply exp_increasing_le in Hge.
      destruct (Rge_dec) as [?|Hnge'] => //=.
      exfalso; apply Hnge'. by apply Rle_ge.
    * destruct (Rge_dec) as [Hge|Hnge'] => //=.
      exfalso. apply Hnge.
      apply Rge_le, exp_le_embedding in Hge.
      apply Rmult_le_reg_l in Hge;  auto.
  - apply markov => //=.
    * intros. apply Rle_ge; left; apply exp_pos.
    * intros. apply Rlt_gt; apply exp_pos.
Qed.

Local Open Scope R_scope.

Lemma chernoff_bernoulli_upper {A} {Ω: distrib A} (lX: list (rrvar Ω)) δ:
  (∀ X, In X lX → ∃ p, is_bernoulli X p) →
  independent lX →
  δ > 0 →
  pr_ge (sum_list_rrvar lX) ((1 + δ) * Ex (sum_list_rrvar lX))
    <= Rpower (exp(δ) / (Rpower (1 + δ) (1 + δ))) (Ex (sum_list_rrvar lX)).
Proof.
  intros Hbern Hindep Hdelta_pos.
  assert (Hext: ∀ a : A,
             (prod_list_rrvar (map (rvar_comp^~ (λ x : R_eqType, exp (ln (1 + δ) * x))) lX)) a =
             (rvar_comp (sum_list_rrvar lX) (λ x : [eqType of R], exp (ln (1 + δ) * x))) a).
  {
    * intros a => //=. induction lX.
      ** rewrite //=. by rewrite Rmult_0_r exp_0.
      ** rewrite //=. rewrite Rmult_plus_distr_l exp_plus. f_equal.
         eapply IHlX.
         *** intros.  eapply Hbern. by right.
         *** eapply independent_tl. eauto.
  }

  assert (Hex_Ex_prod:
            ex_Ex (prod_list_rrvar (map (rvar_comp^~ (λ x : R_eqType, exp (ln (1 + δ) * x))) lX))).
  {
    * apply ex_Ex_indep_prod_list.
      ** by apply indep_fn.
      ** intros ? (X&Heq&Hin)%in_map_iff.
         rewrite -Heq. edestruct (Hbern _ Hin) as (p&His_bern).
         eapply is_bernoulli_ex_Ex; eauto.
  }

  assert (Hpow_pos: 0 < Rpower (1 + δ) (1 + δ)).
  { rewrite /Rpower. apply exp_pos. }

  etransitivity; first eapply generic_chernoff_upper with (t := ln (1 + δ)).
  - rewrite -ln_1. apply Rlt_gt. apply ln_increasing; nra.
  - apply (ex_Ex_ext (prod_list_rrvar (map (λ X, rvar_comp X (λ x, exp (ln (1 + δ) * x))) lX )));
      eauto.
  - rewrite -(Ex_ext _ _ _ Hext) //. rewrite Ex_sum_list; last first.
    { intros ? Hin. edestruct (Hbern _ Hin) as (p&?); eapply is_bernoulli_ex_Ex with (f := id).
      eauto. }
    rewrite Ex_indep_prod_list.
    *
      rewrite /Rdiv -Rpower_mult_distr.
      assert (Hpow_opp': ∀ x y, 0 < x → Rpower (/ x) y = / Rpower x y).
      {
        intros x y.
        rewrite -Rpower_Ropp.
        rewrite /Rpower.
        intros; rewrite ln_Rinv //.
        f_equal. nra.
      }
      rewrite Hpow_opp'.
      rewrite /Rpower.
      assert (exp (ln (1 + δ) * ((1 + δ) * fold_right Rplus 0 (seq.map Ex lX))) =
              exp (fold_right Rplus 0 (seq.map Ex lX) * ln (exp ((1 + δ) * ln (1 + δ)))))
        as ->.
      {
        f_equal. rewrite ln_exp. nra.
      }
      apply Rmult_le_compat_r.
      ** left. apply Rinv_0_lt_compat, exp_pos.
      ** rewrite /Rpower. rewrite fold_right_plus_mult exp_fold_plus.
         rewrite ?seq_ext.map_legacy ?map_map => //=.
         apply fold_right_map_Rmult_le => X Hin.
         destruct (Hbern X Hin) as (p&HXbern).
         rewrite (EGF_is_bernoulli _ p HXbern (ln (1 + δ))).
         rewrite (Ex_is_bernoulli _ p HXbern).
         rewrite exp_ln; last by nra.
         destruct (is_bernoulli_range _ _ HXbern) as (?&?).
         split.
         *** nra.
         *** ring_simplify.
             rewrite ln_exp. rewrite Rplus_comm. apply exp_ineq1_le. nra.
      ** auto.
      ** apply exp_pos.
      ** by apply Rinv_0_lt_compat.
    * by apply indep_fn.
    * intros ? (X&Heq&Hin)%in_map_iff.
      rewrite -Heq. destruct (Hbern _ Hin) as (p&HXbern).
      eapply is_bernoulli_ex_Ex; eauto.
Qed.

Lemma Ex_sum_bernoulli_non_neg {A} {Ω: distrib A} (lX : list (rrvar Ω)):
  (∀ X, In X lX → ∃ p, is_bernoulli X p) →
  0 <= Ex (sum_list_rrvar lX).
Proof.
  intros Hbern. rewrite Ex_sum_list.
  - induction lX as [| X lX]=> //=; first reflexivity.
    destruct (Hbern X) as (p&HXbern); first by left.
    rewrite (Ex_is_bernoulli _ _ HXbern).
    destruct (is_bernoulli_range _ _ HXbern) as (?&?).
    rewrite -[a in a <= _]Rplus_0_r. apply Rplus_le_compat; auto.
    eapply IHlX. intros. apply Hbern. by right.
  - intros X Hin.
    destruct (Hbern X) as (p&HXbern); auto.
    eapply is_bernoulli_ex_Ex with (f := id); eauto.
Qed.

Lemma non_decr_function_le: ∀ (f : R → R) (a b : Rbar) (df : R → R),
       (∀ x : R, Rbar_le a x → Rbar_le x b → is_derive f x (df x))
       → (∀ x : R, Rbar_le a x → Rbar_le x b → df x >= 0)
         → ∀ x y : R, Rbar_le a x → x <= y → Rbar_le y b → f x <= f y.
Proof.
  intros f a b df Hderiv Hderiv_non_neg x y Hrange1 Hrange2 Hrange3.
  edestruct (MVT_gen f x y) as (c&(Hrange1'&Hrange2')&Heq).
  - intros x'. rewrite Rmin_left //= Rmax_right //=. intros [? ?]. eapply Hderiv.
    * eapply Rbar_le_trans; eauto. by rewrite /Rbar_le; left.
    * eapply Rbar_le_trans; eauto. by rewrite /Rbar_le; left.
  - intros x'. rewrite Rmin_left //= Rmax_right //=. intros [? ?].
    assert (continuous f x').
    apply: ex_derive_continuous; eauto.
    econstructor. eapply Hderiv; eauto.
    * eapply Rbar_le_trans; eauto.
    * eapply Rbar_le_trans; eauto. rewrite /Rbar_le; auto.
    * by apply continuity_pt_filterlim.
  - rewrite //= in Heq.
    assert (df c >= 0).
    { apply Hderiv_non_neg.
      * rewrite Rmin_left in Hrange1'; auto. eapply Rbar_le_trans; eauto.
      * rewrite Rmax_right in Hrange2'; auto. eapply Rbar_le_trans; eauto.
        rewrite /Rbar_le //=.
    }
    nra.
Qed.

Lemma chernoff_bernoulli_upper_alt {A} {Ω: distrib A} (lX: list (rrvar Ω)) δ:
  (∀ X, In X lX → ∃ p, is_bernoulli X p) →
  independent lX →
  0 < δ <= 1 →
  pr_ge (sum_list_rrvar lX) ((1 + δ) * Ex (sum_list_rrvar lX))
    <= exp (- Ex (sum_list_rrvar (lX)) * δ^2 / 3).
Proof.
  intros Hbern Hindep Hdelta.
  etransitivity; first eapply chernoff_bernoulli_upper; eauto; try nra; [].
  rewrite /Rpower.
  apply exp_increasing_le.
  rewrite ln_div ?ln_exp.
  - cut (0 <= - (δ - (1 + δ) * ln (1 + δ) + δ^2 / 3) ).
    { intros. specialize (Ex_sum_bernoulli_non_neg _ Hbern) => ?; nra. }
    set (f := λ δ, - (δ - (1 + δ) * ln (1 + δ) + δ^2 / 3)).
    rewrite -/(f δ). transitivity (f 0).
    * right. rewrite /f ?Rplus_0_r ln_1. nra.
    * set (f' := λ δ, - (1 - (1 + δ) / (1 + δ) - ln (1 + δ) + (2 / 3) * δ)).
      set (f'' := λ δ, - (- 1 / (1 + δ) + (2 / 3))).
      apply non_decr_function_le with (a := 0) (b := δ) (df := f').
      ** rewrite /Rbar_le //=. intros x Hr1 Hr2. rewrite /f/f'. AutoDerive.auto_derive; nra.
      ** rewrite /Rbar_le //=. intros x Hr1 Hr2.
         apply Rle_ge.
         assert (x < 1/2 ∨ x = 1/2 ∨ 1/2 < x) as [Hlt|[Heq|Hgt]] by nra.
         {
           transitivity (f' 0).
             { right. rewrite /f'. rewrite Rplus_0_r ln_1. field. }
             apply non_decr_function_le with (a := 0) (b := x) (df := f'').
           *** rewrite /Rbar_le //=. intros x' ??; rewrite /f'/f''. AutoDerive.auto_derive.
               **** repeat split; auto; try nra.
               **** field. nra.
           *** rewrite /Rbar_le //=. intros x' ??; rewrite /f'/f''.
               field_simplify; last by nra.
               apply Rle_ge. replace (0 / 1) with 0 by nra.
               apply Rdiv_le_0_compat; nra.
           *** rewrite //=. reflexivity.
           *** nra.
           *** rewrite //=. reflexivity.
         }
         { rewrite /f'. subst. interval. }
         {
           transitivity (f' 1).
           { rewrite /f'. interval. }
           cut (- f' x <= - f' 1); first by (intros; nra).
           apply non_decr_function_le with (f := λ x, - f' x) (a := 1/2) (b := 3/2) (df := λ x, - f'' x).
           *** rewrite /Rbar_le //=. intros x' ??; rewrite /f'/f''. AutoDerive.auto_derive.
               **** repeat split; auto; try nra.
               **** field. nra.
           *** rewrite /Rbar_le //=. intros x' ??; rewrite /f'/f''.
               field_simplify; last by nra.
               apply Rle_ge. replace (0 / 1) with 0 by nra.
               apply Rdiv_le_0_compat; nra.
           *** rewrite //=.  nra.
           *** nra.
           *** rewrite //=. nra.
         }
      ** rewrite //=. nra.
      ** rewrite //=. nra.
      ** rewrite //=. nra.
  - apply exp_pos.
  - apply exp_pos.
Qed.


Require Export XR_Rle_0_sqr.
Require Export XR_Rsqr_0_uniq.
Require Export XR_Rplus_eq_0_l.

Local Open Scope R_scope.

Lemma Rplus_sqr_eq_0_l : forall r1 r2,
  Rsqr r1 + Rsqr r2 = R0 ->
  r1 = R0.
Proof.
  intros x y h.
  apply Rsqr_0_uniq.
  apply Rplus_eq_0_l with (Rsqr y).
  { apply Rle_0_sqr. }
  { apply Rle_0_sqr. }
  { exact h. }
Qed.


Require Import HoTT.Basics HoTT.Types.

(** * The law of excluded middle *)

Monomorphic Axiom ExcludedMiddle : Type0.
Existing Class ExcludedMiddle.

Axiom LEM : forall `{ExcludedMiddle} (P : Type), IsHProp P -> P + ~P.

Definition ExcludedMiddle_type := forall (P : Type), IsHProp P -> P + ~P.

(** ** LEM means that all propositions are decidable *)

Global Instance decidable_lem `{ExcludedMiddle} (P : Type) `{IsHProp P} : Decidable P
  := LEM P _.

(** ** Double-negation elimination *)

Definition DNE_type := forall P, IsHProp P -> ~~P -> P.

Definition LEM_to_DNE : ExcludedMiddle -> DNE_type.
Proof.
  intros lem P hp nnp.
  case (LEM P _).
  - auto.
  - intros np; elim (nnp np).
Defined.

(** This direction requires Funext. *)
Definition DNE_to_LEM `{Funext} :
  DNE_type -> ExcludedMiddle_type.
Proof.
  intros dn P hp.
  refine (dn (P + ~P) _ _).
  - apply ishprop_sum.
    + exact _.
    + exact _.
    + intros p np; exact (np p).
  - intros nlem.
    apply nlem.
    apply inr.
    intros p.
    apply nlem.
    apply inl.
    apply p.
Defined.

(** DNE is equivalent to "every proposition is a negation". *)
Definition allneg_from_DNE (H : DNE_type) (P : Type) `{IsHProp P}
  : {Q : Type & P <-> ~Q}.
Proof.
  exists (~P); split.
  - intros p np; exact (np p).
  - apply H; exact _.
Defined.

Definition DNE_from_allneg (H : forall P, IsHProp P -> {Q : Type & P <-> ~Q})
  : DNE_type.
Proof.
  intros P ? nnp.
  destruct (H P _) as [Q e].
  apply e.
  intros q.
  apply nnp.
  intros p.
  exact (fst e p q).
Defined.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable tS_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable par_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable oS_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable cong_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.
Variable cR_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable betS_ : Universe -> Universe -> Universe -> Prop.

Variable defcross_1 : (forall A B C D : Universe, (exists X : Universe, (cR_ A B C D -> (betS_ A X B /\ betS_ C X D)))).
Variable defcross2_2 : (forall A B C D X : Universe, ((betS_ A X B /\ betS_ C X D) -> cR_ A B C D)).
Variable defcollinear_3 : (forall A B C : Universe, (col_ A B C -> (A = B \/ (A = C \/ (B = C \/ (betS_ B A C \/ (betS_ A B C \/ betS_ A C B))))))).
Variable defcollinear2a_4 : (forall A B C : Universe, (A = B -> col_ A B C)).
Variable defcollinear2b_5 : (forall A B C : Universe, (A = C -> col_ A B C)).
Variable defcollinear2c_6 : (forall A B C : Universe, (B = C -> col_ A B C)).
Variable defcollinear2d_7 : (forall A B C : Universe, (betS_ B A C -> col_ A B C)).
Variable defcollinear2e_8 : (forall A B C : Universe, (betS_ A B C -> col_ A B C)).
Variable defcollinear2f_9 : (forall A B C : Universe, (betS_ A C B -> col_ A B C)).
Variable lemma_collinearorder_10 : (forall A B C : Universe, (col_ A B C -> (col_ B A C /\ (col_ B C A /\ (col_ C A B /\ (col_ A C B /\ col_ C B A)))))).
Variable lemma_parallelNC_11 : (forall A B C D : Universe, (par_ A B C D -> (~(col_ A B C) /\ (~(col_ A C D) /\ (~(col_ B C D) /\ ~(col_ A B D)))))).
Variable lemma_NCorder_12 : (forall A B C : Universe, (~(col_ A B C) -> (~(col_ B A C) /\ (~(col_ B C A) /\ (~(col_ C A B) /\ (~(col_ A C B) /\ ~(col_ C B A))))))).
Variable defoppositeside_13 : (forall P A B Q : Universe, (exists X : Universe, (tS_ P A B Q -> (betS_ P X Q /\ (col_ A B X /\ ~(col_ A B P)))))).
Variable defoppositeside2_14 : (forall P A B Q X : Universe, ((betS_ P X Q /\ (col_ A B X /\ ~(col_ A B P))) -> tS_ P A B Q)).
Variable lemma_samenotopposite_15 : (forall A B C D : Universe, (oS_ A B C D -> ~(tS_ A C D B))).
Variable lemma_crisscross_16 : (forall A B C D : Universe, ((par_ A C B D /\ ~(cR_ A B C D)) -> cR_ A D B C)).
Variable axiom_betweennesssymmetry_17 : (forall A B C : Universe, (betS_ A B C -> betS_ C B A)).
Variable proposition_33_18 : (forall A B C D M : Universe, ((par_ A B C D /\ (cong_ A B C D /\ (betS_ A M D /\ betS_ B M C))) -> (par_ A C B D /\ cong_ A C B D))).

Theorem proposition_33B_19 : (forall A B C D : Universe, ((par_ A B C D /\ (cong_ A B C D /\ oS_ A C B D)) -> (par_ A C B D /\ cong_ A C B D))).
Proof.
  time tac.
Qed.

End FOFProblem.


From mathcomp Require Import all_ssreflect all_algebra.
Require Import classical unit ideal.

Open Scope ring_scope.
Open Scope classical_set_scope.

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

Section ascending_chain.
Variable (R : comRingType).

(* A chain of ideals I_1, I_2, ..., I_n, ... *)
Variable (chain : nat -> {pred R}).

(* The ascending chain condition *)
Definition asc_chain :=
  (* the chain is actually a chain of ideals *)
  (forall n, idealr (chain n)) ->
  (* the chain is well-formed *)
  (forall m n, (m <= n)%nat -> chain m `<=` chain n)
  -> exists m, forall n, (n >= m)%nat -> chain m =i \bigcup_(i : nat) (chain i).
End ascending_chain.

Module NoetherianRing.
Import GRing.
Section axiom.
Variable (R : comRingType).
Definition axiom := forall (chain : nat -> {pred R}), asc_chain chain.
End axiom.

Section ClassDef.
Record class_of (R : Type) : Type :=
  Class { base : ComRing.class_of R ; mixin : axiom (ComRing.Pack base) }.
Local Coercion base : class_of >-> ComRing.class_of.

Structure type := Pack { sort ; _ : class_of sort }.
Local Coercion sort : type >-> Sortclass.
Variable (T : Type) (cT : type).
Definition class := let: Pack _ c as cT' := cT return class_of cT' in c.
Definition clone c of phant_id class c := @Pack T c.
Let xT := let: Pack T _ := cT in T.
Notation xclass := (class : class_of xT).

Definition pack b0 (m0 : axiom (@ComUnitRing.Pack T b0)) :=
  fun bT b & phant_id (ComUnitRing.class bT) b =>
    fun    m & phant_id m0 m => Pack (@Class T b m).

Definition eqType := @Equality.Pack cT xclass.
Definition choiceType := @Choice.Pack cT xclass.
Definition zmodType := @Zmodule.Pack cT xclass.
Definition ringType := @Ring.Pack cT xclass.
Definition comRingType := @ComRing.Pack cT xclass.
End ClassDef.

Module Exports.
Coercion base : class_of >-> ComRing.class_of.
Arguments mixin [R] c.
Coercion mixin : class_of >-> axiom.
Coercion sort : type >-> Sortclass.
Bind Scope ring_scope with sort.

Coercion eqType : type >-> Equality.type.
Canonical eqType.
Coercion choiceType : type >-> Choice.type.
Canonical choiceType.
Coercion zmodType : type >-> Zmodule.type.
Canonical zmodType.
Coercion ringType : type >-> Ring.type.
Canonical ringType.
Coercion comRingType : type >-> ComRing.type.
Canonical comRingType.

Notation noetherianRingType := type.
Notation NoetherianRingType T m:= (@pack T _ m _ _ id _ id).
End Exports.
End NoetherianRing.
Import NoetherianRing.Exports.

Section noetherian_asc_chain.
Lemma noetherian_asc_chain (R : noetherianRingType) (chain : nat -> {pred R}) : asc_chain chain.
Proof.
  move: R chain => [R [? //=]].
Qed.
End noetherian_asc_chain.

Export NoetherianRing.Exports.


Require Export Topology.

(* TNeigh *)
Definition TNeigh x U X cT := Topology X cT ∧ x ∈ X ∧ U ⊂ X ∧
  ∃ V, V ∈ cT ∧ x ∈ V ∧ V ⊂ U.

Definition TNeighS x X cT := \{λ U, TNeigh x U X cT \}.

Fact TNeighP : ∀ x U X cT,
  Topology X cT → x ∈ U → U ∈ cT → TNeigh x U X cT.
Proof with eauto.
  intros * Ht Hx Hu. split... assert (Hxx : U ⊂ X).
  { apply Ht in Hu. apply ClaE in Hu... } split... split...
  exists U. repeat split... intros z Hz...
Qed.

(* Theorem1 *)
Definition Ux x U cT := ∪\{λ V, x ∈ U ∧ V ∈ cT ∧ x ∈ V ∧ V ⊂ U \}.

Lemma LeTh1 : ∀ U, U = ∪(\{λ t, ∃ x, x ∈ U ∧ t = [x]\}).
Proof with eauto.
  intro. AppE. apply ClaI. exists [x]. split. apply SingI...
  apply ClaI. exists x. split... apply ClaE in H as [y [Hy Heq]].
  apply ClaE in Heq as [z [Hz Heq]]. subst. apply SingE in Hy. subst...
Qed.

Theorem Theorem1 : ∀ U X cT, Topology X cT → U ⊂ X →
  (U ∈ cT ↔ ∀ x, x ∈ U → U ∈ TNeighS x X cT).
Proof with eauto.
  intros * Ht Hsub. split; intros Hp.
  - intros * Hx. apply ClaI. apply TNeighP...
  - destruct (classic (U = ∅)). subst; apply Ht.
    assert (H1 : ∪(\{λ t, ∃ x, x ∈ U ∧ t = [x]\}) ⊂
       ∪(\{λ t, ∃ x, x ∈ U ∧ t = Ux x U cT\})).
    { intros z Hz. apply ClaE in Hz as [y [Hy Hz]]. apply ClaE
        in Hz as [x0 [Hx0 Hz]]. subst... apply ClaE in Hy. subst...
      assert (Hx0' := Hx0). apply Hp in Hx0. apply ClaE in Hx0.
      apply ClaI. exists (Ux x0 U cT). split. apply ClaI.
      assert (Hn := Hx0). destruct Hx0 as [_ [_ [_ [V [Hv [Hx0 Hvu]]]]]].
      exists V. split... apply ClaI... apply ClaI... }
    assert (H2 : ∪(\{λ t, ∃ x, x ∈ U ∧ t = Ux x U cT\}) ⊂ U).
    { intros z Hz. apply ClaE in Hz as [y [Hy Hz]].
      apply ClaE in Hz as [t [Htu Hz]]. subst...
      apply ClaE in Hy as [e [Hz Hy]]. apply ClaE in Hy. apply Hy... }
    assert (Hg : U = ∪(\{λ t, ∃ x, x ∈ U ∧ t = Ux x U cT\})).
    { apply ReSyTrP... split... rewrite <- LeTh1 in H1... }
    rewrite Hg. apply Ht. intros V Hv.
    apply ClaE in Hv as [x [Hx Heq]]. subst.
    apply Ht. intros z Hz. apply ClaE in Hz; tauto.
Qed.

(* Theorem2_3_2 *)
Theorem Theorem2a : ∀ x X cT, Topology X cT → x ∈ X →
  TNeighS x X cT ≠ ∅ ∧ (∀ U, U ∈ TNeighS x X cT → x ∈ U).
Proof with eauto.
  intros * Ht Hx. split.
  - assert (X ∈ TNeighS x X cT).
    { apply ClaI. split... split... split. intros z Hz...
      exists X. split. apply Ht. split... intros z Hz... }
    intro. rewrite H0 in H. exfalso0.
  - intros * Hu. apply ClaE in Hu as [_ [_ [_ [V [_ [Hv Hsub]]]]]]...
Qed.

Theorem Theorem2b : ∀ x X cT, Topology X cT → x ∈ X →
  (∀ U V, U ∈ TNeighS x X cT → V ∈ TNeighS x X cT →
  U ∩ V ∈ TNeighS x X cT).
Proof with eauto.
  intros * Ht Hx * Hu Hv.
  apply ClaE in Hu as [_ [_ [Hux [U0 [Ho1 [Hu0 Hsub1]]]]]].
  apply ClaE in Hv as [_ [_ [Hvx [V0 [Ho2 [Hv0 Hsub2]]]]]].
  assert (Huv : x ∈ U0 ∩ V0 ∧ U0 ∩ V0 ⊂ U ∩ V).
  { split. apply ClaI; tauto. intros z Hz.
    apply ClaE in Hz as [Hzu Hzv]. apply ClaI. split... }
  apply ClaI. split... split... split. intros z Hz.
  apply ClaE in Hz as [Hz1 _]... exists (U0 ∩ V0).
  split; try apply Ht...
Qed.

Theorem Theorem2c : ∀ x X cT, Topology X cT → x ∈ X →
  ∀ U V, U ∈ TNeighS x X cT → V ⊂ X → U ⊂ V → V ∈ TNeighS x X cT.
Proof with eauto.
  intros * Ht Hx * Hu Hv Hsub.
  apply ClaE in Hu as [_ [_ [Hux [U0 [Hou [Hu0 Hsub1]]]]]].
  apply ClaI. split... split... split...
  exists U0. repeat split... eapply ReSyTrP...
Qed.

Theorem Theorem2d : ∀ x X cT, Topology X cT → x ∈ X →
  ∀ U, U ∈ TNeighS x X cT → ∃ V, V ∈ TNeighS x X cT ∧ V ⊂ U ∧
  (∀ y, y ∈ V → V ∈ TNeighS y X cT).
Proof with eauto.
  intros * Ht Hx * Hu. assert (Hu' := Hu).
  apply ClaE in Hu as [_ [_ [Hux [V [Hvo [Hvx Hsub]]]]]].
  exists V. split. apply ClaI. split... split... split.
  eapply ReSyTrP... exists V. split... split... intros z HZ...
  split... apply Theorem1... eapply ReSyTrP...
Qed.

(* Theorem3 *)
Theorem Theorem3 : ∀ f X, Mapping f X cP(cP(X)) →
  (∀ x, x ∈ X → f[x] ⊂ cP(X) /\
  f[x] ≠ ∅ /\ (∀ U, U ∈ f[x] → x ∈ U) /\
  (∀ U V, U ∈ f[x] → V ∈ f[x] → U ∩ V ∈ f[x]) /\
  (∀ U V, U ∈ f[x] → V ⊂ X → U ⊂ V → V ∈ f[x]) /\
  (∀ U, U ∈ f[x] → ∃ V, V ∈ f[x] ∧ V ⊂ U ∧
  (∀ y, y ∈ V → V ∈ f[y]))) →
  exists! cT, (Topology X cT ∧ ∀ x, x ∈ X → f[x] = TNeighS x X cT).
Proof with eauto.
  intros * Hf Hp. set (cT :=
    \{λ U, U ⊂ X ∧ ∀ x, x ∈ U → U ∈ f[x] \}). exists cT.
  assert (Hs : cT ⊂ cP( X)).
  { intros A Ha. apply ClaE in Ha. apply ClaI. tauto. }
  assert (Ht : Topology X cT).
  { repeat split...
    - apply ClaI. split. intros z Hz... intros.
      apply Hp in H as [Hsub [H1 [_ [_ [H3 _]]]]].
      apply EmptyNE in H1 as [U H1]. pose proof H1.
      apply Hsub in H; apply ClaE in H.
      apply (H3 U X) in H1... intros z Hz...
    - apply ClaI. split; intros z Hz; exfalso0.
    - intros * Ha Hb. apply ClaE in Ha as [Hsuba Ha].
      apply ClaE in Hb as [Hsubb Hb]. apply ClaI. assert (A ∩ B ⊂ X).
      { intros x Hx. apply ClaE in Hx as []... } split...
      intros. apply H in H0 as H1. apply ClaE in H0 as [Hzl Hzr].
      apply Ha in Hzl; apply Hb in Hzr. apply Hp...
    - intros cT1 Hsubt. apply ClaI. assert (∪cT1 ⊂ X).
      { intros x Hx. apply ClaE in Hx as [y [Hx Hy]].
        apply Hsubt in Hy. apply ClaE in Hy as [Hy _]... } split...
      intros. apply ClaE in H0 as [U [Hx Hu]]. pose proof Hu.
      apply Hsubt in Hu. apply ClaE in Hu as [Hu Hup].
      apply Hu in Hx as Hx'. apply Hup in Hx.
      apply Hp in Hx' as [_ [_ [_ [_ [Hx' _]]]]].
      apply (Hx' U (∪cT1))... intros t Ht. apply ClaI. exists U... }
  assert (Htp : ∀ x, x ∈ X → f[x] = TNeighS x X cT).
  { intros. pose proof H. apply Hp in H.
    destruct H as [Hsub [_ [H1' [_ [H3 H4]]]]].
    apply ExtAx; intros U; split; intros Hu.
    + pose proof Hu. apply Hsub in H. apply ClaE in H.
      apply H4 in Hu as [V [Hv [Huv HP]]]. assert (V ∈ cT).
      { apply ClaI. split... eapply ReSyTrP... }
      apply ClaI. split... split... split...
    + apply ClaE in Hu as [_ [_ [Hu [V [Hv [Hvx Huv]]]]]].
      apply ClaE in Hv as [_ Hv]. apply Hv in Hvx. apply (H3 V U)... }
  split... intros cT1 [Ht1 Htp1].
  apply ExtAx. intro W. split; intros.
  - apply ClaE in H as []. pose proof Theorem1 _ _ _ Ht1 H.
    apply H1. intros. apply H in H2 as Hx.
    apply H0 in H2. rewrite <- Htp1...
  - apply Ht1 in H as Hw; apply ClaE in Hw. apply ClaI. split...
    intros. pose proof Theorem1 _ _ _ Ht1 Hw.
    pose proof H0. apply H1 in H0... rewrite Htp1...
Qed.


From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq fintype bigop path choice finset fingraph.
Require Import automata misc regexp.
Require Import base.

Set Implicit Arguments.
Import Prenex Implicits.
Import Automata.

Lemma nand3P (b1 b2 b3: bool):
  reflect (~[\/ b1, b2 | b3]) [&& ~~ b1, ~~ b2 & ~~ b3].
Proof.
  apply: iffP.
      apply and3P.
    by move/and3P/andP => [] /negP H0 /andP [] /negP H1 /negP H2 [].
  move => H0. constructor; apply/negP => H1; apply H0; firstorder.
Qed.

Section MyhillNerode.
  Variable char: finType.
  Definition word:= word char.

  Section Relations.
    Variable L: language char.

    (* We model finiteness of equivalence classes
     by functions to some finType. *)

    Definition surjective {X: finType} {Y} (f: Y -> X) := forall x, exists w, f w == x.

    Record Fin_Eq_Cls :=
      {
        fin_type : finType;
        fin_func :> word -> fin_type;
        fin_surjective : surjective fin_func
      }.

    Section Inversion.

      Variable f: Fin_Eq_Cls.

      Definition cr (f: Fin_Eq_Cls) x := xchoose (fin_surjective f x).

      Lemma crK: cancel (cr f) f.
      Proof. move => x. by move: (xchooseP (fin_surjective f x)) => /eqP {2}<-. Qed.

      (* Needed? *)
      Lemma eq_cr x: x = (f (cr f x)).
      Proof. by rewrite crK. Qed.

    End Inversion.

    Section Myhill.

      Definition right_congruent {X} (f: word -> X) :=
        forall u v a, f u = f v -> f (rcons u a) = f (rcons v a).

      Definition refines {X} (f: word -> X) :=
        forall u v, f u = f v -> u \in L = (v \in L).

      Record Myhill_Rel :=
        {
          myhill_func :> Fin_Eq_Cls;
          myhill_congruent: right_congruent myhill_func;
          myhill_refines: refines myhill_func
        }.

    End Myhill.

    Definition suffix_equal u v :=
      forall w, u++w \in L = (v++w \in L).

    Definition equiv_suffix {X} (f: word -> X) :=
      forall u v, f u = f v <-> suffix_equal u v.

    Record Nerode_Rel :=
      {
        nerode_func :> Fin_Eq_Cls;
        nerode_equiv: equiv_suffix nerode_func
      }.

    Lemma cr_rcons (f: Nerode_Rel) w a: f (rcons (cr f (f w)) a) = f (rcons w a).
    Proof.
      apply (f.(nerode_equiv)) => u.
      rewrite -2!cats1 -2!catA /=.
      apply f.(nerode_equiv).
      by rewrite crK.
    Qed.

    Section Weak_Nerode.

      Definition imply_suffix {X} (f: word -> X) :=
        forall u v, f u = f v -> suffix_equal u v.

      Record Weak_Nerode_Rel :=
        {
          weak_nerode_func :> Fin_Eq_Cls;
          weak_nerode_imply: imply_suffix weak_nerode_func
        }.

    End Weak_Nerode.

    Section Weak_Nerode_Facts.

      Variable f: Weak_Nerode_Rel.

      Lemma cr_mem_L_cat u v: cr f (f u) ++ v \in L = (u ++ v \in L).
      Proof.
        erewrite f.(weak_nerode_imply).
          reflexivity.
        by rewrite crK.
      Qed.

      Lemma cr_mem_L w: cr f (f w) \in L = (w \in L).
      Proof.
        rewrite -(cats0 (cr f (f w))) -{2}(cats0 w).
        exact: cr_mem_L_cat.
      Qed.

    End Weak_Nerode_Facts.

    Definition nerode_weak_nerode (f: Nerode_Rel): Weak_Nerode_Rel :=
      {| weak_nerode_imply := fun u v H => match nerode_equiv f u v with conj H0 H1 => H0 H end |}.

    Coercion nerode_weak_nerode : Nerode_Rel >-> Weak_Nerode_Rel.

  End Relations.

  Section DFA_To_Myhill.
    Variable A: dfa char.
    Definition A_c := dfa_connected A.
    Definition f_M := fun w => last (dfa_s A_c) (dfa_run A_c w).

    Lemma f_M_surjective: surjective f_M.
    Proof.
      move => x.
      move: (dfa_connected_repr x) => [] w <-.
      by exists w.
    Qed.

    Definition f_fin : Fin_Eq_Cls :=
      {|
        fin_func := f_M;
        fin_surjective := f_M_surjective
      |}.

    Lemma f_M_right_congruent: right_congruent f_M.
    Proof.
      move => u v a H.
      rewrite -2!cats1 /f_M /= 2!dfa_run'_cat.
      by rewrite 2!last_cat -/(f_M u) -/(f_M v) H.
    Qed.

    Lemma f_M_refines: refines (dfa_lang A_c) f_M.
    Proof.
      move => u v H.
      rewrite -!dfa_run_accept.
      by rewrite -/(f_M v) -/(f_M u) -H.
    Qed.

    Definition dfa_to_myhill' : Myhill_Rel (dfa_lang A_c) :=
      {|
        myhill_func := f_fin;
        myhill_congruent := f_M_right_congruent;
        myhill_refines := f_M_refines
      |}.

    Lemma myhill_lang_eq L1 L2: L1 =i L2 -> Myhill_Rel L1 -> Myhill_Rel L2.
    Proof.
      move => H [f H1]. econstructor;
        first by eauto.
      move => u v. rewrite -H. eauto.
    Qed.

    Lemma dfa_to_myhill : Myhill_Rel (dfa_lang A).
    Proof. exact: myhill_lang_eq (dfa_connected_correct A) dfa_to_myhill'. Defined.

  End DFA_To_Myhill.

  Section Myhill_Weak_Nerode.

    Variable L: language char.
    Variable f: Myhill_Rel L.

    Lemma myhill_suffix: imply_suffix L f.
    Proof.
      move => u v Huv w.
      elim: w u v Huv => [|a w IHw] u v Huv.
        rewrite 2!cats0.
        exact: f.(myhill_refines).
      rewrite -cat1s 2!catA 2!cats1.
      apply: IHw.
      exact: f.(myhill_congruent).
    Qed.

    Lemma myhill_to_weak_nerode: Weak_Nerode_Rel L.
    Proof. exact
      {|
        weak_nerode_func := f;
        weak_nerode_imply := myhill_suffix
      |}.
    Defined.

  End Myhill_Weak_Nerode.

  Section Nerode_To_DFA.
    Variable L: language char.
    Variable f: Nerode_Rel L.

    Definition nerode_to_dfa :=
      {|
        dfa_s := f [::];
        dfa_fin := [pred x | cr f x \in L ];
        dfa_step := [fun x a => f (rcons (cr f x) a)]
      |}.

    Lemma nerode_to_dfa_run w: last (f[::]) (dfa_run' nerode_to_dfa (f [::]) w) = f w.
    Proof.
      move: w.
      apply: last_ind => [|w a IHw] //.
      rewrite -{1}cats1 dfa_run'_cat last_cat IHw /=.
      exact: cr_rcons.
    Qed.

    Lemma nerode_to_dfa_correct: L =i dfa_lang nerode_to_dfa.
    Proof.
      move => w.
      rewrite /dfa_lang /= -dfa_run_accept nerode_to_dfa_run in_simpl /=.
      by rewrite (cr_mem_L f w).
    Qed.

  End Nerode_To_DFA.

  Section Minimalization.
    Variable L: language char.
    Variable f_0: Weak_Nerode_Rel L.
    Definition X := f_0.(fin_type).

    Definition succ := [ fun x a => f_0 ((cr f_0 x) ++ [::a]) ].

    Definition psucc := [ fun x y => [ fun a => (succ x a, succ y a) ] ].

    Definition distinguishable := [ fun x y => (cr f_0 x) \in L != ((cr f_0 y) \in L) ].

    Definition dist0 := [set x | distinguishable x.1 x.2 ].

    Lemma dist0P x:
      reflect (cr f_0 x.1 \in L <> (cr f_0 x.2 \in L))
              (x \in dist0).
    Proof.
      rewrite /dist0 /= !inE.
      apply: iffP. apply idP.
        by move/eqP.
      by move/eqP.
    Qed.

    Lemma dist0NP x:
      reflect (cr f_0 x.1 \in L = (cr f_0 x.2 \in L))
              (x \notin dist0).
    Proof.
      apply: iffP. apply idP.
        move => H. apply/eqP. move: H.
        apply: contraR. move/eqP.
        by move/dist0P.
      move/eqP. apply: contraL. by move/dist0P/eqP.
    Qed.

    Definition distS (dist: {set X*X}) :=
      [set  (x,y) | x in X, y in X & [ exists a, psucc x y a \in dist ] ].

    Lemma distSP (dist: {set X*X}) x y:
      reflect (exists a, psucc x y a \in dist)
              ((x,y) \in distS dist).
    Proof.
      apply: iffP. apply idP.
        move/imset2P => [] x' y' _.
        rewrite !inE /= => /existsP [] a.
        move => H [H1 H2]. subst.
        by eauto.
      move => [a H].
      apply mem_imset2; first by done.
      rewrite !inE /=. apply/existsP.
      exists a. exact H.
    Qed.

    Lemma distSNP (dist: {set X*X}) x y:
      reflect (forall a, psucc x y a \notin dist)
              ((x,y) \notin distS dist).
    Proof.
      apply: introP.
        move/distSP => H1 a.
        apply/negP => H2. by eauto.
      move/negbTE/distSP => [a H1] H2.
      absurd (psucc x y a \in dist) => //.
      by apply/negP.
    Qed.

    Definition one_step_dist dist := dist0 :|: dist :|: (distS dist).

    Lemma one_step_distP (dist: {set X*X}) x:
      reflect ([\/ x \in dist0, x \in dist | x \in distS dist])
              (x \in one_step_dist dist).
    Proof.
      rewrite /one_step_dist !inE.
      apply: introP.
        move/orP => [/orP [] |]; eauto using or3.
      by move/norP => [] /norP [] /negbTE -> /negbTE -> /negbTE -> [].
    Qed.

    Lemma one_step_distNP (dist: {set X*X}) x:
      reflect ([/\ x \notin dist0, x \notin dist & x \notin distS dist])
              (x \notin one_step_dist dist).
    Proof.
      apply: introP.
        by move/one_step_distP/nand3P/and3P.
      move/negbNE/one_step_distP/nand3P => H1 H2.
      apply: H1. by apply/and3P.
    Qed.

    Definition distinct := lfp one_step_dist.

    Notation "x ~!= y" := ((x,y) \in distinct) (at level 70, no associativity).
    Notation "u ~!=_f_0 v" := (f_0(u) ~!= f_0(v)) (at level 70, no associativity).
    Notation "x ~= y" := ((x,y) \notin distinct) (at level 70, no associativity).
    Notation "u ~=_f_0 v" := (f_0(u) ~= f_0(v)) (at level 70, no associativity).

    Lemma distS_mono: mono distS.
    Proof.
      move => s t /subsetP H.
      apply/subsetP.
      move => [x y] /distSP [a H1].
      apply/distSP. exists a.
      exact: H.
    Qed.

    Lemma one_step_dist_mono: mono one_step_dist.
    Proof.
      move => s t H. apply/subsetP.
      move => [x y] /one_step_distP [] H1; apply/one_step_distP;
        first by eauto using or3.
        move: (subsetP H _ H1).
        by eauto using or3.
      move/subsetP: (distS_mono H).
      by eauto using or3.
    Qed.

    Lemma equiv0_refl x:
      (x,x) \notin dist0.
    Proof. by rewrite in_set /= eq_refl. Qed.

    Lemma equiv_refl x: x ~= x.
    Proof.
      rewrite /distinct. move: x.
      apply lfp_ind => [|dist IHdist] x.
        by rewrite  in_set.
      apply/one_step_distNP. econstructor => //;
        first by exact: equiv0_refl.
      apply/distSNP => a.
      exact: IHdist.
    Qed.

    Lemma dist_sym x y: distinguishable x y -> distinguishable y x.
    Proof. by rewrite /= eq_sym. Qed.

    Lemma not_dist_sym x y: ~~ distinguishable x y -> ~~ distinguishable y x.
    Proof. apply: contraL. move/dist_sym => H. by apply/negPn. Qed.

    Lemma equiv0_sym x y: (x,y) \notin dist0 -> (y,x) \notin dist0.
    Proof. by rewrite /dist0 /= 2!in_set eq_sym. Qed.

    Lemma dist0_sym x y: (x,y) \in dist0 -> (y,x) \in dist0.
    Proof. by rewrite /dist0 /= 2!in_set eq_sym. Qed.

    Lemma equiv_sym x y:  x ~= y -> y ~= x.
    Proof.
      move: x y.
      rewrite /distinct.
      apply lfp_ind => [|s IHs] x y.
        by rewrite 2!in_set.
      move/one_step_distNP => [] H0 H1 H2.
      apply/one_step_distNP. constructor.
          exact: equiv0_sym.
        exact: IHs.
      apply/distSNP => a.
      move/distSNP in H2.
      apply: IHs. exact: H2.
    Qed.

    Lemma equiv_trans x y z: x ~= y -> y ~= z -> x ~= z.
    Proof.
      move: x y z.
      rewrite /distinct.
      apply lfp_ind => [|s IHs] x y z.
        by rewrite 3!in_set.
      move/one_step_distNP => [] /dist0NP H1 H2 /distSNP H3.
      move/one_step_distNP => [] /dist0NP H4 H5 /distSNP H6.
      apply/one_step_distNP. constructor.
          apply/dist0NP. by rewrite H1 H4.
        by apply: IHs; eassumption.
      apply/distSNP => a.
      apply: IHs.
        by eapply H3.
      exact: H6.
    Qed.

    Lemma equiv_suffix_equal u v: u ~=_f_0 v -> suffix_equal L u v.
    Proof.
      move => H w. apply/eqP. move: H.
      apply: contraR.
      elim: w u v => [|a w IHw] u v.
        rewrite 2!cats0.
        rewrite /distinct lfpE -/distinct /one_step_dist => H;
          last by exact: one_step_dist_mono.
        by rewrite /dist0  /= 3!in_set 2!cr_mem_L H.
      move => H.
      rewrite /distinct lfpE -/distinct;
        last by exact: one_step_dist_mono.
      apply/one_step_distP. apply: Or33.
      apply/distSP. exists a.
      apply: IHw.
      by rewrite -2!catA 2!(cr_mem_L_cat f_0).
    Qed.

    Lemma distinct_not_suffix_equal u v:
      u ~!=_f_0 v ->
      exists w, u ++ w \in L != (v ++ w \in L).
    Proof.
      rewrite /distinct.
      move: u v.
      apply lfp_ind => [|dist IHdist] u v.
        by rewrite in_set.
      move/one_step_distP => [].
          move/dist0P => /eqP.
          rewrite !cr_mem_L /= => H.
          exists [::]. by rewrite 2!cats0.
        exact: IHdist.
      move/distSP => [a] /IHdist [w].
      rewrite -2!catA !cr_mem_L_cat.
      by eauto.
    Qed.

    Lemma equivP u v:
      reflect (suffix_equal L u v)
              (u ~=_f_0 v).
    Proof.
      apply: introP.
        exact: equiv_suffix_equal.
      move/negbNE => /distinct_not_suffix_equal [w H] H0.
      move: (H0 w).
      move => H1. move/eqP: H.
      by rewrite H1.
    Qed.

    Definition equiv_repr x := [set y | x ~= y].

    Lemma equiv_repr_refl x : x \in equiv_repr x.
    Proof. by rewrite in_set equiv_refl. Qed.

    Definition X_min := map equiv_repr (enum (fin_type f_0)).

    Lemma equiv_repr_mem x: equiv_repr x \in X_min.
    Proof. apply/mapP. exists x => //. by rewrite mem_enum. Qed.

    Definition f_min w := SeqSub (equiv_repr_mem (f_0 w)).

    Lemma f_minP u v:
      reflect (f_min u = f_min v)
              (u ~=_f_0 v).
    Proof.
      apply: iffP.
        apply idP.
        move => H.
        rewrite /f_min /=.
        apply/eqP.
        change ([set x | (f_0 u, x) \notin distinct] == [set x | (f_0 v, x) \notin distinct]).
        apply/eqP.
        apply/setP => x.
        rewrite 2!in_set.
        apply/idP/idP => H0;
          eauto using equiv_sym, equiv_trans.
      move => [] /= /setP H1. move: (H1 (f_0 v)).
      by rewrite equiv_repr_refl in_set => ->.
    Qed.

    Lemma f_min_correct: equiv_suffix L f_min.
    Proof.
      move => u v.
      split.
        move/f_minP.
        exact: equiv_suffix_equal.
     move => H.
     apply/f_minP.
     by apply/equivP.
    Qed.

    Lemma f_min_surjective: surjective f_min.
    Proof.
      move => [x Hx].
      move/mapP: (Hx) => [y Hy Hxy].
      exists (cr f_0 y).
      rewrite /f_min.
      change (equiv_repr (f_0 (cr f_0 y)) == x).
      by rewrite Hxy crK.
    Qed.

    Definition f_min_fin: Fin_Eq_Cls :=
      {| fin_surjective := f_min_surjective |}.

    Lemma weak_nerode_to_nerode: Nerode_Rel L.
    Proof. exact
      {|
        nerode_func := f_min_fin;
        nerode_equiv := f_min_correct
      |}.
    Defined.

  End Minimalization.

End MyhillNerode.


(* --------------------------------------------------------------------
 * Copyright (c) - 2006--2012 - IMDEA Software Institute
 * Copyright (c) - 2006--2012 - Inria
 * Copyright (c) - 2006--2012 - Microsoft Coprporation
 *
 * Distributed under the terms of the CeCILL-B-V1 license
 * -------------------------------------------------------------------- *)

(*************************************************************)
(*      This file is distributed under the terms of the      *)
(*      GNU Lesser General Public License Version 2.1        *)
(*************************************************************)
(*    Benjamin.Gregoire@inria.fr Laurent.Thery@inria.fr      *)
(*************************************************************)

(**********************************************************************
     Aux.v

     Auxillary functions & Theorems
 **********************************************************************)
Require Export Arith.

(**************************************
  Some properties of minus
**************************************)

Theorem minus_O : forall a b : nat, a <= b -> a - b = 0.
intros a; elim a; simpl in |- *; auto with arith.
intros a1 Rec b; case b; elim b; auto with arith.
Qed.

(**************************************
  Definitions and properties of the power for nat
**************************************)

Fixpoint pow (n m: nat)  {struct m} : nat := match m with O => 1%nat | (S m1) => (n * pow n m1)%nat  end.

Theorem pow_add: forall n m p, pow n (m + p) = (pow n m * pow n p)%nat.
intros n m; elim m; simpl.
intros p; rewrite plus_0_r; auto.
intros m1 Rec p; rewrite Rec; auto with arith.
Qed.

Theorem pow_pos: forall p n, (0 < p)%nat -> (0 < pow p n)%nat.
intros p1 n H; elim n; simpl; auto with arith.
intros n1 H1; replace 0%nat with (p1 * 0)%nat; auto with arith.
repeat rewrite (mult_comm p1); apply mult_lt_compat_r; auto with arith.
Qed.

Theorem pow_monotone: forall n p q, (1 < n)%nat -> (p < q)%nat -> (pow n p < pow n q)%nat.
intros n p1 q1 H H1; elim H1; simpl.
pattern (pow n p1) at 1; rewrite <- (mult_1_l (pow n p1)).
apply mult_lt_compat_r; auto.
apply pow_pos; auto with arith.
intros n1 H2 H3.
apply lt_trans with (1 := H3).
pattern (pow n n1) at 1; rewrite <- (mult_1_l (pow n n1)).
apply mult_lt_compat_r; auto.
apply pow_pos; auto with arith.
Qed.

(************************************
  Definition of the divisibility for nat
**************************************)

Definition divide a b := exists c, b = a * c.

Theorem divide_le: forall p q, (1 < q)%nat -> divide p q -> (p <= q)%nat.
intros p1 q1 H (x, H1); subst.
apply le_trans with (p1 * 1)%nat; auto with arith.
rewrite mult_1_r; auto with arith.
apply mult_le_compat_l.
case (le_lt_or_eq 0 x); auto with arith.
intros H2; subst; contradict H; rewrite mult_0_r; auto with arith.
Qed.


(**
 ============================================================================
 Project     : Nominal A, AC and C Unification
 File        : C_Unif.v
 Authors     : Washington Lu\'is R. de Carvalho Segundo and
               Mauricio Ayala Rinc\'on
               Universidade de Bras\'ilia (UnB) - Brazil
               Group of Theory of Computation

 Description : This file is dedicated to the definition of
               the C-unification algorithm and somes basics
               results over this definition.

 Last Modified On: Sep 17, 2018.
 ============================================================================
*)

Require Export Substs.

(** Definition of a solution for a C-unification problem *)

Definition sol_c (Sl : Context * Subst) (T : Triple) :=
  let C := (fst (fst T)) in
  let S := (snd (fst T)) in
  let P := (snd T) in
  let D := (fst Sl) in
  let W := (snd Sl) in
(* 1 *) ( fresh_env C D W ) /\
(* 2 *) ( forall a t, set_In (a#?t) P -> D |- a # (t|^W) ) /\
(* 3 *) ( forall s t, set_In (s~?t) P -> D |- (s|^W) ~c (t|^W) ) /\
(* 4 *) ( exists S'', D |- (S©S'') ~:c W ) .

(** The fresh\_sys relation *)

Inductive fresh_sys : Triple -> Triple -> Prop :=

 | fresh_sys_Ut : forall C S P a, (set_In (a#?(<<>>)) P) ->
                                  fresh_sys (C,S,P)
                                            (C,S,P\(a#?(<<>>)))

 | fresh_sys_At : forall C S P a b, a <> b -> (set_In (a#?(%b)) P) ->
                                    fresh_sys (C,S,P)
                                              (C,S,(P\(a#?(%b))))

 | fresh_sys_Fc : forall C S P a E n s, (set_In (a#?(Fc E n s)) P) ->
                                        fresh_sys (C,S,P)
                                                  (C,S,(P|+(a#?s))\(a#?(Fc E n s)))

 | fresh_sys_Ab_1 : forall C S P a s, (set_In (a#?([a]^s)) P) ->
                                      fresh_sys (C,S,P)
                                                (C,S,(P\(a#?([a]^s))))

 | fresh_sys_Ab_2 : forall C S P a b s, a <> b -> (set_In (a#?([b]^s)) P) ->
                                        fresh_sys (C,S,P)
                                                  (C,S,(P|+(a#?s))\(a#?([b]^s)))

 | fresh_sys_Su : forall C S P a pi X, (set_In (a#?(pi|.X)) P) ->
                                       fresh_sys (C,S,P)
                                                 (C|++((!pi) $ a,X),S,(P\(a#?(pi|.X))))
 | fresh_sys_Pr : forall C S P a s t, (set_In (a#?(<|s,t|>)) P) ->
                                      fresh_sys (C,S,P)
                                                (C,S,(((P|+(a#?s))|+(a#?t))\(a#?(<|s,t|>))))
.

(** Definition of A_equivalence between two terms w.r.t. the function symbol f^E_n *)

Definition A_equiv (s t : term) (E n : nat) :=
                    term_size s = term_size t /\
                    (forall i, i <= TPlength s E n -> TPith i s E n = TPith i t E n) .

(** The equ\_sys relation *)

Inductive equ_sys (varSet : set Var) : Triple -> Triple -> Prop :=

 | equ_sys_refl : forall C S P s, (set_In (s~?s) P) ->
                                   equ_sys varSet (C,S,P)
                                                  (C,S,P\(s~?s))

 | equ_sys_Pr : forall C S P s0 s1 t0 t1,
                  (set_In ((<|s0,s1|>)~?(<|t0,t1|>)) P) ->
                   equ_sys varSet (C,S,P)
                                  (C,S,(((P|+(s0~?t0))|+(s1~?t1))\((<|s0,s1|>)~?(<|t0,t1|>))))

 | equ_sys_Fc : forall C S P E n t t', (set_In ((Fc E n t)~?(Fc E n t')) P) -> E <> 2 ->

                                        equ_sys varSet (C,S,P)
                                                       (C,S,(P|+(t~?t'))\((Fc E n t)~?(Fc E n t')))

 | equ_sys_C1 : forall C S P n s0 s1 t0 t1,

   (set_In ((Fc 2 n (<|s0,s1|>))~?(Fc 2 n (<|t0,t1|>)))) P ->

     equ_sys varSet (C,S,P)
                    (C,S,((P|+(s0~?t0))|+(s1~?t1))\(Fc 2 n (<|s0,s1|>)~?(Fc 2 n (<|t0,t1|>))))

 | equ_sys_C2 : forall C S P n s0 s1 t0 t1,

   (set_In ((Fc 2 n (<|s0,s1|>))~?(Fc 2 n (<|t0,t1|>)))) P ->

     equ_sys varSet (C,S,P)
                    (C,S,((P|+(s0~?t1))|+(s1~?t0))\(Fc 2 n (<|s0,s1|>)~?(Fc 2 n (<|t0,t1|>))))

 | equ_sys_Ab1 : forall C S P a t t', (set_In (([a]^t)~?([a]^t')) P) ->
                                       equ_sys varSet (C,S,P)
                                                      (C,S,(P|+(t~?t'))\(([a]^t)~?([a]^t')))

 | equ_sys_Ab2 : forall C S P a b t t',
                    a <> b -> (set_In (([a]^t)~?([b]^t')) P) ->
                    equ_sys varSet (C,S,P)
                                   (C,S,((P|+(t~?(((a,b)::nil)@t'))|+(a#?t')))\(([a]^t)~?([b]^t')))

 | equ_sys_inst : forall C S S' P pi X t,

                    (~ set_In X (set_union var_eqdec (term_vars t) varSet)) ->

                    ((set_In (pi|.X~?t) P) \/ (set_In (t~?(pi|.X)) P)) ->

                    S' = S©((X,(!pi)@t)::nil) ->

                    equ_sys varSet (C,S,P)
                                   (C,S',((P\(pi|.X~?t)\(t~?(pi|.X)))|^^((X,(!pi)@t)::nil))\cup(C/?S'))

 | equ_sys_inv : forall C S P pi pi' X,
                   pi <> pi' -> pi' <> [] -> (set_In ((pi|.X)~?(pi'|.X)) P) ->
                   equ_sys varSet (C,S,P)
                                  (C,S,(P|+((pi++(!pi'))|.X~?([]|.X)))\((pi|.X)~?(pi'|.X)))
.

(** Definition of valid triples *)

Definition valid_triple (T : Triple) :=
  let C := (fst (fst T)) in
  let S := (snd (fst T)) in
  let P := (snd T) in
  (* 1 *) ( set_inter var_eqdec (dom_rec S) (Problem_vars P) = [] ) /\
  (* 2 *) ( set_inter var_eqdec (dom_rec S) (im_vars S) = [] ) .

(** Definitions of normal forms and of a reflexive-transitive closure *)

Definition NF (T:Type) (R:T->T->Prop) (s:T) := forall t, ~ R s t.

Inductive tr_clos (T:Type) (R:T->T->Prop) : T->T->Prop :=
 | tr_rf : forall s, tr_clos T R s s
 | tr_os : forall s t, R s t -> tr_clos T R s t
 | tr_ms : forall s t u, R s t -> tr_clos T R t u -> tr_clos T R s u
.

(** Definition of unif\_step *)

(**
	A unification step is an equ_sys reduction,
	or a fresh_sys reduction over a triple whose equational
	constraints are all fixpoint equations.
*)

Inductive unif_step  (varSet : set Var) : Triple -> Triple -> Prop :=

 | equ_unif_step   : forall T T', equ_sys varSet T T' -> unif_step varSet T T'

 | fresh_unif_step : forall T T', fixpoint_Problem (equ_proj (snd T)) ->
                                  fresh_sys T T' -> unif_step varSet T T'
.

(** Definition of leaf and unif\_path *)

(**
	A leaf T is a normal form of relation unif_step.
*)

Definition leaf (varSet : set Var) (T : Triple) := NF _ (unif_step varSet) T .

(**
	A unifcation path from T to T' (unif_path T T') is zero
	or more steps of unif_step from T and T'
	where T' is a normal form (w.r.t. unif_path), ie, a leaf.
*)

Definition unif_path  (varSet : set Var) (T T' : Triple) := tr_clos _ (unif_step varSet) T T' /\ leaf varSet T'.

(** Some basic lemmas regarding fresh\_sys, equ\_sys, unif\_step and unif\_path *)

(**
	If all equational constraints of P in T = (C, S, P)
	are fixpoint equations, then T is a normal form w.r.t equ_sys.
*)

Lemma equ_proj_fixpoint_is_NF : forall C S P varSet, fixpoint_Problem (equ_proj P) ->
                                NF _ (equ_sys varSet) (C,S,P).
Proof.
  intros. unfold NF; intro T. intro H0.
  unfold fixpoint_Problem in H.
  unfold fixpoint_equ in H.
  destruct T. destruct p.
  inverts H0;
    try apply equ_proj_set_In_eq in H2;
    try apply equ_proj_set_In_eq in H3;
    try apply H in H2; try destruct H2;
    try apply H in H3; try destruct H3;
    try destruct H0; try destruct H0; try inverts H1.
  inverts H4. false.
  apply equ_proj_set_In_eq in H8.
  apply H in H8. destruct H8.
  destruct H0. destruct H0. inverts H1.
  destruct H8; apply equ_proj_set_In_eq in H0;  apply H in H0;
  destruct H0; destruct H0; destruct H0; inverts H1;
  apply H5; simpl; apply set_union_intro1; left~.
  apply equ_proj_set_In_eq in H9. apply H in H9.
  destruct H9. destruct H0. destruct H0.
  inverts H1. apply H8; trivial.
Qed.

(**
	The fixpoint equations are preserved by unif_step
*)

Lemma fixpoint_preserv : forall T T' varSet,
                           unif_step varSet T T' ->
                           fixpoint_Problem (equ_proj (snd T)) ->
                           fixpoint_Problem (equ_proj (snd T')).
Proof.
  intros. destruct H. destruct T. destruct p.
  simpl in H0.
  apply equ_proj_fixpoint_is_NF with (C:=c) (S:=s) (varSet := varSet) in H0.
  apply H0 in H. contradiction.
  inverts H1; simpl in *|-*;
  rewrite equ_proj_rem_eq; rewrite set_remove_eq;
  try apply fresh_not_In_equ_proj;
  try rewrite equ_proj_add_fresh; trivial.
  rewrite equ_proj_add_fresh; trivial.
Qed.

(**
	Problem properness is preserved by fresh\_sys, equ\_sys, unif\_step and unif\_path
*)

Lemma fresh_Proper_Problem : forall T T', fresh_sys T T' ->
                                          Proper_Problem (snd T) -> Proper_Problem (snd T').
Proof.
  intros. destruct T. destruct T'. simpl in *|-*.
  destruct p. destruct p1. unfold Proper_Problem in *|-*; intros.
  inverts H; apply set_remove_1 in H1; apply H0; trivial;
  try apply set_add_elim in H1; try  destruct H1; try inverts H; trivial.
  apply set_add_elim in H. destruct H; trivial. inverts H.
Qed.

Lemma equ_Proper_Problem : forall T T' varSet,
      equ_sys varSet T T' ->
      Proper_Problem (snd T) -> Proper_Problem (snd T').
Proof.
  intros. destruct T. destruct T'. simpl in *|-*.
  destruct p. destruct p1. unfold Proper_Problem in *|-*; intros.
  inverts H; try apply set_remove_1 in H1.
  apply H0; trivial.
  apply set_add_elim in H1. destruct H1. inverts H.
  apply H0 in H3. destruct H3. split~.
  apply Proper_subterm with (t :=<|s2,s3|>); trivial.
  simpl. apply set_add_intro1. apply set_union_intro2. apply In_subterms.
  apply Proper_subterm with (t :=<|t0,t1|>); trivial.
  simpl. apply set_add_intro1. apply set_union_intro2. apply In_subterms.
  apply set_add_elim in H. destruct H. inverts H. apply H0 in H3. destruct H3. split~.
  apply Proper_subterm with (t :=<|s2,s3|>); trivial.
  simpl. apply set_add_intro1. apply set_union_intro1. apply In_subterms.
  apply Proper_subterm with (t :=<|t0,t1|>); trivial.
  simpl. apply set_add_intro1. apply set_union_intro1. apply In_subterms.
  apply H0; trivial.
  apply set_add_elim in H1. destruct H1. inverts H.
  apply H0 in H4. destruct H4. split~.
  apply Proper_subterm with (t :=Fc E n t0); trivial.
  simpl. apply set_add_intro1. apply In_subterms.
  apply Proper_subterm with (t :=Fc E n t'); trivial.
  simpl. apply set_add_intro1. apply In_subterms.
  apply H0; trivial.
  apply H0 in H3. destruct H3.
  apply set_add_elim in H1. destruct H1. inverts H1. split~.
  apply Proper_subterm with (t :=Fc 2 n (<|s2,s3|>)); trivial.
  simpl. apply set_add_intro1. apply set_add_intro1.
  apply set_union_intro2. apply In_subterms.
  apply Proper_subterm with (t :=Fc 2 n (<|t0,t1|>)); trivial.
  simpl. apply set_add_intro1. apply set_add_intro1.
  apply set_union_intro2. apply In_subterms.
  apply set_add_elim in H1. destruct H1. inverts H1. split~.
  apply Proper_subterm with (t :=Fc 2 n (<|s2,s3|>)); trivial.
  simpl. apply set_add_intro1. apply set_add_intro1.
  apply set_union_intro1. apply In_subterms.
  apply Proper_subterm with (t :=Fc 2 n (<|t0,t1|>)); trivial.
  simpl. apply set_add_intro1. apply set_add_intro1.
  apply set_union_intro1. apply In_subterms.
  apply H0; trivial.
  apply H0 in H3. destruct H3.
  apply set_add_elim in H1. destruct H1. inverts H1. split~.
  apply Proper_subterm with (t :=Fc 2 n (<|s2,s3|>)); trivial.
  simpl. apply set_add_intro1. apply set_add_intro1.
  apply set_union_intro2. apply In_subterms.
  apply Proper_subterm with (t :=Fc 2 n (<|t0,t1|>)); trivial.
  simpl. apply set_add_intro1. apply set_add_intro1.
  apply set_union_intro1. apply In_subterms.
  apply set_add_elim in H1. destruct H1. inverts H1. split~.
  apply Proper_subterm with (t :=Fc 2 n (<|s2,s3|>)); trivial.
  simpl. apply set_add_intro1. apply set_add_intro1.
  apply set_union_intro1. apply In_subterms.
  apply Proper_subterm with (t :=Fc 2 n (<|t0,t1|>)); trivial.
  simpl. apply set_add_intro1. apply set_add_intro1.
  apply set_union_intro2. apply In_subterms.
  apply H0; trivial.
  apply set_add_elim in H1. destruct H1. inverts H.
  apply H0 in H3. destruct H3. split~.
  apply Proper_subterm with (t :=[a]^t0); trivial.
  simpl. apply set_add_intro1. apply In_subterms.
  apply Proper_subterm with (t :=[a]^t'); trivial.
  simpl. apply set_add_intro1. apply In_subterms.
  apply H0; trivial.
  apply set_add_elim in H1. destruct H1. inverts H.
  apply set_add_elim in H. destruct H. inverts H.
  apply H0 in H9. destruct H9. split~.
  apply Proper_subterm with (t :=[a]^t0); trivial.
  simpl. apply set_add_intro1. apply In_subterms.
  apply perm_Proper_term.
  apply Proper_subterm with (t :=[b]^t'); trivial.
  simpl. apply set_add_intro1. apply In_subterms.
  apply H0; trivial.
  apply set_union_elim in H1. destruct H1.
  apply set_In_subs_remove_problem in H.
  apply set_In_subs_remove_problem in H.
  apply set_In_subs in H.
  case H; clear H; intros u H. destruct H.
  destruct u. simpl in H. inverts H.
  simpl in H. inverts H.
  apply H0 in H1. destruct H1.
  split; apply subs_Proper_term; trivial;
  apply perm_Proper_term; destruct H9; apply H0 in H2; destruct H2; trivial.
  apply equ_subs_fresh in H. contradiction.
  apply set_add_elim in H1.
  destruct H1. inverts H.
  split; unfold Proper_term; intros; simpl in H; destruct H;
   try contradiction; inverts H.
  apply H0; trivial.
Qed.

Lemma unif_step_Proper_Problem : forall T T' varSet,
      unif_step varSet T T' ->
      Proper_Problem (snd T) -> Proper_Problem (snd T').
Proof.
  intros. inverts H.
  apply equ_Proper_Problem with (T:=T) (varSet := varSet); trivial.
  apply fresh_Proper_Problem with (T:=T); trivial.
Qed.

Lemma unif_path_Proper_Problem : forall T T' varSet,
      unif_path varSet T T' ->
      Proper_Problem (snd T) -> Proper_Problem (snd T').
Proof.
  intros. inverts H. induction H1; trivial.
  apply unif_step_Proper_Problem with (T:=s) (varSet := varSet); trivial.
  apply IHtr_clos; trivial.
  apply unif_step_Proper_Problem with (T:=s) (varSet := varSet); trivial.
Qed.

(**
	Validity is preserved by fresh\_sys, equ\_sys, unif\_step and unif\_path
*)

Lemma fresh_valid_preservation : forall T T',
      valid_triple T -> fresh_sys T T' -> valid_triple T'.
Proof.
  intros. unfold valid_triple in *|-*. destruct H;
  destruct H0; simpl in *|-*; split~;
  apply set_inter_nil; intro X0; apply set_inter_nil with (a:=X0) in H;
  intro H'; apply H; clear H; apply set_inter_elim in H';
  case H'; clear H'; intros Q Q';
  apply set_inter_intro; trivial;
  try apply Problem_vars_remove in Q';
  try apply Problem_vars_add in Q';
  try apply set_union_elim in Q';
  try destruct Q';
  try apply Problem_vars_add in H;
  try apply set_union_elim in H;
  try destruct H; try simpl in H;
  try apply set_union_elim in H;
  try destruct H; trivial;
  try apply Problem_vars_set_In
  with (X:=X0) in H0; simpl; trivial.
  apply Problem_vars_set_In with (X:=X0) in H2; simpl; trivial.
  apply set_union_intro1; trivial.
  apply set_union_intro2; trivial.
Qed.

Lemma equ_valid_preservation_aux : forall T T' varSet,
      valid_triple T -> equ_sys varSet T T' ->
      (set_inter var_eqdec (dom_rec (snd (fst T')))
                 (im_vars (snd (fst T'))) = []) .

Proof.
  intros. unfold valid_triple in *|-. destruct H;
    destruct H0; simpl in *|-*; trivial.

  assert (Q : ~ set_In X (dom_rec S)).
   apply set_inter_nil with (a:=X) in H.
   intro H4. apply H. apply set_inter_intro; trivial.
   destruct H2;
     apply Problem_vars_set_In with (X:=X) in H2; simpl; trivial.
   apply set_union_intro1; simpl; left~.
   apply set_add_intro2; trivial.

  assert (Q' : set_inter var_eqdec (dom_rec S) (term_vars t) = []).
   apply set_inter_nil. intro Y. intro H4.
   apply set_inter_elim in H4. destruct H4.
   apply set_inter_nil with (a:=Y) in H.
   apply H. apply set_inter_intro; trivial.
   destruct H2;
     apply Problem_vars_set_In with (X:=Y) in H2; simpl; trivial.
   apply set_union_intro2; trivial. apply set_add_intro1; trivial.

  apply set_inter_nil. intro Y. intro H4.
  apply set_inter_elim in H4. destruct H4.
  rewrite H3 in H4. rewrite H3 in H5.
  apply In_dom_eq_dom_rec in H4.
  apply dom_comp_add1 in H4.
  destruct H4. rewrite H4 in H5.
  apply im_vars_comp_add2 in H5; trivial.
  autorewrite with perm in H5. apply H0.
  apply set_union_intro1; trivial.
  apply im_vars_comp_add1 in H5; trivial.
  apply set_union_elim in H5. destruct H5.
  apply set_inter_nil with (a:=Y) in H1.
  apply H1. apply set_inter_intro; trivial.
  apply In_dom_eq_dom_rec; trivial.
  autorewrite with perm in H5.

  apply set_inter_nil with (a:=Y) in Q'.
  apply Q'. apply set_inter_intro; trivial.
  apply In_dom_eq_dom_rec; trivial.

Qed.

Lemma equ_valid_preservation : forall T T' varSet,
      valid_triple T -> equ_sys varSet T T' -> valid_triple T' .
Proof.
  intros. unfold valid_triple in *|-*. split~.
  Focus 2.
  (* 2:{ *)
  apply equ_valid_preservation_aux with (T:=T) (varSet := varSet); trivial. (* } *)
   destruct H. apply set_inter_nil. intros Y H2.
   apply set_inter_elim in H2. destruct H2.
  generalize H; intro H'.
  apply set_inter_nil with (a:=Y) in H;
  apply H; destruct H0; simpl in *|-*;
      repeat apply Problem_vars_remove in H3; simpl; trivial.

  apply set_inter_intro; trivial.

  apply set_inter_intro; trivial.
  apply Problem_vars_add in H3;
  apply set_union_elim in H3; destruct H3;
  try apply Problem_vars_add in H3;
  try apply set_union_elim in H3; try destruct H3; simpl in H3; trivial;
  apply set_union_elim in H3; destruct H3;
  apply Problem_vars_set_In
  with (X:=Y) in H0; simpl; trivial.
  apply set_union_intro1; apply set_union_intro1; trivial.
  apply set_union_intro2; apply set_union_intro1; trivial.
  apply set_union_intro1; apply set_union_intro2; trivial.
  apply set_union_intro2; apply set_union_intro2; trivial.

  apply set_inter_intro; trivial.
  apply Problem_vars_add in H3.
  apply set_union_elim in H3. destruct H3; trivial.
  apply Problem_vars_set_In
  with (X:=Y) in H0; simpl; trivial.

  apply set_inter_intro; trivial.
  apply Problem_vars_add in H3.
  apply set_union_elim in H3. destruct H3.
  apply Problem_vars_add in H3.
  apply set_union_elim in H3. destruct H3; trivial.
  simpl in H3. apply Problem_vars_set_In
  with (X:=Y) in H0; simpl; trivial.
  apply set_union_elim in H3. destruct H3.
  apply set_union_intro1. apply set_union_intro1; trivial.
  apply set_union_intro2. apply set_union_intro1; trivial.
  simpl in H3. apply Problem_vars_set_In
  with (X:=Y) in H0; simpl; trivial.
  apply set_union_elim in H3. destruct H3.
  apply set_union_intro1. apply set_union_intro2; trivial.
  apply set_union_intro2. apply set_union_intro2; trivial.

  apply set_inter_intro; trivial.
  apply Problem_vars_add in H3.
  apply set_union_elim in H3. destruct H3.
  apply Problem_vars_add in H3.
  apply set_union_elim in H3. destruct H3; trivial.
  simpl in H3. apply Problem_vars_set_In
  with (X:=Y) in H0; simpl; trivial.
  apply set_union_elim in H3. destruct H3.
  apply set_union_intro1. apply set_union_intro1; trivial.
  apply set_union_intro2. apply set_union_intro2; trivial.
  simpl in H3. apply Problem_vars_set_In
  with (X:=Y) in H0; simpl; trivial.
  apply set_union_elim in H3. destruct H3.
  apply set_union_intro1. apply set_union_intro2; trivial.
  apply set_union_intro2. apply set_union_intro1; trivial.

  apply set_inter_intro; trivial.
  apply Problem_vars_add in H3.
  apply set_union_elim in H3. destruct H3; trivial.
  apply Problem_vars_set_In
  with (X:=Y) in H0; simpl; trivial.

  apply set_inter_intro; trivial.
  apply Problem_vars_add in H3;
  apply set_union_elim in H3; destruct H3;
  try apply Problem_vars_add in H3;
  try apply set_union_elim in H3; try destruct H3; simpl in H3; trivial;
  try apply set_union_elim in H3; try destruct H3;
  apply Problem_vars_set_In
  with (X:=Y) in H4; simpl; trivial.
  apply set_union_intro1; trivial.
  rewrite perm_term_vars in H3.
  apply set_union_intro2; trivial.
  apply set_union_intro2; trivial.

  apply Problem_vars_union in H3.
  apply set_union_elim in H3. destruct H3.
  rewrite H5 in H2. apply In_dom_eq_dom_rec in H2.
  apply dom_comp_add1 in H2. destruct H2.
  rewrite H2 in H3. apply In_im_subst_term_Problem in H3.
  autorewrite with perm in H3.
  false. apply H0. apply set_union_intro1; trivial.

  apply In_im_subst_term_Problem' in H3.
  apply set_union_elim in H3. destruct H3.
  repeat apply Problem_vars_remove in H3.
  apply set_inter_intro; trivial.
  apply In_dom_eq_dom_rec; trivial.
  autorewrite with perm in H3.
  destruct H4; apply Problem_vars_set_In
  with (X:=Y) in H4; simpl; trivial.
  apply set_inter_intro; trivial.
  apply In_dom_eq_dom_rec; trivial.
  apply set_union_intro2; trivial.
  apply set_inter_intro; trivial.
  apply In_dom_eq_dom_rec; trivial.
  apply set_add_intro1; trivial.
  apply subs_fresh_vars_im in H3.
  assert (Q:  set_inter var_eqdec (dom_rec S') (im_vars S') = []).
   replace S' with (snd (fst (C,S',((P\(pi|.X~?t)\(t~?(pi|.X)))|^^((X,(!pi)@t)::nil))\cup(C/?S')))).
   apply equ_valid_preservation_aux with (T := (C,S,P)) (varSet := varSet).
   unfold valid_triple. simpl. split~.
   apply equ_sys_inst; trivial.
   simpl; trivial.
  apply set_inter_nil with (a:=Y) in Q.
  simpl. false. apply Q. apply set_inter_intro; trivial.

  apply set_inter_intro; trivial.
  apply Problem_vars_add in H3.
  apply set_union_elim in H3. destruct H3; trivial.
  apply Problem_vars_set_In
  with (X:=Y) in H5; simpl; trivial.

Qed.

Lemma unif_step_valid_preserv : forall T T' varSet,
      valid_triple T -> unif_step varSet T T' -> valid_triple T'.
Proof.
  intros. destruct H0.
  apply equ_valid_preservation with (T:=T) (varSet:=varSet); trivial.
  apply fresh_valid_preservation with (T:=T); trivial.
Qed.

Lemma unif_path_valid_preserv : forall T T' varSet,
      valid_triple T -> unif_path varSet T T' -> valid_triple T'.
Proof.
  intros. destruct H0. induction H0; trivial.
  apply unif_step_valid_preserv with (T := s) (varSet:=varSet); trivial.
  apply IHtr_clos; trivial.
  apply unif_step_valid_preserv with (T := s) (varSet:=varSet); trivial.
Qed.