(* First-Order Formulas *)

(* with arity checks *)

From Quantifiers Require Export foterms_ar.

Set Implicit Arguments.

(** * First-Order Formulas *)

Section Formulas.

Context {vatom : DecType} {tatom : Type} {tarity : tatom -> nat}.
Notation term := (@term vatom tatom tarity).
Arguments evar _ _ _ {T}.
Notation evar := (evar vatom tatom tarity).

Notation "r ;; s" := (fecomp r s) (at level 20, format "r  ;;  s").
Notation closed t := (tvars t = nil).
Notation "⇑" := fup.
Notation "⇑[ u ] r" := (felift u r) (at level 25, format "⇑[ u ] r").

Hint Rewrite (@tesubs_evar vatom tatom) : term_db.
Hint Rewrite (@tesubs_comp vatom tatom) : term_db.
Hint Rewrite (@tsubs_tsubs_eq vatom tatom) : term_db.
Hint Rewrite (@tsubs_tsubs vatom tatom)
                        using try (intuition; fail);
                             (try apply closed_notvars); intuition; fail : term_db.
Hint Rewrite (@tvars_tesubs_closed vatom tatom) using intuition; fail : term_db.
Hint Rewrite (@tvars_tsubs_closed vatom tatom) using intuition; fail : term_db.
Hint Rewrite (@notin_tsubs vatom tatom)
                         using try easy;
                              (try (intuition; fail));
                              (try apply closed_notvars); intuition; fail : term_db.
Hint Rewrite (@notin_tsubs_bivar vatom tatom)
                               using try easy;
                                    (try (intuition; fail));
                                    (try apply closed_notvars); intuition; fail : term_db.
Hint Rewrite (@tsubs_tesubs vatom tatom) using try (intuition; fail) : term_db.

Hint Resolve tesubs_ext : term_db.
Hint Resolve closed_notvars : term_db.

Context {fatom : Type}.  (* relation symbols for [formula] *)
Context {farity : fatom -> nat}.  (* arity of relation symbols *)
(* Generic sets of connectives *)
Context {NCon : Type}. (* nullary connectives *)
Context {UCon : Type}. (* unary connectives *)
Context {BCon : Type}. (* binary connectives *)
Context {QCon : Type}. (* quantifiers *)

(** formulas *)
(** first-order formulas *)
Inductive formula T : nat -> Type :=
| frel X : formula T (farity X)
| fconstr (t : term T 0) {k} : formula T (S k) -> formula T k
| fnul : NCon -> formula T 0
| funa : UCon -> formula T 0 -> formula T 0
| fbin : BCon -> formula T 0 -> formula T 0 -> formula T 0
| fqtf : QCon -> vatom -> formula T 0 -> formula T 0.
Arguments frel {T} _.
Arguments fnul {T} _.
(* Nullary connectives in [NCon] and [fnul] are mostly redundant with [fvar f nil] *)

Ltac formula_induction A :=
  try (intros until A); (* to avoid name clashes in induction t *)
  let XX := fresh "X" in
  let xx := fresh "x" in
  let ncon := fresh "ncon" in
  let ucon := fresh "ucon" in
  let bcon := fresh "bcon" in
  let qcon := fresh "qcon" in
  let A1 := fresh A in
  let A2 := fresh A in
  let BB := fresh "B" in
  let lll := fresh "l" in
  let tt := fresh "t" in
  induction A as [ XX | tt BB | ncon | ucon A ? | bcon A1 ? A2 ? | qcon xx A ]; simpl; intros;
  [ try ((try f_equal); intuition; fail)
  | try (apply (f_equal2 (fun x y => fconstr x y))); intuition
  | try ((try f_equal); intuition; fail)
  | try (apply (f_equal (funa _))); intuition
  | try (apply (f_equal2 (fbin _))); intuition
  | (try apply (f_equal (fqtf _ _))); repeat case_analysis; try (intuition; fail);
     try (now rcauto) ];
  try (now rcauto).

(** * Size of [formula] *)

Fixpoint fsize T k (A : formula T k) :=
match A with
| frel _ => 1
| fconstr _ _ => 1
| fnul _ => 1
| funa _ B => S (fsize B)
| fbin _ B C => S (fsize B + fsize C)
| fqtf _ _ B => S (fsize B)
end.

(** * Substitution of eigen variables in [formula] *)

(** substitutes the [term] [r n] for index [n] in [formula] [A] *)
(* capture is not avoided *)
Fixpoint esubs T1 T2 k (r : T1 -> term T2 0) (A : formula T1 k) : formula T2 k :=
match A with
| frel X => frel X
| fconstr t B => fconstr ((tesubs r) t) (esubs r B)
| fnul ncon => fnul ncon
| funa ucon B => funa ucon (esubs r B)
| fbin bcon B C => fbin bcon (esubs r B) (esubs r C)
| fqtf qcon x B => fqtf qcon x (esubs r B)
end.
Notation "A ⟦ r ⟧" := (esubs r A) (at level 8, left associativity, format "A ⟦ r ⟧").

Lemma fsize_esubs T1 T2 k : forall (r : T1 -> term T2 0) (A : formula T1 k), fsize A⟦r⟧ = fsize A.
Proof. formula_induction A. Qed.
Hint Rewrite fsize_esubs : term_db.

Lemma esubs_evar T k : forall (A : formula T k),
  A⟦evar⟧ = A.
Proof. formula_induction A. Qed.
Hint Rewrite esubs_evar : term_db.

Lemma esubs_comp T1 T2 T3 k (r : T1 -> term T2 0) (s : T2 -> term T3 0) :
  forall A : formula T1 k, A⟦r⟧⟦s⟧ = A⟦r ;; s⟧.
Proof. formula_induction A. Qed.
Hint Rewrite esubs_comp : term_db.

(* the result of substitution depends extensionnaly on the substituting function *)
Lemma esubs_ext T1 T2 k (r1 r2 : T1 -> term T2 0) : r1 ~ r2 -> forall A : formula T1 k, A⟦r1⟧ = A⟦r2⟧.
Proof. formula_induction A. Qed.

(** * Formula substitution *)

(** substitutes [term] [u] for variable [x] in [formula] [A] *)
(* capture is not avoided *)
Fixpoint subs T k x u (A : formula T k) : formula T k :=
match A with
| frel X => frel X
| fconstr t B => fconstr (tsubs x u t) (subs x u B)
| fnul ncon => fnul ncon
| funa ucon B => funa ucon (subs x u B)
| fbin bcon B C => fbin bcon (subs x u B) (subs x u C)
| fqtf qcon y B => fqtf qcon y (if eq_dt_dec y x then B else subs x u B)
end.
Notation "A [ u // x ]" := (subs x u A) (at level 8, format "A [ u // x ]").

Lemma fsize_subs T k : forall u x (A : formula T k), fsize A[u//x] = fsize A.
Proof. formula_induction A. Qed.
Hint Rewrite fsize_subs : term_db.

(** * Additional results with variable eigen type *)

Lemma subs_esubs T1 T2 k (r : T1 -> term T2 0): forall x u (A : formula T1 k),
  (forall n, closed (r n)) -> A[u//x]⟦r⟧ = A⟦r⟧[tesubs r u//x].
Proof. formula_induction A. Qed.
Hint Rewrite subs_esubs using intuition; fail : term_db.

(* We restrict to [formula nat] *)
(** * Eigen variables *)

Notation "A ↑" := (A⟦⇑⟧) (at level 8, format "A ↑").
Notation "v ⇓" := (fesubs v) (at level 18, format "v ⇓").

Lemma esubs_fup k v (A : formula nat k) : A↑⟦v⇓⟧ = A.
Proof. rcauto. Qed.
Hint Rewrite esubs_fup : term_db.

Lemma felift_esubs k u r (A : formula nat k) : A↑⟦⇑[u]r⟧ = A⟦r⟧↑.
Proof. rcauto. Qed.
Hint Rewrite felift_esubs : term_db.

End Formulas.

(* Some sets of connectives *)
Inductive Nocon := .
Inductive Icon := imp_con.
Inductive Qcon := frl_con | exs_con.

Notation imp := (fbin imp_con).
Notation frl := (fqtf frl_con).
Notation exs := (fqtf exs_con).

Ltac formula_induction A :=
  try (intros until A); (* to avoid name clashes in induction t *)
  let XX := fresh "X" in
  let xx := fresh "x" in
  let ncon := fresh "ncon" in
  let ucon := fresh "ucon" in
  let bcon := fresh "bcon" in
  let qcon := fresh "qcon" in
  let A1 := fresh A in
  let A2 := fresh A in
  let BB := fresh "B" in
  let lll := fresh "l" in
  let tt := fresh "t" in
  induction A as [ XX | tt BB | ncon | ucon A ? | bcon A1 ? A2 ? | qcon xx A ]; simpl; intros;
  [ try ((try f_equal); intuition; fail)
  | try (apply (f_equal2 (fun x y => fconstr x y))); intuition
  | try ((try f_equal); intuition; fail)
  | try (apply (f_equal (funa _))); intuition
  | try (apply (f_equal2 (fbin _))); intuition
  | (try apply (f_equal (fqtf _ _))); repeat case_analysis; try (intuition; fail);
     try (now rcauto) ];
  try (now rcauto).


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

Require Import List.
Require Import Peano_dec.
Require Import LegacyRing.
Require Import LegacyField_Compl.

Record Field_Theory : Type :=
  {A : Type;
   Aplus : A -> A -> A;
   Amult : A -> A -> A;
   Aone : A;
   Azero : A;
   Aopp : A -> A;
   Aeq : A -> A -> bool;
   Ainv : A -> A;
   Aminus : option (A -> A -> A);
   Adiv : option (A -> A -> A);
   RT : Ring_Theory Aplus Amult Aone Azero Aopp Aeq;
   Th_inv_def : forall n:A, n <> Azero -> Amult (Ainv n) n = Aone}.

(* The reflexion structure *)
Inductive ExprA : Set :=
  | EAzero : ExprA
  | EAone : ExprA
  | EAplus : ExprA -> ExprA -> ExprA
  | EAmult : ExprA -> ExprA -> ExprA
  | EAopp : ExprA -> ExprA
  | EAinv : ExprA -> ExprA
  | EAvar : nat -> ExprA.

(**** Decidability of equality ****)

Lemma eqExprA_O : forall e1 e2:ExprA, {e1 = e2} + {e1 <> e2}.
Proof.
  double induction e1 e2; try intros;
   try (left; reflexivity) || (try (right; discriminate)).
  elim (H1 e0); intro y; elim (H2 e); intro y0;
   try
    (left; rewrite y; rewrite y0; auto) ||
      (right; red in |- *; intro; inversion H3; auto).
  elim (H1 e0); intro y; elim (H2 e); intro y0;
   try
    (left; rewrite y; rewrite y0; auto) ||
      (right; red in |- *; intro; inversion H3; auto).
  elim (H0 e); intro y.
  left; rewrite y; auto.
  right; red in |- *; intro; inversion H1; auto.
  elim (H0 e); intro y.
  left; rewrite y; auto.
  right; red in |- *; intro; inversion H1; auto.
  elim (eq_nat_dec n n0); intro y.
  left; rewrite y; auto.
  right; red in |- *; intro; inversion H; auto.
Defined.

Definition eq_nat_dec := Eval compute in eq_nat_dec.
Definition eqExprA := Eval compute in eqExprA_O.

(**** Generation of the multiplier ****)

Fixpoint mult_of_list (e:list ExprA) : ExprA :=
  match e with
  | nil => EAone
  | e1 :: l1 => EAmult e1 (mult_of_list l1)
  end.

Section Theory_of_fields.

Variable T : Field_Theory.

Let AT := A T.
Let AplusT := Aplus T.
Let AmultT := Amult T.
Let AoneT := Aone T.
Let AzeroT := Azero T.
Let AoppT := Aopp T.
Let AeqT := Aeq T.
Let AinvT := Ainv T.
Let RTT := RT T.
Let Th_inv_defT := Th_inv_def T.

Add Legacy Abstract Ring (A T) (Aplus T) (Amult T) (Aone T) (
 Azero T) (Aopp T) (Aeq T) (RT T).

Add Legacy Abstract Ring AT AplusT AmultT AoneT AzeroT AoppT AeqT RTT.

(***************************)
(*    Lemmas to be used    *)
(***************************)

Lemma AplusT_comm : forall r1 r2:AT, AplusT r1 r2 = AplusT r2 r1.
Proof.
  intros; legacy ring.
Qed.

Lemma AplusT_assoc :
 forall r1 r2 r3:AT, AplusT (AplusT r1 r2) r3 = AplusT r1 (AplusT r2 r3).
Proof.
  intros; legacy ring.
Qed.

Lemma AmultT_comm : forall r1 r2:AT, AmultT r1 r2 = AmultT r2 r1.
Proof.
  intros; legacy ring.
Qed.

Lemma AmultT_assoc :
 forall r1 r2 r3:AT, AmultT (AmultT r1 r2) r3 = AmultT r1 (AmultT r2 r3).
Proof.
  intros; legacy ring.
Qed.

Lemma AplusT_Ol : forall r:AT, AplusT AzeroT r = r.
Proof.
  intros; legacy ring.
Qed.

Lemma AmultT_1l : forall r:AT, AmultT AoneT r = r.
Proof.
  intros; legacy ring.
Qed.

Lemma AplusT_AoppT_r : forall r:AT, AplusT r (AoppT r) = AzeroT.
Proof.
  intros; legacy ring.
Qed.

Lemma AmultT_AplusT_distr :
 forall r1 r2 r3:AT,
   AmultT r1 (AplusT r2 r3) = AplusT (AmultT r1 r2) (AmultT r1 r3).
Proof.
  intros; legacy ring.
Qed.

Lemma r_AplusT_plus : forall r r1 r2:AT, AplusT r r1 = AplusT r r2 -> r1 = r2.
Proof.
  intros; transitivity (AplusT (AplusT (AoppT r) r) r1).
  legacy ring.
  transitivity (AplusT (AplusT (AoppT r) r) r2).
  repeat rewrite AplusT_assoc; rewrite <- H; reflexivity.
  legacy ring.
Qed.

Lemma r_AmultT_mult :
 forall r r1 r2:AT, AmultT r r1 = AmultT r r2 -> r <> AzeroT -> r1 = r2.
Proof.
  intros; transitivity (AmultT (AmultT (AinvT r) r) r1).
  rewrite Th_inv_defT; [ symmetry  in |- *; apply AmultT_1l; auto | auto ].
  transitivity (AmultT (AmultT (AinvT r) r) r2).
  repeat rewrite AmultT_assoc; rewrite H; trivial.
  rewrite Th_inv_defT; [ apply AmultT_1l; auto | auto ].
Qed.

Lemma AmultT_Or : forall r:AT, AmultT r AzeroT = AzeroT.
Proof.
  intro; legacy ring.
Qed.

Lemma AmultT_Ol : forall r:AT, AmultT AzeroT r = AzeroT.
Proof.
  intro; legacy ring.
Qed.

Lemma AmultT_1r : forall r:AT, AmultT r AoneT = r.
Proof.
  intro; legacy ring.
Qed.

Lemma AinvT_r : forall r:AT, r <> AzeroT -> AmultT r (AinvT r) = AoneT.
Proof.
  intros; rewrite AmultT_comm; apply Th_inv_defT; auto.
Qed.

Lemma Rmult_neq_0_reg :
 forall r1 r2:AT, AmultT r1 r2 <> AzeroT -> r1 <> AzeroT /\ r2 <> AzeroT.
Proof.
  intros r1 r2 H; split; red in |- *; intro; apply H; rewrite H0; legacy ring.
Qed.

(************************)
(*    Interpretation    *)
(************************)

(**** ExprA --> A ****)

Fixpoint interp_ExprA (lvar:list (AT * nat)) (e:ExprA) {struct e} :
 AT :=
  match e with
  | EAzero => AzeroT
  | EAone => AoneT
  | EAplus e1 e2 => AplusT (interp_ExprA lvar e1) (interp_ExprA lvar e2)
  | EAmult e1 e2 => AmultT (interp_ExprA lvar e1) (interp_ExprA lvar e2)
  | EAopp e => Aopp T (interp_ExprA lvar e)
  | EAinv e => Ainv T (interp_ExprA lvar e)
  | EAvar n => assoc_2nd AT nat eq_nat_dec lvar n AzeroT
  end.

(************************)
(*    Simplification    *)
(************************)

(**** Associativity ****)

Definition merge_mult :=
  (fix merge_mult (e1:ExprA) : ExprA -> ExprA :=
     fun e2:ExprA =>
       match e1 with
       | EAmult t1 t2 =>
           match t2 with
           | EAmult t2 t3 => EAmult t1 (EAmult t2 (merge_mult t3 e2))
           | _ => EAmult t1 (EAmult t2 e2)
           end
       | _ => EAmult e1 e2
       end).

Fixpoint assoc_mult (e:ExprA) : ExprA :=
  match e with
  | EAmult e1 e3 =>
      match e1 with
      | EAmult e1 e2 =>
          merge_mult (merge_mult (assoc_mult e1) (assoc_mult e2))
            (assoc_mult e3)
      | _ => EAmult e1 (assoc_mult e3)
      end
  | _ => e
  end.

Definition merge_plus :=
  (fix merge_plus (e1:ExprA) : ExprA -> ExprA :=
     fun e2:ExprA =>
       match e1 with
       | EAplus t1 t2 =>
           match t2 with
           | EAplus t2 t3 => EAplus t1 (EAplus t2 (merge_plus t3 e2))
           | _ => EAplus t1 (EAplus t2 e2)
           end
       | _ => EAplus e1 e2
       end).

Fixpoint assoc (e:ExprA) : ExprA :=
  match e with
  | EAplus e1 e3 =>
      match e1 with
      | EAplus e1 e2 =>
          merge_plus (merge_plus (assoc e1) (assoc e2)) (assoc e3)
      | _ => EAplus (assoc_mult e1) (assoc e3)
      end
  | _ => assoc_mult e
  end.

Lemma merge_mult_correct1 :
 forall (e1 e2 e3:ExprA) (lvar:list (AT * nat)),
   interp_ExprA lvar (merge_mult (EAmult e1 e2) e3) =
   interp_ExprA lvar (EAmult e1 (merge_mult e2 e3)).
Proof.
intros e1 e2; generalize e1; generalize e2; clear e1 e2.
simple induction e2; auto; intros.
unfold merge_mult at 1 in |- *; fold merge_mult in |- *;
 unfold interp_ExprA at 2 in |- *; fold interp_ExprA in |- *;
 rewrite (H0 e e3 lvar); unfold interp_ExprA at 1 in |- *;
 fold interp_ExprA in |- *; unfold interp_ExprA at 5 in |- *;
 fold interp_ExprA in |- *; auto.
Qed.

Lemma merge_mult_correct :
 forall (e1 e2:ExprA) (lvar:list (AT * nat)),
   interp_ExprA lvar (merge_mult e1 e2) = interp_ExprA lvar (EAmult e1 e2).
Proof.
simple induction e1; auto; intros.
elim e0; try (intros; simpl in |- *; legacy ring).
unfold interp_ExprA in H2; fold interp_ExprA in H2;
 cut
  (AmultT (interp_ExprA lvar e2)
     (AmultT (interp_ExprA lvar e4)
        (AmultT (interp_ExprA lvar e) (interp_ExprA lvar e3))) =
   AmultT
     (AmultT (AmultT (interp_ExprA lvar e) (interp_ExprA lvar e4))
        (interp_ExprA lvar e2)) (interp_ExprA lvar e3)).
intro H3; rewrite H3; rewrite <- H2; rewrite merge_mult_correct1;
 simpl in |- *; legacy ring.
legacy ring.
Qed.

Lemma assoc_mult_correct1 :
 forall (e1 e2:ExprA) (lvar:list (AT * nat)),
   AmultT (interp_ExprA lvar (assoc_mult e1))
     (interp_ExprA lvar (assoc_mult e2)) =
   interp_ExprA lvar (assoc_mult (EAmult e1 e2)).
Proof.
simple induction e1; auto; intros.
rewrite <- (H e0 lvar); simpl in |- *; rewrite merge_mult_correct;
 simpl in |- *; rewrite merge_mult_correct; simpl in |- *;
 auto.
Qed.

Lemma assoc_mult_correct :
 forall (e:ExprA) (lvar:list (AT * nat)),
   interp_ExprA lvar (assoc_mult e) = interp_ExprA lvar e.
Proof.
simple induction e; auto; intros.
elim e0; intros.
intros; simpl in |- *; legacy ring.
simpl in |- *; rewrite (AmultT_1l (interp_ExprA lvar (assoc_mult e1)));
 rewrite (AmultT_1l (interp_ExprA lvar e1)); apply H0.
simpl in |- *; rewrite (H0 lvar); auto.
simpl in |- *; rewrite merge_mult_correct; simpl in |- *;
 rewrite merge_mult_correct; simpl in |- *; rewrite AmultT_assoc;
 rewrite assoc_mult_correct1; rewrite H2; simpl in |- *;
 rewrite <- assoc_mult_correct1 in H1; unfold interp_ExprA at 3 in H1;
 fold interp_ExprA in H1; rewrite (H0 lvar) in H1;
 rewrite (AmultT_comm (interp_ExprA lvar e3) (interp_ExprA lvar e1));
 rewrite <- AmultT_assoc; rewrite H1; rewrite AmultT_assoc;
 legacy ring.
simpl in |- *; rewrite (H0 lvar); auto.
simpl in |- *; rewrite (H0 lvar); auto.
simpl in |- *; rewrite (H0 lvar); auto.
Qed.

Lemma merge_plus_correct1 :
 forall (e1 e2 e3:ExprA) (lvar:list (AT * nat)),
   interp_ExprA lvar (merge_plus (EAplus e1 e2) e3) =
   interp_ExprA lvar (EAplus e1 (merge_plus e2 e3)).
Proof.
intros e1 e2; generalize e1; generalize e2; clear e1 e2.
simple induction e2; auto; intros.
unfold merge_plus at 1 in |- *; fold merge_plus in |- *;
 unfold interp_ExprA at 2 in |- *; fold interp_ExprA in |- *;
 rewrite (H0 e e3 lvar); unfold interp_ExprA at 1 in |- *;
 fold interp_ExprA in |- *; unfold interp_ExprA at 5 in |- *;
 fold interp_ExprA in |- *; auto.
Qed.

Lemma merge_plus_correct :
 forall (e1 e2:ExprA) (lvar:list (AT * nat)),
   interp_ExprA lvar (merge_plus e1 e2) = interp_ExprA lvar (EAplus e1 e2).
Proof.
simple induction e1; auto; intros.
elim e0; try intros; try (simpl in |- *; legacy ring).
unfold interp_ExprA in H2; fold interp_ExprA in H2;
 cut
  (AplusT (interp_ExprA lvar e2)
     (AplusT (interp_ExprA lvar e4)
        (AplusT (interp_ExprA lvar e) (interp_ExprA lvar e3))) =
   AplusT
     (AplusT (AplusT (interp_ExprA lvar e) (interp_ExprA lvar e4))
        (interp_ExprA lvar e2)) (interp_ExprA lvar e3)).
intro H3; rewrite H3; rewrite <- H2; rewrite merge_plus_correct1;
 simpl in |- *; legacy ring.
legacy ring.
Qed.

Lemma assoc_plus_correct :
 forall (e1 e2:ExprA) (lvar:list (AT * nat)),
   AplusT (interp_ExprA lvar (assoc e1)) (interp_ExprA lvar (assoc e2)) =
   interp_ExprA lvar (assoc (EAplus e1 e2)).
Proof.
simple induction e1; auto; intros.
rewrite <- (H e0 lvar); simpl in |- *; rewrite merge_plus_correct;
 simpl in |- *; rewrite merge_plus_correct; simpl in |- *;
 auto.
Qed.

Lemma assoc_correct :
 forall (e:ExprA) (lvar:list (AT * nat)),
   interp_ExprA lvar (assoc e) = interp_ExprA lvar e.
Proof.
simple induction e; auto; intros.
elim e0; intros.
simpl in |- *; rewrite (H0 lvar); auto.
simpl in |- *; rewrite (H0 lvar); auto.
simpl in |- *; rewrite merge_plus_correct; simpl in |- *;
 rewrite merge_plus_correct; simpl in |- *; rewrite AplusT_assoc;
 rewrite assoc_plus_correct; rewrite H2; simpl in |- *;
 apply
  (r_AplusT_plus (interp_ExprA lvar (assoc e1))
     (AplusT (interp_ExprA lvar (assoc e2))
        (AplusT (interp_ExprA lvar e3) (interp_ExprA lvar e1)))
     (AplusT (AplusT (interp_ExprA lvar e2) (interp_ExprA lvar e3))
        (interp_ExprA lvar e1))); rewrite <- AplusT_assoc;
 rewrite
  (AplusT_comm (interp_ExprA lvar (assoc e1)) (interp_ExprA lvar (assoc e2)))
  ; rewrite assoc_plus_correct; rewrite H1; simpl in |- *;
 rewrite (H0 lvar);
 rewrite <-
  (AplusT_assoc (AplusT (interp_ExprA lvar e2) (interp_ExprA lvar e1))
     (interp_ExprA lvar e3) (interp_ExprA lvar e1))
  ;
 rewrite
  (AplusT_assoc (interp_ExprA lvar e2) (interp_ExprA lvar e1)
     (interp_ExprA lvar e3));
 rewrite (AplusT_comm (interp_ExprA lvar e1) (interp_ExprA lvar e3));
 rewrite <-
  (AplusT_assoc (interp_ExprA lvar e2) (interp_ExprA lvar e3)
     (interp_ExprA lvar e1)); apply AplusT_comm.
unfold assoc in |- *; fold assoc in |- *; unfold interp_ExprA in |- *;
 fold interp_ExprA in |- *; rewrite assoc_mult_correct;
 rewrite (H0 lvar); simpl in |- *; auto.
simpl in |- *; rewrite (H0 lvar); auto.
simpl in |- *; rewrite (H0 lvar); auto.
simpl in |- *; rewrite (H0 lvar); auto.
unfold assoc in |- *; fold assoc in |- *; unfold interp_ExprA in |- *;
 fold interp_ExprA in |- *; rewrite assoc_mult_correct;
 simpl in |- *; auto.
Qed.

(**** Distribution *****)

Fixpoint distrib_EAopp (e:ExprA) : ExprA :=
  match e with
  | EAplus e1 e2 => EAplus (distrib_EAopp e1) (distrib_EAopp e2)
  | EAmult e1 e2 => EAmult (distrib_EAopp e1) (distrib_EAopp e2)
  | EAopp e => EAmult (EAopp EAone) (distrib_EAopp e)
  | e => e
  end.

Definition distrib_mult_right :=
  (fix distrib_mult_right (e1:ExprA) : ExprA -> ExprA :=
     fun e2:ExprA =>
       match e1 with
       | EAplus t1 t2 =>
           EAplus (distrib_mult_right t1 e2) (distrib_mult_right t2 e2)
       | _ => EAmult e1 e2
       end).

Fixpoint distrib_mult_left (e1 e2:ExprA) {struct e1} : ExprA :=
  match e1 with
  | EAplus t1 t2 =>
      EAplus (distrib_mult_left t1 e2) (distrib_mult_left t2 e2)
  | _ => distrib_mult_right e2 e1
  end.

Fixpoint distrib_main (e:ExprA) : ExprA :=
  match e with
  | EAmult e1 e2 => distrib_mult_left (distrib_main e1) (distrib_main e2)
  | EAplus e1 e2 => EAplus (distrib_main e1) (distrib_main e2)
  | EAopp e => EAopp (distrib_main e)
  | _ => e
  end.

Definition distrib (e:ExprA) : ExprA := distrib_main (distrib_EAopp e).

Lemma distrib_mult_right_correct :
 forall (e1 e2:ExprA) (lvar:list (AT * nat)),
   interp_ExprA lvar (distrib_mult_right e1 e2) =
   AmultT (interp_ExprA lvar e1) (interp_ExprA lvar e2).
Proof.
simple induction e1; try intros; simpl in |- *; auto.
rewrite AmultT_comm; rewrite AmultT_AplusT_distr; rewrite (H e2 lvar);
 rewrite (H0 e2 lvar); legacy ring.
Qed.

Lemma distrib_mult_left_correct :
 forall (e1 e2:ExprA) (lvar:list (AT * nat)),
   interp_ExprA lvar (distrib_mult_left e1 e2) =
   AmultT (interp_ExprA lvar e1) (interp_ExprA lvar e2).
Proof.
simple induction e1; try intros; simpl in |- *.
rewrite AmultT_Ol; rewrite distrib_mult_right_correct; simpl in |- *;
 apply AmultT_Or.
rewrite distrib_mult_right_correct; simpl in |- *; apply AmultT_comm.
rewrite AmultT_comm;
 rewrite
  (AmultT_AplusT_distr (interp_ExprA lvar e2) (interp_ExprA lvar e)
     (interp_ExprA lvar e0));
 rewrite (AmultT_comm (interp_ExprA lvar e2) (interp_ExprA lvar e));
 rewrite (AmultT_comm (interp_ExprA lvar e2) (interp_ExprA lvar e0));
 rewrite (H e2 lvar); rewrite (H0 e2 lvar); auto.
rewrite distrib_mult_right_correct; simpl in |- *; apply AmultT_comm.
rewrite distrib_mult_right_correct; simpl in |- *; apply AmultT_comm.
rewrite distrib_mult_right_correct; simpl in |- *; apply AmultT_comm.
rewrite distrib_mult_right_correct; simpl in |- *; apply AmultT_comm.
Qed.

Lemma distrib_correct :
 forall (e:ExprA) (lvar:list (AT * nat)),
   interp_ExprA lvar (distrib e) = interp_ExprA lvar e.
Proof.
simple induction e; intros; auto.
simpl in |- *; rewrite <- (H lvar); rewrite <- (H0 lvar);
 unfold distrib in |- *; simpl in |- *; auto.
simpl in |- *; rewrite <- (H lvar); rewrite <- (H0 lvar);
 unfold distrib in |- *; simpl in |- *; apply distrib_mult_left_correct.
simpl in |- *; fold AoppT in |- *; rewrite <- (H lvar);
 unfold distrib in |- *; simpl in |- *; rewrite distrib_mult_right_correct;
 simpl in |- *; fold AoppT in |- *; legacy ring.
Qed.

(**** Multiplication by the inverse product ****)

Lemma mult_eq :
 forall (e1 e2 a:ExprA) (lvar:list (AT * nat)),
   interp_ExprA lvar a <> AzeroT ->
   interp_ExprA lvar (EAmult a e1) = interp_ExprA lvar (EAmult a e2) ->
   interp_ExprA lvar e1 = interp_ExprA lvar e2.
Proof.
  simpl in |- *; intros;
   apply
    (r_AmultT_mult (interp_ExprA lvar a) (interp_ExprA lvar e1)
       (interp_ExprA lvar e2)); assumption.
Qed.

Fixpoint multiply_aux (a e:ExprA) {struct e} : ExprA :=
  match e with
  | EAplus e1 e2 => EAplus (EAmult a e1) (multiply_aux a e2)
  | _ => EAmult a e
  end.

Definition multiply (e:ExprA) : ExprA :=
  match e with
  | EAmult a e1 => multiply_aux a e1
  | _ => e
  end.

Lemma multiply_aux_correct :
 forall (a e:ExprA) (lvar:list (AT * nat)),
   interp_ExprA lvar (multiply_aux a e) =
   AmultT (interp_ExprA lvar a) (interp_ExprA lvar e).
Proof.
simple induction e; simpl in |- *; intros; try rewrite merge_mult_correct;
 auto.
  simpl in |- *; rewrite (H0 lvar); legacy ring.
Qed.

Lemma multiply_correct :
 forall (e:ExprA) (lvar:list (AT * nat)),
   interp_ExprA lvar (multiply e) = interp_ExprA lvar e.
Proof.
  simple induction e; simpl in |- *; auto.
  intros; apply multiply_aux_correct.
Qed.

(**** Permutations and simplification ****)

Fixpoint monom_remove (a m:ExprA) {struct m} : ExprA :=
  match m with
  | EAmult m0 m1 =>
      match eqExprA m0 (EAinv a) with
      | left _ => m1
      | right _ => EAmult m0 (monom_remove a m1)
      end
  | _ =>
      match eqExprA m (EAinv a) with
      | left _ => EAone
      | right _ => EAmult a m
      end
  end.

Definition monom_simplif_rem :=
  (fix monom_simplif_rem (a:ExprA) : ExprA -> ExprA :=
     fun m:ExprA =>
       match a with
       | EAmult a0 a1 => monom_simplif_rem a1 (monom_remove a0 m)
       | _ => monom_remove a m
       end).

Definition monom_simplif (a m:ExprA) : ExprA :=
  match m with
  | EAmult a' m' =>
      match eqExprA a a' with
      | left _ => monom_simplif_rem a m'
      | right _ => m
      end
  | _ => m
  end.

Fixpoint inverse_simplif (a e:ExprA) {struct e} : ExprA :=
  match e with
  | EAplus e1 e2 => EAplus (monom_simplif a e1) (inverse_simplif a e2)
  | _ => monom_simplif a e
  end.

Lemma monom_remove_correct :
 forall (e a:ExprA) (lvar:list (AT * nat)),
   interp_ExprA lvar a <> AzeroT ->
   interp_ExprA lvar (monom_remove a e) =
   AmultT (interp_ExprA lvar a) (interp_ExprA lvar e).
Proof.
simple induction e; intros.
simpl in |- *; case (eqExprA EAzero (EAinv a)); intros;
 [ inversion e0 | simpl in |- *; trivial ].
simpl in |- *; case (eqExprA EAone (EAinv a)); intros;
 [ inversion e0 | simpl in |- *; trivial ].
simpl in |- *; case (eqExprA (EAplus e0 e1) (EAinv a)); intros;
 [ inversion e2 | simpl in |- *; trivial ].
simpl in |- *; case (eqExprA e0 (EAinv a)); intros.
rewrite e2; simpl in |- *; fold AinvT in |- *.
rewrite <-
 (AmultT_assoc (interp_ExprA lvar a) (AinvT (interp_ExprA lvar a))
    (interp_ExprA lvar e1)); rewrite AinvT_r; [ legacy ring | assumption ].
simpl in |- *; rewrite H0; auto; legacy ring.
simpl in |- *; fold AoppT in |- *; case (eqExprA (EAopp e0) (EAinv a));
 intros; [ inversion e1 | simpl in |- *; trivial ].
unfold monom_remove in |- *; case (eqExprA (EAinv e0) (EAinv a)); intros.
case (eqExprA e0 a); intros.
rewrite e2; simpl in |- *; fold AinvT in |- *; rewrite AinvT_r; auto.
inversion e1; simpl in |- *; exfalso; auto.
simpl in |- *; trivial.
unfold monom_remove in |- *; case (eqExprA (EAvar n) (EAinv a)); intros;
 [ inversion e0 | simpl in |- *; trivial ].
Qed.

Lemma monom_simplif_rem_correct :
 forall (a e:ExprA) (lvar:list (AT * nat)),
   interp_ExprA lvar a <> AzeroT ->
   interp_ExprA lvar (monom_simplif_rem a e) =
   AmultT (interp_ExprA lvar a) (interp_ExprA lvar e).
Proof.
simple induction a; simpl in |- *; intros; try rewrite monom_remove_correct;
 auto.
elim (Rmult_neq_0_reg (interp_ExprA lvar e) (interp_ExprA lvar e0) H1);
 intros.
rewrite (H0 (monom_remove e e1) lvar H3); rewrite monom_remove_correct; auto.
legacy ring.
Qed.

Lemma monom_simplif_correct :
 forall (e a:ExprA) (lvar:list (AT * nat)),
   interp_ExprA lvar a <> AzeroT ->
   interp_ExprA lvar (monom_simplif a e) = interp_ExprA lvar e.
Proof.
simple induction e; intros; auto.
simpl in |- *; case (eqExprA a e0); intros.
rewrite <- e2; apply monom_simplif_rem_correct; auto.
simpl in |- *; trivial.
Qed.

Lemma inverse_correct :
 forall (e a:ExprA) (lvar:list (AT * nat)),
   interp_ExprA lvar a <> AzeroT ->
   interp_ExprA lvar (inverse_simplif a e) = interp_ExprA lvar e.
Proof.
simple induction e; intros; auto.
simpl in |- *; rewrite (H0 a lvar H1); rewrite monom_simplif_correct; auto.
unfold inverse_simplif in |- *; rewrite monom_simplif_correct; auto.
Qed.

End Theory_of_fields.

(* Compatibility *)
Notation AplusT_sym := AplusT_comm (only parsing).
Notation AmultT_sym := AmultT_comm (only parsing).


Require Coq.Vectors.Vector.
Import Vectors.VectorDef.VectorNotations.

Set Implicit Arguments.
Set Asymmetric Patterns.

Definition Vector_caseS'
           {A'} (Q : nat -> Type)
           (P : forall {n} (v : Vector.t A' (S n)), Q n -> Type)
           (H : forall h {n} t q, @P n (h :: t) q) {n} (v: Vector.t A' (S n))
           (q : Q n)
: P v q.
Proof.
  specialize (fun h t => H h _ t q).
  change n with (pred (S n)) in H, q |- *.
  set (Sn := S n) in *.
  pose (fun Sn (v : Vector.t A' Sn) (q : Q (pred Sn)) =>
          match Sn return Vector.t A' Sn -> Q (pred Sn) -> Type with
            | S n' => P n'
            | 0 => fun _ _ => True
          end v q) as P'.
  change (match Sn return Type with
            | 0 => True
            | _ => P' Sn v q
          end).
  change (forall h (t : match Sn with
                          | S n' => Vector.t A' n'
                          | 0 => Vector.t A' Sn
                        end),
            P' Sn (match Sn return match Sn with
                                     | S n' => Vector.t A' n'
                                     | 0 => Vector.t A' Sn
                                   end -> Vector.t A' Sn
                   with
                     | S _ => fun t => h :: t
                     | 0 => fun t => t
                   end t) q) in H.
  clearbody P'; clear P.
  clearbody Sn.
  destruct v as [|h ? t].
  { constructor. }
  { apply H. }
Defined.

Definition Vector_nth_map' A (f: A -> Type) (n: nat):
  forall v (p: Fin.t n),
    f (Vector.nth v p) ->
    Vector.nth (Vector.map f v) p.
Proof.
  induction p.
  - apply (Vector.caseS (fun n1 v1 => f (Vector.nth v1 Fin.F1) -> Vector.nth (Vector.map f v1) Fin.F1) (fun h n1 t => fun x => x) v).
  - apply (Vector.caseS (fun n1 v1 => forall p4, (forall v2, f (Vector.nth v2 p4) -> Vector.nth (Vector.map f v2) p4) ->
                                                 f (Vector.nth v1 (Fin.FS p4)) -> Vector.nth (Vector.map f v1) (Fin.FS p4))
                        (fun h n1 t p4 IHp2 =>
                           fun X => IHp2 t X)
                        v p IHp
          ).
Defined.

Definition Vector_nth_map A (f: A -> Type) n (v: Vector.t A n) p
           (m: f (Vector.nth v p)): Vector.nth (Vector.map f v) p := @Vector_nth_map' _ f n v p m.

Definition Vector_nth_map2_l' A B (g: A -> B) (f: B -> Type) n (v: Vector.t A n) (p: Fin.t n):
  (forall p: Fin.t n, Vector.nth (Vector.map (fun x => f (g x)) v) p) ->
  f (Vector.nth (Vector.map g v) p) :=
  Fin.t_rect
    (fun n0 p3 =>
       forall v0,
         (forall p, Vector.nth (Vector.map (fun x => f (g x)) v0) p) -> f (Vector.nth (Vector.map g v0) p3))
    (fun n0 v0 =>
       Vector.caseS
         (fun n1 v1 =>
            (forall p, Vector.nth (Vector.map (fun x => f (g x)) v1) p) -> f (Vector.nth (Vector.map g v1) Fin.F1))
         (fun h n1 t => fun x => x Fin.F1) v0)
    (fun n0 p3 IHp1 v0 =>
       Vector.caseS
         (fun n1 v1 =>
            forall p4,
              (forall v2,
                 (forall p, Vector.nth (Vector.map (fun x => f (g x)) v2) p) -> f (Vector.nth (Vector.map g v2) p4)) ->
              (forall p, Vector.nth (Vector.map (fun x => f (g x)) v1) p) -> f (Vector.nth (Vector.map g v1) (Fin.FS p4)))
         (fun h n1 t p4 IHp2 =>
            fun X => (IHp2 t (fun (p: Fin.t n1) => (X (Fin.FS p))))
         ) v0 p3 IHp1) n p v.

Definition Vector_nth_map2_l A B (g: A -> B) (f: B -> Type) n (v: Vector.t A n)
  (m: forall p: Fin.t n, Vector.nth (Vector.map (fun x => f (g x)) v) p)
  (p: Fin.t n): f (Vector.nth (Vector.map g v) p) := @Vector_nth_map2_l' _ _ g f n v p m.

Definition Vector_nth_map2_r' A B (g: A -> B) (f: B -> Type) n (v: Vector.t A n) (p: Fin.t n):
  f (g (Vector.nth v p)) ->
  f (Vector.nth (Vector.map g v) p).
Proof.
  induction p.
  - apply (Vector.caseS (fun n1 v1 => f (g (Vector.nth v1 Fin.F1)) ->
                                      f (Vector.nth (Vector.map g v1) Fin.F1)) (fun h n1 t => fun x => x) v).
  - apply (Vector.caseS (fun n1 v1 => forall p4, (forall v2, f (g (Vector.nth v2 p4)) -> f (Vector.nth (Vector.map g v2) p4)) ->
                                                 f (g (Vector.nth v1 (Fin.FS p4))) -> f (Vector.nth (Vector.map g v1) (Fin.FS p4)))
                        (fun h n1 t p4 IHp2 =>
                           fun X => IHp2 t X)
                        v p IHp
          ).
Defined.

Definition Vector_nth_map2_r A B (g: A -> B) (f: B -> Type) n (v: Vector.t A n)  (p: Fin.t n)
           (m: f (g (Vector.nth v p))):
  f (Vector.nth (Vector.map g v) p) := @Vector_nth_map2_r' _ _ g f n v p m.

Section find.
  Variable A: Type.
  Variable f: A -> bool.

  Fixpoint Vector_find' n (v: Vector.t A n): match n with
                                               | 0 => unit
                                               | S m => Fin.t (S m)
                                             end :=
  match v in Vector.t _ n0 return match n0 with
                                    | 0 => unit
                                    | S m0 => Fin.t (S m0)
                                  end with
    | Vector.nil => tt
    | Vector.cons h n1 t => if f h
                            then Fin.F1
                            else match n1 as n0 return (Vector.t _ n0 -> Fin.t (S n0)) with
                                   | 0 => fun _ => Fin.F1
                                   | S n2 => fun t0 => Fin.FS (Vector_find' t0)
                                 end t
  end.

  Definition Vector_find n (v: Vector.t A (S n)): Fin.t (S n) := Vector_find' v.

  Fixpoint Vector_find_opt n (v: Vector.t A n): option (Fin.t n) :=
    match v in Vector.t _ n0 return option (Fin.t n0) with
    | Vector.nil => None
    | Vector.cons h n1 t => if f h
                            then Some Fin.F1
                            else match n1 as n0 return (Vector.t _ n0 -> option (Fin.t (S n0)))
                                 with
                                   | 0 => fun _ => None
                                   | S n2 => fun t0 =>
                                               match Vector_find_opt t0 with
                                               | None => None
                                               | Some i => Some (Fin.FS i)
                                               end
                                 end t
  end.
End find.


MacBook-Air:~ billw$ /Applications/CoqIDE_8.4pl5.app/Contents/Resources/bin/coqtop
Welcome to Coq 8.4pl5 (October 2014)

Coq < Section Examples.

Coq < Require Import Classical.

Coq < Variables P Q : Prop.
P is assumed
Q is assumed

Coq < Goal (P -> Q) <-> (~Q -> ~P).
1 subgoal

  P : Prop
  Q : Prop
  ============================
   P -> Q <-> ~ Q -> ~ P

Unnamed_thm < intros.
1 subgoal

  P : Prop
  Q : Prop
  ============================
   P -> Q <-> ~ Q -> ~ P

Unnamed_thm < intro.
Toplevel input, characters 0-5:
> intro.
> ^^^^^
Error: No product even after head-reduction.

Unnamed_thm < split.
2 subgoals

  P : Prop
  Q : Prop
  ============================
   (P -> Q) -> ~ Q -> ~ P

subgoal 2 is:
 (~ Q -> ~ P) -> P -> Q

Unnamed_thm < intros.
2 subgoals

  P : Prop
  Q : Prop
  H : P -> Q
  H0 : ~ Q
  ============================
   ~ P

subgoal 2 is:
 (~ Q -> ~ P) -> P -> Q

Unnamed_thm < auto.
1 subgoal

  P : Prop
  Q : Prop
  ============================
   (~ Q -> ~ P) -> P -> Q

Unnamed_thm < intros.
1 subgoal

  P : Prop
  Q : Prop
  H : ~ Q -> ~ P
  H0 : P
  ============================
   Q

Unnamed_thm < tauto.
No more subgoals.

Unnamed_thm < Qed.
intros.
split.
 intros.
 auto.

 intros.
 tauto.

Unnamed_thm is defined

Coq <


(* Hilbert system for Intuitionistic Logic with implication and quantifiers *)

From Coq Require Import List.
From Quantifiers Require Import foformulas_ext.

Set Implicit Arguments.

(** * Proofs *)

Section Proofs.

Context { vatom : DecType } { tatom fatom : Type }.

Arguments tvar {_} {_} {T} _.

Notation term := (@term vatom tatom Empty_set).
Notation closed t := (tvars t = nil).

Notation formula := (@formula vatom tatom fatom Nocon Nocon Icon Qcon Empty_set).
Notation fvar := (@fvar vatom tatom fatom Nocon Nocon Icon Qcon Empty_set).
Notation "A [ u // x ]" := (subs x u A) (at level 8, format "A [ u // x ]").
Notation "x ∈ A" := (In x (freevars A)) (at level 30).
Notation "x ∉ A" := (~ In x (freevars A)) (at level 30).
Notation "y #[ x ] A" := (no_capture_at x y A) (at level 30, format "y  #[ x ]  A").
Infix "→" := (fbin imp_con) (at level 55, right associativity).

(** Proofs *)
Inductive hprove : formula -> Type :=
| hprove_K : forall A B, hprove (A → B → A)
| hprove_S : forall A B C, hprove ((A → B → C) → ((A → B) → A → C))
| hprove_MP : forall A B, hprove (A → B) -> hprove A -> hprove B
| hprove_INST : forall x A t, Forall (fun y => y #[x] A) (tvars t) ->
                   hprove (frl x A → A[t//x])
| hprove_FRL : forall x A B, x ∉ A -> hprove ((frl x (A → B)) → A → frl x B)
| hprove_GEN : forall x A, hprove A -> hprove (frl x A)
| hprove_EINST : forall x A t, Forall (fun y => y #[x] A) (tvars t) ->
                   hprove (A[t//x] → exs x A)
| hprove_EXS : forall x A B, x ∉ B -> hprove (frl x (A → B) → exs x A → B).

Lemma hprove_I A : hprove (A → A).
Proof. (* I = (S K) K *)
eapply hprove_MP.
- eapply hprove_MP.
  + apply hprove_S.
  + apply hprove_K with (B := A → A).
- apply hprove_K.
Qed.

Lemma hprove_B A B C : hprove ((B → C) → (A → B) → A → C).
Proof. (* B = (S (K S)) K *)
eapply hprove_MP.
- eapply hprove_MP.
  + apply hprove_S.
  + eapply hprove_MP.
    * apply hprove_K.
    * apply hprove_S.
- apply hprove_K.
Qed.

Lemma hprove_C A B C : hprove ((A → B → C) → B → A → C).
Proof. (* C = (S ((S (K B)) S)) (K K) *)
eapply hprove_MP.
- eapply hprove_MP.
  + apply hprove_S.
  + eapply hprove_MP.
    * eapply hprove_MP.
      -- apply hprove_S.
      -- eapply hprove_MP.
         ++ apply hprove_K.
         ++ apply hprove_B.
    * apply hprove_S.
- eapply hprove_MP.
  + apply hprove_K.
  + apply hprove_K.
Qed.

Lemma hprove_K2 A B : hprove (B → A → A).
Proof. (* K2 = C K *)
eapply hprove_MP.
- apply hprove_C.
- apply hprove_K.
Qed.

Lemma hprove_W A B : hprove ((A → A → B) → A → B).
Proof. (* (S S) (S K) *)
eapply hprove_MP.
- eapply hprove_MP.
  + apply hprove_S.
  + apply hprove_S.
- eapply hprove_MP.
  + apply hprove_S.
  + apply hprove_K.
Qed.

Lemma hprove_CUT B A C : hprove (A → B) -> hprove (B → C) -> hprove (A → C).
Proof. (* fun x y => (B y) x *)
intros pi1 pi2.
eapply hprove_MP.
- eapply hprove_MP.
  + apply hprove_B.
  + apply pi2.
- apply pi1.
Qed.

Lemma hprove_B2 A B C : hprove ((A → B) → (B → C) → A → C).
Proof. (* C B *)
eapply hprove_MP.
- apply hprove_C.
- apply hprove_B.
Qed.

End Proofs.


Require Import Category.Lib.
Require Import Category.Theory.Category.
Require Import Category.Theory.Functor.
Require Import Category.Structure.Cone.
Require Import Category.Structure.Limit.
Require Import Category.Structure.Terminal.
Require Import Category.Instance.Zero.

Generalizable All Variables.

Theorem Terminal_Limit (C : Category) (F : 0 ⟶ C) :
  Limit F ↔ @Terminal C.
Proof.
  split; intros.
  - construct.
    + exact (vertex_obj[X]).
    + given (cone : Cone F). {
        unshelve (refine {| vertex_obj := x |}); unshelve econstructor; intros.
        - inversion x0.
        - inversion x0.
      }
      destruct (@ump_limits _ _ _ X cone).
      apply unique_obj.
    + given (cone : Cone F). {
        unshelve (refine {| vertex_obj := x |}); unshelve econstructor; intros.
        - inversion x0.
        - inversion x0.
      }
      destruct (@ump_limits _ _ _ X cone).
      pose proof (uniqueness f).
      pose proof (uniqueness g).
      rewrite <- X0, <- X1.
      * reflexivity.
      * intro x0; inversion x0.
      * intro x0; inversion x0.
  - construct.
    + construct; [ | unshelve econstructor ].
      * exact terminal_obj.
      * inversion x.
      * inversion x.
    + simpl.
      unshelve eexists.
      * exact one.
      * intros.
        inversion x.
      * intros.
        apply one_unique.
Qed.


Require Import HoTT.Basics HoTT.Types HoTT.Fibrations.
Require Import MyTacs MyLemmas Colimits.Diagram Colimits.Colimit Colimits.Colimit_Sigma MappingTelescope.

Require Import KernelPair_v1.

(* also work with: *)
(* Require Import KernelPair_v2. *)
(* Notation "'KP'" := KP'. *)
(*  *)

Local Open Scope path_scope.
Generalizable All Variables.

Context `{Funext}.

Section CechNerve.

  Context {X Y: Type} (f: X -> Y).

  Definition CechNerve_aux (n: nat) : {T: Type & T -> Y}.
    induction n.
    - exists X. exact f.
    - exists (KP IHn.2).
      first [apply KP_lift | simple refine (KP_lift _ (KP_colimit _))].
  Defined.

  Let fn := λ n, (CechNerve_aux n).2.

  Definition CechNerve : diagram mappingtelescope_graph.
    simple refine (Build_diagram _ _ _).
    - intros n. exact (CechNerve_aux n).1.
    - intros n m q; destruct q; simpl. apply kp.
  Defined.

  Definition SlicedCechNerve1 (y: Y) : diagram mappingtelescope_graph.
    simple refine (Build_diagram _ _ _).
    - intros n. exact (hfiber (fn n) y).
    - intros n m q x; destruct q; simpl in *.
      exists (kp x.1). exact x.2.
  Defined.

  Definition SlicedCechNerve_equiv1 : CechNerve ≃ (sigma_diag SlicedCechNerve1).
    simple refine (Build_diagram_equiv (Build_diagram_map _ _) _).
    - intros n; simpl. apply equiv_fibration_replacement.
    - intros n m q; destruct q; simpl in *.
      exact (fibration_replacement_commute kp (fn n) (fn n.+1) (λ _,1)).
    - intros n; simpl. apply (equiv_fibration_replacement (fn n)).
  Defined.

  Let auxT (y: Y) (n: nat) : Type   (* := T^n (hfiber f y) *)
    := (nat_rect (fun _ => Type) (hfiber f y) (λ _ X, T X) n).

  Definition SlicedCechNerve2 (y: Y) : diagram mappingtelescope_graph.
    simple refine (Build_diagram _ _ _).
    - intros n; exact (auxT y n).
    - intros i j q; destruct q; simpl. apply α.
  Defined.

  Definition SlicedCechNerve_equiv2 `{ua : Univalence} (y: Y) : (SlicedCechNerve1 y) ≃ (SlicedCechNerve2 y).
    simple refine (equiv_mappingtelescope_diag _ _ _ _); simpl.
    apply reflexive_equiv.
    intros n e. simple refine (hfiber_KP_lift_equiv _ _ _).
  Defined.

  Definition SlicedCechNerve_equiv `{ua : Univalence} : CechNerve ≃ (sigma_diag SlicedCechNerve2).
    etransitivity. apply SlicedCechNerve_equiv1.
    simple refine (sigma_diag_functor_equiv _ _ _).
    apply SlicedCechNerve_equiv2.
  Defined.
End CechNerve.


From Coq Require Import String List Arith Lia.
From minilog Require Import data utils substitutions.
Import ListNotations.

(** * Verified Matching Algorithm *)

(** A state of the algorithm is a list of equations to be solved and a current solution.
    Solutions are represented as finite maps from variables to closed terms ([datum])
*)
Record state := {
  equations : list (datum * pattern);
  solution  : fin_csubst;
}.

(** At every iteration, the algorithm either fails, update the current state,
    or terminates with a solution *)
Inductive status :=
  | Failure
  | Update (st : state)
  | Success (sub : fin_csubst).

(** Intepreting a finite map as a set of equations *)
Definition map_as_equations (m : @fin_map datum) :=
  map (fun '(x, y) => (y, Pvar x)) m.

(** Intepreting a state as set of equations *)
Definition state_as_equations (st : state) :=
  equations st ++ map_as_equations (solution st).

(** What it means to be a solution to a set of equations *)
Definition satisfy (s : csubstitution) equs :=
  Forall (fun '(x, y) => Matching s x y) equs.

(** Equivalence of two sets of equations *)
Definition equiv equs1 equs2 :=
  forall s, satisfy s equs1 <-> satisfy s equs2.

(** Equivalence of two states *)
Definition state_equiv st1 st2 :=
  equiv (state_as_equations st1) (state_as_equations st2).

(** All bindings of a map are preserved when the map is interpreted as a set of equations *)
Lemma in_map_in_equations:
  forall sol (d : datum) (n : nat), In (n, d) sol -> In (d, Pvar n) (map_as_equations sol).
Proof.
  induction sol as [| [n dat] sol IH]; try easy.
  intros d m [[=->->] | H2]. now left.
  right. now apply IH.
Qed.

(** All equations generated from a map are of the form [(_, Pvar x)] where [x]
    is bound in the map *)
Lemma in_equations_in_map:
  forall dat pat sub,
    In (dat, pat) (map_as_equations sub) -> exists x, pat = Pvar x /\ get sub x <> None.
Proof.
  intros. induction sub as [|[x vx] sub IH].
  - inversion H.
  - simpl in H. destruct H as [[=-><-] | Hin].
    exists x. split; auto. simpl.
    now rewrite Nat.eqb_refl.
    specialize (IH Hin) as [y [Hy1 Hy2]].
    exists y; split; auto.
    simpl. now destruct (x =? y)%nat.
Qed.

(** Reduce the problem of matching 2 lists of terms
    to the problem of solving a list of equations
*)
Fixpoint decompose (l1 : list datum) (l2 : list pattern) :=
  match l1, l2 with
  | [], [] => Some []
  | x::xs, y::ys =>
    do equs <- decompose xs ys;
    Some ((x, y)::equs)
  | _, _ => None
  end.

(** One step of the matching algorithm:
    We start by picking an equation from the worklist.
    If it is a trivial equation, it is deleted and
    the solution is extended accordingly.
    If it is a non trivial equation, we decompose it and
    extend the worklist.
*)
Definition matching_step (st : state) : status :=
  match equations st with
  | [] => Success (solution st)
  | (Dapp f1 l1, Papp f2 l2)::equs =>
    if (f1 =? f2)%string then
      match decompose l1 l2 with
      | Some equs' => Update (Build_state (equs' ++ equs) (solution st))
      | None => Failure
      end
    else Failure
  | (d, Pvar x)::equs =>
    match get (solution st) x with
    | None => Update (Build_state equs ((x, d)::(solution st)))
    | Some vx =>
      if (vx =? d)%datum then Update (Build_state equs (solution st)) else Failure
    end
  end.

Lemma decompose_equiv:
  forall s1 s2 l1 l2 l,
    (s1 =? s2)%string = true ->
    decompose l1 l2 = Some l ->
    equiv l [(Dapp s1 l1, Papp s2 l2)].
Proof.
  intros * ->%String.eqb_eq H sub.
  induction l2 in l, l1, H, sub |-*.
  - destruct l1; try easy. simpl in *.
    inversion_clear H. now repeat econstructor.
  - destruct l1; try easy. simpl in *.
    destruct (decompose l1 l2) as [l'|] eqn:Heq; try easy.
    simpl in H. inversion H; subst. clear H.
    specialize (IHl2 _ _ Heq sub) as [H1 H2].
    split; intros.
    + inversion_clear H as [| ? ? H3 H4].
      specialize (H1 H4).
      inversion_clear H3.
      inversion_clear H1 as [| ? ? H3 _].
      inversion_clear H3.
      now econstructor.
    + inversion H as [| ? ? H3 _]; subst.
      inversion H3. apply Forall_cons; try easy.
      apply H2. apply Forall_cons; try easy.
      subst. repeat econstructor.
Qed.

Lemma matching_step_equiv:
  forall st1 st2,
    matching_step st1 = Update st2 ->
    state_equiv st1 st2.
Proof.
  intros [equs1 sol1] [equs2 sol2] H.
  induction equs1 as [| [dat1 pat1] equs1 _] in equs2, sol2, H |-*; try easy.
  destruct dat1, pat1; try easy.
  - unfold matching_step in H. simpl in H.
    destruct get eqn:Hget in H;
    try destruct datum_eqb eqn:Hdat in H; try easy.
    + inversion H; subst. clear H. intros sub. split.
      * intros Hsat. inversion_clear Hsat as [| ? ? H1 H2]; subst.
        apply Forall_app in H2 as [H2 H3].
        red. cbn. apply Forall_app. split; auto.
      * intros Hsat. red. cbn. apply Forall_cons; auto.
        apply datum_eqb_eq in Hdat; subst.
        unfold satisfy, state_as_equations in Hsat.
        apply Forall_app in Hsat as [_ H2]. simpl in H2.
        apply get_in in Hget.
        rewrite Forall_forall in H2.
        now specialize (H2 (Dapp s l, Pvar n) (in_map_in_equations _ _ _ Hget)).
    + inversion H; subst. clear H. intros sub. split.
      * intros Hsat. inversion_clear Hsat as [| ? ? H1 H2].
        apply Forall_app in H2 as [H2 H3].
        red. cbn. apply Forall_app; split; auto.
      * intros Hsat. unfold satisfy in *. cbn in *.
        apply Forall_app in Hsat as [H1 H2]. simpl in *.
        inversion H2 as [|? ? H3 H4]; subst.
        apply Forall_cons; auto.
        apply Forall_app; auto.
  - unfold matching_step in H. simpl in H.
    destruct String.eqb eqn:Hstr in H; try easy.
    inversion H; subst. clear H.
    destruct (decompose l l0) eqn:Hdec; try easy.
    inversion H1; subst. clear H1.
    intros sub. unfold state_as_equations. simpl.
    pose proof (decompose_equiv _ _ _ _ _ Hstr Hdec sub) as [H1 H2].
    split; intros Hsat.
    + inversion Hsat as [| ? ? H3 H4]; subst.
      apply Forall_app in H4 as [H4 H5].
      apply Forall_app; split; try easy.
      apply Forall_app; split; try easy.
      apply H2. now econstructor.
    + apply Forall_app in Hsat as [[H3 H4]%Forall_app H5].
      specialize (H1 H3).
      inversion H1 as [| ? ? H6 H7]; subst.
      econstructor; try easy.
      apply Forall_app; split; try easy.
Qed.

Lemma matching_step_done:
  forall st sol,
    matching_step st = Success sol ->
    equations st = [].
Proof.
  intros [equs sol] sol' Heq. simpl.
  destruct equs as [| [dat pat] equs ]; try easy.
  unfold matching_step in Heq; simpl in *.
  destruct dat, pat;
  try destruct get;
  try destruct datum_eqb;
  try destruct String.eqb;
  try destruct decompose;
  try easy.
Qed.

Lemma matching_step_sol:
  forall st sol,
    matching_step st = Success sol ->
    sol = solution st.
Proof.
  intros [equs sol] sol' Heq. simpl.
  destruct equs as [| [dat pat] equs ]; try easy.
  unfold matching_step in Heq; simpl in *.
  - now inversion Heq.
  - apply matching_step_done in Heq.
    now inversion Heq.
Qed.

Lemma decompose_fail:
  forall l1 l2, decompose l1 l2 = None -> length l1 <> length l2.
Proof.
  induction l1 as [| x xs IH]; intros.
  - now destruct l2.
  - destruct l2; try easy. simpl in H.
    destruct (decompose xs l2) eqn:Heq; try easy.
    specialize (IH _ Heq).
    intros [=]. now rewrite H1 in IH.
Qed.

Lemma match_list_length:
  forall sub s1 l1 s2 l2 ,
    Matching sub (Dapp s1 l1) (Papp s2 l2) ->
    length l1 = length l2.
Proof.
  intros. inversion H; subst.
  apply map_length.
Qed.

Lemma matching_step_failure:
  forall st,
    matching_step st = Failure ->
    forall sub, ~satisfy sub (state_as_equations st).
Proof.
  intros [equs sol] Heq sub Hcontr.
  destruct equs as [| [dat pat] equs]; try easy.
  unfold state_as_equations in Hcontr. simpl in *.
  inversion Hcontr as [| ? ? H1 H2]; subst.
  apply Forall_app in H2 as [H2 H3].
  destruct dat, pat.
  + unfold matching_step in Heq. simpl in *.
    destruct get eqn:Heq1; try easy.
    destruct datum_eqb eqn:Heq2; try easy.
    apply get_in, in_map_in_equations in Heq1.
    rewrite Forall_forall in H3.
    specialize (H3 _ Heq1). simpl in H3.
    unfold Matching in *; subst. simpl in *.
    apply datum_eqb_neq in Heq2.
    now rewrite H1 in Heq2.
  + unfold matching_step in Heq. simpl in *.
    destruct String.eqb eqn:Heq2.
    destruct decompose eqn:Heq3; try easy.
    apply decompose_fail in Heq3.
    apply match_list_length in H1.
    now rewrite H1 in Heq3.
    apply String.eqb_neq in Heq2.
    now inversion H1.
Qed.

(** ** Termination of the algorithm *)

(** Size of an equation *)
Definition equation_size '((x , y) : datum * pattern) : nat :=
  datum_size x + pattern_size y.

(** Size of a list of equations *)
Definition equations_size eqs : nat :=
  sum equation_size eqs.

(** Size of a state *)
Definition state_size (st : state) :=
  equations_size (equations st).

(** Ordering on states *)
Definition state_lt (st1 st2 : state) :=
  state_size st1 < state_size st2.

(** The ordering on states is well founded *)
Lemma state_lt_wf:
  well_founded state_lt.
Proof.
  apply (well_founded_ltof _ state_size).
Defined.

(** [matching_step] is strictly decreasing wrt [state_lt] *)
Lemma matching_step_mono:
  forall st1 st2,
    matching_step st1 = Update st2 ->
    state_lt st2 st1.
Proof.
  intros. red.
  destruct st1 as [equs sols]. simpl.
  destruct equs as [|[ [f1 l1] [| f2 l2]] equs]; unfold matching_step in H; simpl in *|-; try easy.
  + unfold state_size, equations_size, sum.
    destruct get eqn:Hget; try easy.
    destruct datum_eqb eqn:Heq; try easy.
    apply datum_eqb_eq in Heq; subst.
    all: inversion_clear H; simpl.
    all: apply sum_aux_mono; lia.
  + unfold state_size, equations_size.
    destruct String.eqb eqn:Heq1; try easy.
    destruct decompose as [equs'|] eqn:Heq2; try easy.
    inversion_clear H; simpl equations.
    fold (app [(Dapp f1 l1, Papp f2 l2)] equs).
    do 2 rewrite sum_app.
    apply Nat.add_lt_mono_r.
    induction l1 as [| d1 l1 IH] in l2, equs', Heq2 |-* ; simpl in Heq2.
    - destruct l2 as [| d2 l2 ]; inversion_clear Heq2; cbn; lia.
    - destruct l2 as [| d2 l2 ]; [inversion Heq2|].
      destruct (decompose l1 l2) as [l|] eqn:Hdec; try easy.
      simpl in Heq2. inversion_clear Heq2.
      specialize (IH _ _ Hdec).
      repeat rewrite sum_cons in *.
      simpl equation_size in *.
      repeat rewrite sum_cons in *.
      lia.
Qed.

(** If there are no infinite decreasing sequences from a state [st1]
    and if [matchin_step st1 = Update st2] then
    then there are no inifinitely decreasing sequences starting from [st2]
*)
Lemma matching_iter_acc:
  forall st1 st2, Acc state_lt st1 -> matching_step st1 = Update st2 -> Acc state_lt st2.
Proof.
  intros * H1 H2.
  eapply Acc_inv; eauto.
  now apply matching_step_mono.
Defined.

(** An proof carrying datatype to classify elements of type [status] *)
Inductive status_cases (s : status) : Type :=
  | is_update   : sigT (fun st => s = Update st) -> status_cases s
  | is_success  : sigT (fun sol => s = Success sol) -> status_cases s
  | is_failure  : s = Failure -> status_cases s.

(** Any element of type [status] can be classified *)
Theorem status_dec:
  forall s : status, status_cases s.
Proof.
  intros [ | | ].
  + now apply is_failure.
  + apply is_update. eauto.
  + apply is_success. eauto.
Qed.

(** Iterating [matching_step] untill termination starting from an
    accessible state
    (i.e. a state from which there are no inifinite decreasing chains).

    The recursion is structural on the proof that the current
    state is accessible.
*)
Fixpoint matching_iter (st : state) (acc : Acc state_lt st) {struct acc} :=
  let s := matching_step st in
  match status_dec s with
  | is_success _ Hsol => Some (projT1 Hsol)
  | is_update _  Hupd => matching_iter (projT1 Hupd) (matching_iter_acc st (projT1 Hupd) acc (projT2 Hupd))
  | is_failure _ _    => None
  end.

(** The matching algorithm iterates the function [matching_step]
    starting with the initial equation to be solved.
*)
Definition matching (d : datum) (p : pattern) :=
  let st0 := Build_state [(d, p)] [] in
  matching_iter st0 (state_lt_wf st0).

(** ** Correctness of the Algorithm *)

(** *** Certificates *)

(** A first option is to have a partial algorithm that explicitely
    double checks that the computed solution to the matching problem
    is indeed a solution. This approach is sound but not complete.
*)
Definition certified_matching (dat : datum) (pat : pattern) : bool :=
  match matching dat pat with
  | Some sub => csubst pat sub =? dat
  | None => false
  end.

Lemma certified_matching_correct:
  forall dat pat, certified_matching dat pat = true -> Match dat pat.
Proof.
  intros. unfold certified_matching in H.
  destruct (matching dat pat) eqn:Heq; try easy.
  apply datum_eqb_eq in H.
  eexists. red. now rewrite H.
Qed.

(** *** Soundness and Completeness *)

(** What it means that the domain of a finite map covers the variables of
    of a given pattern
*)
Definition covers_pattern (sub : fin_csubst) pat :=
  forall x, free_var pat x -> get sub x <> None.

(** What it means that the domain of a finite map covers the variables of
    of a set of equations
*)
Definition covers_equs (sub : fin_csubst) (equs : list (datum * pattern)) :=
  Forall (fun '(_, pat) => covers_pattern sub pat) equs.

(** If a finite map covers the variables of a pattern, it also covers all its subpaterns *)
Lemma covers_subpattern:
  forall sub s x xs,
    covers_pattern sub (Papp s (x::xs)) ->
    covers_pattern sub x /\ covers_pattern sub (Papp s xs).
Proof.
  intros * H. split.
  - intros n Hn. apply H.
    now repeat econstructor.
  - intros n Hn. apply H.
    inversion Hn; subst.
    econstructor. now apply Exists_cons_tl.
Qed.

(** Extending a finite map that covers a pattern [pat]
    with a fresh binding does not change the result of
    applying the substitution to [pat]
*)
Lemma csubst_extend_map:
  forall pat sub x vx,
    get sub x = None ->
    covers_pattern sub pat ->
    csubst pat (cinterp sub) = csubst pat (cinterp ((x, vx)::sub)).
Proof.
  refine (pattern_induction _ _ _); try easy.
  - intros. unfold cinterp. simpl.
    destruct (x0 =? x)%nat eqn:Heq1.
    + apply Nat.eqb_eq in Heq1; subst.
      destruct get eqn:Heq2; try easy.
      specialize (H0 x (free_var_var x)).
      now rewrite Heq2 in H0.
    + destruct get eqn:Heq2; try easy.
  - intros * H1 * H2 H3. simpl.
    assert (Heq : map (fun p : pattern => csubst p (cinterp sub)) dats = map (fun p : pattern => csubst p (cinterp ((x, vx) :: sub))) dats).
    { apply map_ext_in. intros.
      rewrite Forall_forall in H1. apply H1; try easy.
      red. intros. apply H3. econstructor.
      apply Exists_exists. now exists a.
    }
    now rewrite Heq.
Qed.

(** Extending a finite map that covers equations [equs]
    with a fresh binding preserves the satisfiablity of [equs].
*)
Lemma satisfy_extend_map:
  forall sub x vx equs,
    get sub x = None ->
    covers_equs sub equs ->
    satisfy (cinterp sub) equs ->
    satisfy (cinterp ((x, vx)::sub)) equs.
Proof.
  intros * H1 H2 H3. induction equs as [|[dat pat] equs IH].
  - econstructor.
  - inversion H3; subst. clear H3.
    inversion H2; subst. clear H2.
    apply Forall_cons.
    + destruct pat; try easy.
      * unfold Matching, cinterp in H4 |-*. simpl in *.
        destruct (x =? n)%nat eqn:Heq2; try easy.
        apply Nat.eqb_eq in Heq2; subst.
        destruct (get sub n) eqn:Heq1; try easy.
        specialize (H3 n (free_var_var n)).
        now rewrite Heq1 in H3.
      * unfold Matching in H4 |-*.
        rewrite H4. clear H4.
        simpl. induction l; try easy.
        apply covers_subpattern in H3 as [H3 H4]. specialize (IHl H4).
        specialize (IH H6 H5).
        simpl. inversion IHl; subst.
        rewrite <- csubst_extend_map; auto.
    + apply (IH H6 H5).
Qed.

(** A valid substitution is a finite map
    with only one binding for each variable
*)
Inductive valid_subst : fin_csubst -> Prop :=
  | valid_nil : valid_subst []
  | valid_cons x vx m :
    valid_subst m ->
    get m x = None ->
    valid_subst ((x, vx)::m).

(** A finite map covers itself *)
Lemma covers_itself:
  forall sub, covers_equs sub (map_as_equations sub).
Proof.
  induction sub as [| [x vx] sub IH].
  - econstructor.
  - unfold map_as_equations. simpl.
    apply Forall_forall.
    intros [dat pat] H; inversion_clear H as [[=H1 H2]|]; subst.
    + intros y Hy. inversion Hy; subst.
      simpl. now rewrite Nat.eqb_refl.
    + intros y Hy. simpl.
      destruct (x =? y)%nat; try easy.
      destruct (get sub y) eqn:Heq; try easy.
      apply in_equations_in_map in H0 as [z [-> Hz]].
      inversion Hy; subst.
      now rewrite Heq in Hz.
Qed.

(** A finite map satisfies itself *)
Lemma satisfy_self:
  forall sub, valid_subst sub -> satisfy (cinterp sub) (map_as_equations sub).
Proof.
  induction sub as [| (x, vx) sub IH].
  - econstructor.
  - intros H. inversion H; subst.
    specialize (IH H2).
    simpl. econstructor.
    + red. unfold cinterp. simpl.
      now rewrite Nat.eqb_refl.
    + apply satisfy_extend_map; auto.
      apply covers_itself.
Qed.

(** Taking a step of the matching algorithm preserves the well-formedness of the solution *)
Theorem matching_step_valid_subst:
  forall st1 st2,
    valid_subst (solution st1) ->
    matching_step st1 = Update st2 ->
    valid_subst (solution st2).
Proof.
  intros [[| [dat pat] equs1] sol1] [equs2 sol2] H1 H2; simpl solution in *; try easy.
  cbn in H2.
  destruct dat, pat; try easy.
  - destruct get eqn:Heq1.
    destruct datum_eqb eqn:Heq2; try easy.
    + apply datum_eqb_eq in Heq2; subst.
      inversion H2; subst; auto.
    + inversion H2; subst. clear H2.
      now econstructor.
  - destruct String.eqb eqn:Heq1; try easy.
    apply String.eqb_eq in Heq1; subst.
    destruct decompose eqn:Heq2; try easy.
    now inversion H2; subst.
Qed.

(** Taking several steps of the matching algorithm preserves the well-formedness of the solution *)
Lemma matching_iter_valid_subst:
  forall st sub Hacc, valid_subst (solution st) -> matching_iter st Hacc = Some sub -> valid_subst sub.
Proof.
  induction st using (well_founded_induction state_lt_wf). intros * Hvalid.
  destruct Hacc as [Hacc]; cbn.
  destruct status_dec as [[st' Hst'] | [sol Hsol] |]; try easy; simpl.
  - intros Heq.
    pose proof (Hlt := matching_step_mono _ _ Hst').
    pose proof (Hsub := matching_step_valid_subst _ _ Hvalid Hst').
    eapply H; eauto.
  - apply matching_step_sol in Hsol; subst.
    now intros [=<-].
Qed.

(** Taking several steps of the matching algorithm starting in a well formed state [st]
    generates a solution to the equations described by [st]
*)
Lemma matching_iter_sound:
  forall st sub Hacc, valid_subst (solution st) -> matching_iter st Hacc = Some sub -> satisfy (cinterp sub) (state_as_equations st).
Proof.
  induction st using (well_founded_induction state_lt_wf). intros *.
  destruct Hacc as [Hacc]; cbn. intros Hvalid.
  destruct status_dec as [[st' Hst'] | [sol Hsol] |]; try easy; simpl.
  - pose proof (Hlt := matching_step_mono _ _ Hst').
    pose proof (Heq := matching_step_equiv _ _ Hst' (cinterp sub)).
    pose proof (Hvalid' := matching_step_valid_subst _ _ Hvalid Hst').
    rewrite Heq. now apply H.
  - pose proof (Hsol' := matching_step_sol _ _ Hsol).
    pose proof (Hequs := matching_step_done _ _ Hsol).
    destruct st as [equs sols]. unfold state_as_equations.
    simpl in *; subst. simpl.
    intros [=<-]. cbn in Hsol. inversion_clear Hsol.
    now apply satisfy_self.
Qed.

(** If the set of equations generated by a state [st] has a solution,
   then iterating [matching_step] starting from [st] eventually gives a solution
*)
Lemma matching_iter_complete:
  forall st sub Hacc, satisfy sub (state_as_equations st) -> exists sub, matching_iter st Hacc = Some sub.
Proof.
  induction st using (well_founded_induction state_lt_wf). intros * Hsat.
  destruct Hacc as [Hacc]; cbn.
  destruct status_dec as [[st' Hst'] | [sol Hsol] |]; simpl.
  - pose proof (Hlt := matching_step_mono _ _ Hst').
    pose proof (Heq := matching_step_equiv _ _ Hst' sub).
    rewrite Heq in Hsat.
    specialize (H _ Hlt sub (Hacc _ (matching_step_mono st st' Hst')) Hsat) as [sub' Hsub'].
    eexists. apply Hsub'.
  - now eexists sol.
  - eapply matching_step_failure in e.
    now apply e in Hsat.
Qed.

(** [matching] is a sound algorithm to solve matching problems *)
Lemma matching_sound:
  forall dat pat sub, matching dat pat = Some sub -> Matching (cinterp sub) dat pat.
Proof.
  intros.
  unfold matching in H.
  apply matching_iter_sound in H.
  - now inversion H.
  - econstructor.
Qed.

(** [matching] is a complete algorithm to solve matching problems *)
Lemma matching_complete:
  forall dat pat, Match dat pat -> exists sub, matching dat pat = Some sub.
Proof.
  intros * [sub Hsub].
  unfold matching.
  apply (matching_iter_complete _ sub).
  unfold state_as_equations. simpl.
  now econstructor.
Qed.


(* (c) Copyright 2006-2016 Microsoft Corporation and Inria.                  *)
(* Distributed under the terms of CeCILL-B.                                  *)
From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq choice.
From mathcomp Require Import fintype tuple.

(******************************************************************************)
(* This file implements a type for functions with a finite domain:            *)
(*      {ffun aT -> rT} where aT should have a finType structure,             *)
(*      {ffun forall x : aT, rT} for dependent functions over a finType aT,   *)
(*  and {ffun funT} where funT expands to a product over a finType.           *)
(* Any eqType, choiceType, countType and finType structures on rT extend to   *)
(* {ffun aT -> rT} as Leibnitz equality and extensional equalities coincide.  *)
(*     (T ^ n)%type is notation for {ffun 'I_n -> T}, which is isomorphic     *)
(*   to n.-tuple T, but is structurally positive and thus can be used to      *)
(*   define inductive types, e.g., Inductive tree := node n of tree ^ n (see  *)
(*   mid-file for an expanded example).                                       *)
(* --> More generally, {ffun fT} is always structurally positive.             *)
(*   {ffun fT} inherits combinatorial structures of rT, i.e., eqType,         *)
(* choiceType, countType, and finType. However, due to some limitations of    *)
(* the Coq 8.9 unification code the structures are only inherited in the      *)
(* NON dependent case, when rT does not depend on x.                          *)
(*  For f : {ffun fT} with fT := forall x : aT, rT we define                  *)
(*              f x == the image of x under f (f coerces to a CiC function)   *)
(* --> The coercion is structurally decreasing, e.g., Coq will accept         *)
(*   Fixpoint size t := let: node n f := t in sumn (codom (size \o f)) + 1.   *)
(* as structurally decreasing on t of the inductive tree type above.          *)
(*       {dffun fT} == alias for {ffun fT} that inherits combinatorial        *)
(*                     structures on rT, when rT DOES depend on x.            *)
(*      total_fun g == the function induced by a dependent function g of type *)
(*                     forall x, rT on the total space {x : aT & rT}.         *)
(*                  := fun x =>  Tagged (fun x => rT) (g x).                  *)
(*        tfgraph f == the total function graph of f, i.e., the #|aT|.-tuple  *)
(*                     of all the (dependent pair) values of total_fun f.     *)
(*         finfun g == the f extensionally equal to g, and the RECOMMENDED    *)
(*                     interface for building elements of {ffun fT}.          *)
(* [ffun x : aT => E] := finfun (fun x : aT => E).                            *)
(*                     There should be an explicit type constraint on E if    *)
(*                     type does not depend on x, due to the Coq unification  *)
(*                     limitations referred to above.                         *)
(*        ffun0 aT0 == the trivial finfun, from a proof aT0 that #|aT| = 0.   *)
(*   f \in family F == f belongs to the family F (f x \in F x for all x)      *)
(*   There are additional operations for non-dependent finite functions,      *)
(* i.e., f in {ffun aT -> rT}.                                                *)
(*    [ffun x => E] := finfun (fun x => E).                                   *)
(*                     The type of E must not depend on x; this restriction   *)
(*                     is a mitigation of the aforementioned Coq unification  *)
(*                     limitations.                                           *)
(*       [ffun=> E] := [ffun _ => E] (E should not have a dependent type).    *)
(*         fgraph f == the function graph of f, i.e., the #|aT|.-tuple        *)
(*                     listing the values of f x, for x ranging over enum aT. *)
(*         Finfun G == the finfun f whose (simple) function graph is G.       *)
(*  f \in ffun_on R == the range of f is a subset of R.                       *)
(*     y.-support f == the y-support of f, i.e., [pred x | f x != y].         *)
(*                     Thus, y.-support f \subset D means f has y-support D.  *)
(*                     We will put Notation support := 0.-support in ssralg.  *)
(* f \in pffun_on y D R == f is a y-partial function from D to R:             *)
(*                     f has y-support D and f x \in R for all x \in D.       *)
(*  f \in pfamily y D F == f belongs to the y-partial family from D to F:     *)
(*                     f has y-support D and f x \in F x for all x \in D.     *)
(******************************************************************************)

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

Section Def.

Variables (aT : finType) (rT : aT -> Type).

Inductive finfun_on : seq aT -> Type :=
| finfun_nil                            : finfun_on [::]
| finfun_cons x s of rT x & finfun_on s : finfun_on (x :: s).

Local Fixpoint finfun_rec (g : forall x, rT x) s : finfun_on s :=
  if s is x1 :: s1 then finfun_cons (g x1) (finfun_rec g s1) else finfun_nil.

Local Fixpoint fun_of_fin_rec x s (f_s : finfun_on s) : x \in s -> rT x :=
  if f_s is finfun_cons x1 s1 y1 f_s1 then
    if eqP is ReflectT Dx in reflect _ Dxb return Dxb || (x \in s1) -> rT x then
      fun=> ecast x (rT x) (esym Dx) y1
    else fun_of_fin_rec f_s1
  else fun isF =>  False_rect (rT x) (notF isF).

Variant finfun_of (ph : phant (forall x, rT x)) : predArgType :=
  FinfunOf of finfun_on (enum aT).

Definition dfinfun_of ph := finfun_of ph.

Definition fun_of_fin ph (f : finfun_of ph) x :=
  let: FinfunOf f_aT := f in fun_of_fin_rec f_aT (mem_enum aT x).

End Def.

Coercion fun_of_fin : finfun_of >-> Funclass.
Identity Coercion unfold_dfinfun_of : dfinfun_of >-> finfun_of.
Arguments fun_of_fin {aT rT ph} f x.

Notation "{ 'ffun' fT }" := (finfun_of (Phant fT))
  (at level 0, format "{ 'ffun'  '[hv' fT ']' }") : type_scope.

Notation "{ 'dffun' fT }" := (dfinfun_of (Phant fT))
  (at level 0, format "{ 'dffun'  '[hv' fT ']' }") : type_scope.

Definition exp_finIndexType := ordinal_finType.
Notation "T ^ n" :=
  (@finfun_of (exp_finIndexType n) (fun=> T) (Phant _)) : type_scope.

Local Notation finPi aT rT := (forall x : Finite.sort aT, rT x) (only parsing).
Local Notation finfun_def :=
  (fun aT rT g => FinfunOf (Phant (finPi aT rT)) (finfun_rec g (enum aT))).

Module Type FinfunDefSig.
Parameter finfun : forall aT rT, finPi aT rT -> {ffun finPi aT rT}.
Axiom finfunE : finfun = finfun_def.
End FinfunDefSig.

Module FinfunDef : FinfunDefSig.
Definition finfun := finfun_def.
Lemma finfunE : finfun = finfun_def. Proof. by []. Qed.
End FinfunDef.

Notation finfun := FinfunDef.finfun.
Canonical finfun_unlock := Unlockable FinfunDef.finfunE.
Arguments finfun {aT rT} g.

Notation "[ 'ffun' x : aT => E ]" := (finfun (fun x : aT => E))
  (at level 0, x name) : fun_scope.

Notation "[ 'ffun' x => E ]" := (@finfun _ (fun=> _) (fun x => E))
  (at level 0, x name, format "[ 'ffun'  x  =>  E ]") : fun_scope.

Notation "[ 'ffun' => E ]" := [ffun _ => E]
  (at level 0, format "[ 'ffun' =>  E ]") : fun_scope.

(* Example outcommented.
(* Examples of using finite functions as containers in recursive inductive    *)
(* types, and making use of the fact that the type and accessor are           *)
(* structurally positive and decreasing, respectively.                        *)
Unset Elimination Schemes.
Inductive tree := node n of tree ^ n.
Fixpoint size t := let: node n f := t in sumn (codom (size \o f)) + 1.
Example tree_step (K : tree -> Type) :=
  forall n st (t := node st) & forall i : 'I_n, K (st i), K t.
Example tree_rect K (Kstep : tree_step K) : forall t, K t.
Proof. by fix IHt 1 => -[n st]; apply/Kstep=> i; apply: IHt. Defined.

(* An artificial example use of dependent functions.                          *)
Inductive tri_tree n := tri_row of {ffun forall i : 'I_n, tri_tree i}.
Fixpoint tri_size n (t : tri_tree n) :=
  let: tri_row f := t in sumn [seq tri_size (f i) | i : 'I_n] + 1.
Example tri_tree_step (K : forall n, tri_tree n -> Type) :=
  forall n st (t := tri_row st) & forall i : 'I_n, K i (st i), K n t.
Example tri_tree_rect K (Kstep : tri_tree_step K) : forall n t, K n t.
Proof. by fix IHt 2 => n [st]; apply/Kstep=> i; apply: IHt. Defined.
Set Elimination Schemes.
(* End example. *) *)

(* The correspondence between finfun_of and CiC dependent functions.          *)
Section DepPlainTheory.
Variables (aT : finType) (rT : aT -> Type).
Notation fT := {ffun finPi aT rT}.
Implicit Type f : fT.

Fact ffun0 (aT0 : #|aT| = 0) : fT.
Proof. by apply/finfun=> x; have:= card0_eq aT0 x. Qed.

Lemma ffunE g x : (finfun g : fT) x = g x.
Proof.
rewrite unlock /=; set s := enum aT; set s_x : mem_seq s x := mem_enum _ _.
by elim: s s_x => //= x1 s IHs; case: eqP => [|_]; [case: x1 / | apply: IHs].
Qed.

Lemma ffunP (f1 f2 : fT) : (forall x, f1 x = f2 x) <-> f1 = f2.
Proof.
suffices ffunK f g: (forall x, f x = g x) -> f = finfun g.
  by split=> [/ffunK|] -> //; apply/esym/ffunK.
case: f => f Dg; rewrite unlock; congr FinfunOf.
have{} Dg x (aTx : mem_seq (enum aT) x): g x = fun_of_fin_rec f aTx.
  by rewrite -Dg /= (bool_irrelevance (mem_enum _ _) aTx).
elim: (enum aT) / f (enum_uniq aT) => //= x1 s y f IHf /andP[s'x1 Us] in Dg *.
rewrite Dg ?eqxx //=; case: eqP => // /eq_axiomK-> /= _.
rewrite {}IHf // => x s_x; rewrite Dg ?s_x ?orbT //.
by case: eqP (memPn s'x1 x s_x) => // _ _ /(bool_irrelevance s_x) <-.
Qed.

Lemma ffunK : @cancel (finPi aT rT) fT fun_of_fin finfun.
Proof. by move=> f; apply/ffunP=> x; rewrite ffunE. Qed.

Lemma eq_dffun (g1 g2 : forall x, rT x) :
   (forall x, g1 x = g2 x) -> finfun g1 = finfun g2.
Proof. by move=> eq_g; apply/ffunP => x; rewrite !ffunE eq_g. Qed.

Definition total_fun g x := Tagged rT (g x : rT x).

Definition tfgraph f := codom_tuple (total_fun f).

Lemma codom_tffun f : codom (total_fun f) = tfgraph f. Proof. by []. Qed.

Local Definition tfgraph_inv (G : #|aT|.-tuple {x : aT & rT x}) : option fT :=
  if eqfunP isn't ReflectT Dtg then None else
  Some [ffun x => ecast x (rT x) (Dtg x) (tagged (tnth G (enum_rank x)))].

Local Lemma tfgraphK : pcancel tfgraph tfgraph_inv.
Proof.
move=> f; have Dg x: tnth (tfgraph f) (enum_rank x) = total_fun f x.
  by rewrite tnth_map -[tnth _ _]enum_val_nth enum_rankK.
rewrite /tfgraph_inv; case: eqfunP => /= [Dtg | [] x]; last by rewrite Dg.
congr (Some _); apply/ffunP=> x; rewrite ffunE.
by rewrite Dg in (Dx := Dtg x) *; rewrite eq_axiomK.
Qed.

Lemma tfgraph_inj : injective tfgraph. Proof. exact: pcan_inj tfgraphK. Qed.

Definition family_mem mF := [pred f : fT | [forall x, in_mem (f x) (mF x)]].

Variables (pT : forall x, predType (rT x)) (F : forall x, pT x).

(* Helper for defining notation for function families. *)
Local Definition fmem F x := mem (F x : pT x).

Lemma familyP f : reflect (forall x, f x \in F x) (f \in family_mem (fmem F)).
Proof. exact: forallP. Qed.

End DepPlainTheory.

Arguments ffunK {aT rT} f : rename.
Arguments ffun0 {aT rT} aT0.
Arguments eq_dffun {aT rT} [g1] g2 eq_g12.
Arguments total_fun {aT rT} g x.
Arguments tfgraph {aT rT} f.
Arguments tfgraphK {aT rT} f : rename.
Arguments tfgraph_inj {aT rT} [f1 f2] : rename.

Arguments fmem {aT rT pT} F x /.
Arguments familyP {aT rT pT F f}.
Notation family F := (family_mem (fmem F)).

Section InheritedStructures.

Variable aT : finType.
Notation dffun_aT rT rS := {dffun forall x : aT, rT x : rS}.

Local Remark eqMixin rT : Equality.mixin_of (dffun_aT rT eqType).
Proof. exact: PcanEqMixin tfgraphK. Qed.
Canonical finfun_eqType (rT : eqType) :=
  EqType {ffun aT -> rT} (eqMixin (fun=> rT)).
Canonical dfinfun_eqType rT :=
  EqType (dffun_aT rT eqType) (eqMixin rT).

Local Remark choiceMixin rT : Choice.mixin_of (dffun_aT rT choiceType).
Proof. exact: PcanChoiceMixin tfgraphK. Qed.
Canonical finfun_choiceType (rT : choiceType) :=
  ChoiceType {ffun aT -> rT} (choiceMixin (fun=> rT)).
Canonical dfinfun_choiceType rT :=
  ChoiceType (dffun_aT rT choiceType) (choiceMixin rT).

Local Remark countMixin rT : Countable.mixin_of (dffun_aT rT countType).
Proof. exact: PcanCountMixin tfgraphK. Qed.
Canonical finfun_countType (rT : countType) :=
  CountType {ffun aT -> rT} (countMixin (fun => rT)).
Canonical dfinfun_countType rT :=
  CountType (dffun_aT rT countType) (countMixin rT).

Local Definition finMixin rT :=
  PcanFinMixin (tfgraphK : @pcancel _ (dffun_aT rT finType) _ _).
Canonical finfun_finType (rT : finType) :=
  FinType {ffun aT -> rT} (finMixin (fun=> rT)).
Canonical dfinfun_finType rT :=
  FinType (dffun_aT rT finType) (finMixin rT).

End InheritedStructures.

Section FinFunTuple.

Context {T : Type} {n : nat}.

Definition tuple_of_finfun (f : T ^ n) : n.-tuple T := [tuple f i | i < n].

Definition finfun_of_tuple (t : n.-tuple T) : (T ^ n) := [ffun i => tnth t i].

Lemma finfun_of_tupleK : cancel finfun_of_tuple tuple_of_finfun.
Proof.
by move=> t; apply: eq_from_tnth => i; rewrite tnth_map ffunE tnth_ord_tuple.
Qed.

Lemma tuple_of_finfunK : cancel tuple_of_finfun finfun_of_tuple.
Proof.
by move=> f; apply/ffunP => i; rewrite ffunE tnth_map tnth_ord_tuple.
Qed.

End FinFunTuple.

Section FunPlainTheory.

Variables (aT : finType) (rT : Type).
Notation fT := {ffun aT -> rT}.
Implicit Types (f : fT) (R : pred rT).

Definition fgraph f := codom_tuple f.

Definition Finfun (G : #|aT|.-tuple rT) := [ffun x => tnth G (enum_rank x)].

Lemma tnth_fgraph f i : tnth (fgraph f) i = f (enum_val i).
Proof. by rewrite tnth_map /tnth -enum_val_nth. Qed.

Lemma FinfunK : cancel Finfun fgraph.
Proof.
by move=> G; apply/eq_from_tnth=> i; rewrite tnth_fgraph ffunE enum_valK.
Qed.

Lemma fgraphK : cancel fgraph Finfun.
Proof. by move=> f; apply/ffunP=> x; rewrite ffunE tnth_fgraph enum_rankK. Qed.

Lemma fgraph_ffun0 aT0 : fgraph (ffun0 aT0) = nil :> seq rT.
Proof. by apply/nilP/eqP; rewrite size_tuple. Qed.

Lemma codom_ffun f : codom f = fgraph f. Proof. by []. Qed.

Lemma tagged_tfgraph f : @map _ rT tagged (tfgraph f) = fgraph f.
Proof. by rewrite -map_comp. Qed.

Lemma eq_ffun (g1 g2 : aT -> rT) : g1 =1 g2 -> finfun g1 = finfun g2.
Proof. exact: eq_dffun. Qed.

Lemma fgraph_codom f : fgraph f = codom_tuple f.
Proof. exact/esym/val_inj/codom_ffun. Qed.

Definition ffun_on_mem (mR : mem_pred rT) := family_mem (fun _ : aT => mR).

Lemma ffun_onP R f : reflect (forall x, f x \in R) (f \in ffun_on_mem (mem R)).
Proof. exact: forallP. Qed.

End FunPlainTheory.

Arguments Finfun {aT rT} G.
Arguments fgraph {aT rT} f.
Arguments FinfunK {aT rT} G : rename.
Arguments fgraphK {aT rT} f : rename.
Arguments eq_ffun {aT rT} [g1] g2 eq_g12.
Arguments ffun_onP {aT rT R f}.

Notation ffun_on R := (ffun_on_mem _ (mem R)).
Notation "@ 'ffun_on' aT R" :=
  (ffun_on R : simpl_pred (finfun_of (Phant (aT -> id _))))
  (at level 10, aT, R at level 9).

Lemma nth_fgraph_ord T n (x0 : T) (i : 'I_n) f : nth x0 (fgraph f) i = f i.
Proof.
by rewrite -[i in RHS]enum_rankK -tnth_fgraph  (tnth_nth x0) enum_rank_ord.
Qed.

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

Section Support.

Variables (aT : Type) (rT : eqType).

Definition support_for y (f : aT -> rT) := [pred x | f x != y].

Lemma supportE x y f : (x \in support_for y f) = (f x != y). Proof. by []. Qed.

End Support.

Notation "y .-support" := (support_for y)
  (at level 2, format "y .-support") : fun_scope.

Section EqTheory.

Variables (aT : finType) (rT : eqType).
Notation fT := {ffun aT -> rT}.
Implicit Types (y : rT) (D : {pred aT}) (R : {pred rT}) (f : fT).

Lemma supportP y D g :
  reflect (forall x, x \notin D -> g x = y) (y.-support g \subset D).
Proof.
by apply: (iffP subsetP) => Dg x; [apply: contraNeq | apply: contraR] => /Dg->.
Qed.

Definition pfamily_mem y mD (mF : aT -> mem_pred rT) :=
  family (fun i : aT => if in_mem i mD then pred_of_simpl (mF i) else pred1 y).

Lemma pfamilyP (pT : predType rT) y D (F : aT -> pT) f :
  reflect (y.-support f \subset D /\ {in D, forall x, f x \in F x})
          (f \in pfamily_mem y (mem D) (fmem F)).
Proof.
apply: (iffP familyP) => [/= f_pfam | [/supportP f_supp f_fam] x].
  split=> [|x Ax]; last by have:= f_pfam x; rewrite Ax.
  by apply/subsetP=> x; case: ifP (f_pfam x) => //= _ fx0 /negP[].
by case: ifPn => Ax /=; rewrite inE /= (f_fam, f_supp).
Qed.

Definition pffun_on_mem y mD mR := pfamily_mem y mD (fun _ => mR).

Lemma pffun_onP y D R f :
  reflect (y.-support f \subset D /\ {subset image f D <= R})
          (f \in pffun_on_mem y (mem D) (mem R)).
Proof.
apply: (iffP (pfamilyP y D (fun _ => R) f)) => [] [-> f_fam]; split=> //.
  by move=> _ /imageP[x Ax ->]; apply: f_fam.
by move=> x Ax; apply: f_fam; apply/imageP; exists x.
Qed.

End EqTheory.

Arguments supportP {aT rT y D g}.
Arguments pfamilyP {aT rT pT y D F f}.
Arguments pffun_onP {aT rT y D R f}.

Notation pfamily y D F := (pfamily_mem y (mem D) (fmem F)).
Notation pffun_on y D R := (pffun_on_mem y (mem D) (mem R)).

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

Section FinDepTheory.

Variables (aT : finType) (rT : aT -> finType).
Notation fT := {dffun forall x : aT, rT x}.

Lemma card_family (F : forall x, pred (rT x)) :
  #|(family F : simpl_pred fT)| = foldr muln 1 [seq #|F x| | x : aT].
Proof.
rewrite /image_mem; set E := enum aT in (uniqE := enum_uniq aT) *.
have trivF x: x \notin E -> #|F x| = 1 by rewrite mem_enum.
elim: E uniqE => /= [_ | x0 E IH_E /andP[E'x0 uniqE]] in F trivF *.
  have /fin_all_exists[f0 Ff0] x: exists y0, F x =i pred1 y0.
    have /pred0Pn[y Fy]: #|F x| != 0 by rewrite trivF.
    by exists y; apply/fsym/subset_cardP; rewrite ?subset_pred1 // card1 trivF.
  apply: eq_card1 (finfun f0 : fT) _ _ => f; apply/familyP/eqP=> [Ff | {f}-> x].
    by apply/ffunP=> x; have /[!(Ff0, ffunE)]/eqP := Ff x.
  by rewrite ffunE Ff0 inE /=.
have [y0 Fxy0 | Fx00] := pickP (F x0); last first.
  by rewrite !eq_card0 // => f; apply: contraFF (Fx00 (f x0))=> /familyP; apply.
pose F1 x := if eqP is ReflectT Dx then xpred1 (ecast x (rT x) Dx y0) else F x.
transitivity (#|[predX F x0 & family F1 : pred fT]|); last first.
  rewrite cardX {}IH_E {uniqE}// => [|x E'x]; last first.
    rewrite /F1; case: eqP => [Dx | /nesym/eqP-x0'x]; first exact: card1.
    by rewrite trivF // negb_or x0'x.
  congr (_ * foldr _ _ _); apply/eq_in_map=> x Ex.
  by rewrite /F1; case: eqP => // Dx0; rewrite Dx0 Ex in E'x0.
pose g yf : fT := let: (y, f) := yf : rT x0 * fT in
  [ffun x => if eqP is ReflectT Dx then ecast x (rT x) Dx y else f x].
have gK: cancel (fun f : fT => (f x0, g (y0, f))) g.
  by move=> f; apply/ffunP=> x; rewrite !ffunE; case: eqP => //; case: x /.
rewrite -(card_image (can_inj gK)); apply: eq_card => [] [y f] /=.
apply/imageP/andP=> [[f1 /familyP/=Ff1] [-> ->]| [/=Fx0y /familyP/=Ff]].
  split=> //; apply/familyP=> x; rewrite ffunE /F1 /=.
  by case: eqP => // Dx; apply: eqxx.
exists (g (y, f)).
  by apply/familyP=> x; have:= Ff x; rewrite ffunE /F1; case: eqP; [case: x /|].
congr (_, _); first by rewrite /= ffunE; case: eqP => // Dx; rewrite eq_axiomK.
by apply/ffunP=> x; have:= Ff x; rewrite !ffunE /F1; case: eqP => // Dx /eqP.
Qed.

Lemma card_dep_ffun : #|fT| = foldr muln 1 [seq #|rT x| | x : aT].
Proof. by rewrite -card_family; apply/esym/eq_card=> f; apply/familyP. Qed.

End FinDepTheory.

Section FinFunTheory.

Variables aT rT : finType.
Notation fT := {ffun aT -> rT}.
Implicit Types (D : {pred aT}) (R : {pred rT}) (F : aT -> pred rT).

Lemma card_pfamily y0 D F :
  #|pfamily y0 D F| = foldr muln 1 [seq #|F x| | x in D].
Proof.
rewrite card_family !/(image _ _) /(enum D) -enumT /=.
by elim: (enum aT) => //= x E ->; have [// | D'x] := ifP; rewrite card1 mul1n.
Qed.

Lemma card_pffun_on y0 D R : #|pffun_on y0 D R| = #|R| ^ #|D|.
Proof.
rewrite (cardE D) card_pfamily /image_mem.
by elim: (enum D) => //= _ e ->; rewrite expnS.
Qed.

Lemma card_ffun_on R : #|@ffun_on aT R| = #|R| ^ #|aT|.
Proof.
rewrite card_family /image_mem cardT.
by elim: (enum aT) => //= _ e ->; rewrite expnS.
Qed.

Lemma card_ffun : #|fT| = #|rT| ^ #|aT|.
Proof. by rewrite -card_ffun_on; apply/esym/eq_card=> f; apply/forallP. Qed.

End FinFunTheory.


From Undecidability.L Require Import LTactics.
Require Import Undecidability.Shared.Libs.PSL.Vectors.Vectors.
Require Import Vector List.
Import ListNotations.
Import VectorNotations.
Import L_Notations.

Fixpoint many_lam k s := match k with 0 => s | S k => lam (many_lam k s) end.

Lemma subst_many_lam k n u s :
  subst (many_lam k s) n u = many_lam k (subst s (k + n) u).
Proof.
  induction k in n |- *; cbn.
  - reflexivity.
  - f_equal. rewrite IHk. repeat f_equal. lia.
Qed.

Fixpoint many_app k s (v : Vector.t term k) :=
    match v with
    | Vector.nil => s
    | Vector.cons x _ v => many_app (L.app s x) v
    end.

Lemma subst_many_app k (v : Vector.t term k) n u s :
  subst (many_app s v) n u = many_app (subst s n u) (Vector.map (fun s => subst s n u) v).
Proof.
  induction v in s |- *; cbn.
  - reflexivity.
  - now rewrite IHv.
Qed.

Lemma equiv_many_app_L k (v : Vector.t term k) s t :
  s == t -> many_app s v == many_app t v.
Proof.
  induction v in s, t |- *; intros H; cbn.
  - eassumption.
  - eapply IHv. now rewrite H.
Qed.

Fixpoint tabulate {X : Type} (n : nat) (f : Fin.t n -> X) {struct n} : Vector.t X n :=
  match n as m return ((Fin.t m -> X) -> t X m) with
  | 0 => fun _ => []
  | S m => fun f => f Fin.F1 :: @tabulate _ m (fun i => f (Fin.FS i))
  end f.

Definition many_vars k := (tabulate (n := k) (fun i => k - S (proj1_sig (Fin.to_nat i)))).

Lemma tabulate_ext {X} k f1 f2 :
  (forall i, f1 i = f2 i :> X) -> tabulate (n := k) f1 = tabulate f2.
Proof.
  intros H. induction k in f1, f2, H |- *; cbn.
  - reflexivity.
  - f_equal; eauto.
Qed.

Lemma many_vars_S n :
  many_vars (S n) = n :: many_vars n.
Proof.
  cbn. f_equal. unfold many_vars. lia. eapply tabulate_ext. intros i. destruct Fin.to_nat as [i_ Hi].
  reflexivity.
Qed.

Fixpoint many_subst {k} s n (v : Vector.t term k) :=
  match v with
  | [] => s
  | Vector.cons u k v => many_subst (subst s (n + k) u) n v
  end.

Lemma beta_red s t t' : lambda t -> t' == subst s 0 t -> (lam s) t == t'.
Proof.
  intros [u ->] ->. repeat econstructor.
Qed.

Lemma many_beta k (v : Vector.t term k) s :
  (forall x, Vector.In x v -> proc x) ->
  many_app (many_lam k s) v == many_subst s 0 v.
Proof.
  induction v in s |- *; cbn; intros Hv.
  - reflexivity.
  - rewrite equiv_many_app_L. 2:{ eapply beta_red. eapply Hv. econstructor. reflexivity. }
    rewrite subst_many_lam. replace (n + 0) with n by lia. rewrite IHv. reflexivity.
    intros. eapply Hv. now econstructor.
Qed.

Lemma many_subst_app (s t : term) {k} n (v : Vector.t term k) :
  many_subst (s t) n v = (many_subst s n v) (many_subst t n v).
Proof.
  induction v in n, s, t |- *.
  - reflexivity.
  - cbn. now rewrite IHv.
Qed.

Lemma many_subst_many_app (s : term) {k} n (ts v : Vector.t term k) :
  many_subst (many_app s ts) n v = many_app (many_subst s n v) (Vector.map (fun t => many_subst t n v) ts).
Proof.
  induction v in n, s, ts |- *.
  - cbn. revert ts. apply case0. reflexivity.
  - cbn. apply (caseS' ts). cbn. intros.
    rewrite subst_many_app, IHv. cbn. rewrite many_subst_app.
    now rewrite Vector.map_map.
Qed.

Lemma many_subst_closed (s : term) {k} n (v : Vector.t term k) :
  closed s -> many_subst s n v = s.
Proof.
  induction v in n, s |- *.
  - reflexivity.
  - cbn. intros H. rewrite H. now eapply IHv.
Qed.


(** This file is still experimental. See its tracking issue
https://gitlab.mpi-sws.org/iris/iris/-/issues/439 for details on remaining
issues before stabilization. *)
(** Ghost state for a append-only list, wrapping the [mono_listR] RA. This
  provides three assertions:
  - an authoritative proposition [mono_list_auth_own γ q l] for the authoritative
    list [l]
  - a persistent assertion [mono_list_lb_own γ l] witnessing that the authoritative
    list is at least [l]
  - a persistent assertion [mono_list_idx_own γ i a] witnessing that the index [i]
    is [a] in the authoritative list.

The key rules are [mono_list_lb_own_valid], which asserts that an auth at [l]
and a lower-bound at [l'] imply that [l' `prefix_of` l], and [mono_list_update],
which allows one to grow the auth element by appending only. At any time the
auth list can be "snapshotted" with [mono_list_lb_own_get] to produce a
persistent lower-bound. *)
From iris.proofmode Require Import tactics.
From iris.algebra.lib Require Import mono_list.
From iris.bi.lib Require Import fractional.
From iris.base_logic.lib Require Export own.
From iris.prelude Require Import options.

Class mono_listG (A : Type) Σ :=
  MonoListG { mono_list_inG : inG Σ (mono_listR (leibnizO A)) }.
Local Existing Instance mono_list_inG.

Definition mono_listΣ (A : Type) : gFunctors :=
  #[GFunctor (mono_listR (leibnizO A))].

Global Instance subG_mono_listΣ {A Σ} :
  subG (mono_listΣ A) Σ → (mono_listG A) Σ.
Proof. solve_inG. Qed.

Local Definition mono_list_auth_own_def `{!mono_listG A Σ}
    (γ : gname) (q : Qp) (l : list A) : iProp Σ :=
  own γ (●ML{#q} (l : listO (leibnizO A))).
Local Definition mono_list_auth_own_aux : seal (@mono_list_auth_own_def).
Proof. by eexists. Qed.
Definition mono_list_auth_own := mono_list_auth_own_aux.(unseal).
Local Definition mono_list_auth_own_unseal :
  @mono_list_auth_own = @mono_list_auth_own_def := mono_list_auth_own_aux.(seal_eq).
Global Arguments mono_list_auth_own {A Σ _} γ q l.

Local Definition mono_list_lb_own_def `{!mono_listG A Σ}
    (γ : gname) (l : list A) : iProp Σ :=
  own γ (◯ML (l : listO (leibnizO A))).
Local Definition mono_list_lb_own_aux : seal (@mono_list_lb_own_def).
Proof. by eexists. Qed.
Definition mono_list_lb_own := mono_list_lb_own_aux.(unseal).
Local Definition mono_list_lb_own_unseal :
  @mono_list_lb_own = @mono_list_lb_own_def := mono_list_lb_own_aux.(seal_eq).
Global Arguments mono_list_lb_own {A Σ _} γ l.

Definition mono_list_idx_own `{!mono_listG A Σ}
    (γ : gname) (i : nat) (a : A) : iProp Σ :=
  ∃ l : list A, ⌜ l !! i = Some a ⌝ ∗ mono_list_lb_own γ l.

Local Ltac unseal := rewrite
  /mono_list_idx_own ?mono_list_auth_own_unseal /mono_list_auth_own_def
  ?mono_list_lb_own_unseal /mono_list_lb_own_def.

Section mono_list_own.
  Context `{!mono_listG A Σ}.
  Implicit Types (l : list A) (i : nat) (a : A).

  Global Instance mono_list_auth_own_timeless γ q l : Timeless (mono_list_auth_own γ q l).
  Proof. unseal. apply _. Qed.
  Global Instance mono_list_lb_own_timeless γ l : Timeless (mono_list_lb_own γ l).
  Proof. unseal. apply _. Qed.
  Global Instance mono_list_lb_own_persistent γ l : Persistent (mono_list_lb_own γ l).
  Proof. unseal. apply _. Qed.
  Global Instance mono_list_idx_own_timeless γ i a :
    Timeless (mono_list_idx_own γ i a) := _.
  Global Instance mono_list_idx_own_persistent γ i a :
    Persistent (mono_list_idx_own γ i a) := _.

  Global Instance mono_list_auth_own_fractional γ l :
    Fractional (λ q, mono_list_auth_own γ q l).
  Proof. unseal. intros p q. by rewrite -own_op -mono_list_auth_dfrac_op. Qed.
  Global Instance mono_list_auth_own_as_fractional γ q l :
    AsFractional (mono_list_auth_own γ q l) (λ q, mono_list_auth_own γ q l) q.
  Proof. split; [auto|apply _]. Qed.

  Lemma mono_list_auth_own_agree γ q1 q2 l1 l2 :
    mono_list_auth_own γ q1 l1 -∗
    mono_list_auth_own γ q2 l2 -∗
    ⌜(q1 + q2 ≤ 1)%Qp ∧ l1 = l2⌝.
  Proof.
    unseal. iIntros "H1 H2".
    by iCombine "H1 H2" gives %?%mono_list_auth_dfrac_op_valid_L.
  Qed.
  Lemma mono_list_auth_own_exclusive γ l1 l2 :
    mono_list_auth_own γ 1 l1 -∗ mono_list_auth_own γ 1 l2 -∗ False.
  Proof.
    iIntros "H1 H2".
    iDestruct (mono_list_auth_own_agree with "H1 H2") as %[]; done.
  Qed.

  Lemma mono_list_auth_lb_valid γ q l1 l2 :
    mono_list_auth_own γ q l1 -∗
    mono_list_lb_own γ l2 -∗
    ⌜ (q ≤ 1)%Qp ∧ l2 `prefix_of` l1 ⌝.
  Proof.
    unseal. iIntros "Hauth Hlb".
    by iCombine "Hauth Hlb" gives %?%mono_list_both_dfrac_valid_L.
  Qed.

  Lemma mono_list_lb_valid γ l1 l2 :
    mono_list_lb_own γ l1 -∗
    mono_list_lb_own γ l2 -∗
    ⌜ l1 `prefix_of` l2 ∨ l2 `prefix_of` l1 ⌝.
  Proof.
    unseal. iIntros "H1 H2".
    by iCombine "H1 H2" gives %?%mono_list_lb_op_valid_L.
  Qed.

  Lemma mono_list_idx_agree γ i a1 a2 :
    mono_list_idx_own γ i a1 -∗ mono_list_idx_own γ i a2 -∗ ⌜ a1 = a2 ⌝.
  Proof.
    iDestruct 1 as (l1 Hl1) "H1". iDestruct 1 as (l2 Hl2) "H2".
    iDestruct (mono_list_lb_valid with "H1 H2") as %Hpre.
    iPureIntro.
    destruct Hpre as [Hpre|Hpre]; eapply prefix_lookup_Some in Hpre; eauto; congruence.
  Qed.

  Lemma mono_list_auth_idx_lookup γ q l i a :
    mono_list_auth_own γ q l -∗ mono_list_idx_own γ i a -∗ ⌜ l !! i = Some a ⌝.
  Proof.
    iIntros "Hauth". iDestruct 1 as (l1 Hl1) "Hl1".
    iDestruct (mono_list_auth_lb_valid with "Hauth Hl1") as %[_ Hpre].
    iPureIntro.
    eapply prefix_lookup_Some in Hpre; eauto; congruence.
  Qed.

  Lemma mono_list_lb_own_get γ q l :
    mono_list_auth_own γ q l -∗ mono_list_lb_own γ l.
  Proof. intros. unseal. by apply own_mono, mono_list_included. Qed.
  Lemma mono_list_lb_own_le {γ l} l' :
    l' `prefix_of` l →
    mono_list_lb_own γ l -∗ mono_list_lb_own γ l'.
  Proof. unseal. intros. by apply own_mono, mono_list_lb_mono. Qed.

  Lemma mono_list_idx_own_get {γ l} i a :
    l !! i = Some a →
    mono_list_lb_own γ l -∗ mono_list_idx_own γ i a.
  Proof. iIntros (Hli) "Hl". iExists l. by iFrame. Qed.

  Lemma mono_list_own_alloc l :
    ⊢ |==> ∃ γ, mono_list_auth_own γ 1 l ∗ mono_list_lb_own γ l.
  Proof.
    unseal. setoid_rewrite <- own_op. by apply own_alloc, mono_list_both_valid_L.
  Qed.
  Lemma mono_list_auth_own_update {γ l} l' :
    l `prefix_of` l' →
    mono_list_auth_own γ 1 l ==∗ mono_list_auth_own γ 1 l' ∗ mono_list_lb_own γ l'.
  Proof.
    iIntros (?) "Hauth".
    iAssert (mono_list_auth_own γ 1 l') with "[> Hauth]" as "Hauth".
    { unseal. iApply (own_update with "Hauth"). by apply mono_list_update. }
    iModIntro. iSplit; [done|]. by iApply mono_list_lb_own_get.
  Qed.

  Lemma mono_list_auth_own_update_app {γ l} l' :
    mono_list_auth_own γ 1 l ==∗
    mono_list_auth_own γ 1 (l ++ l') ∗ mono_list_lb_own γ (l ++ l').
  Proof. by apply mono_list_auth_own_update, prefix_app_r. Qed.
End mono_list_own.


Set Implicit Arguments.

Require Import Bedrock.Platform.Cito.FreeVars.
Require Import Bedrock.StringSet.
Import StringSet.
Require Import Bedrock.Platform.Cito.StringSetFacts.

Definition get_local_vars stmt arg_vars ret_var :=
  elements (diff (add ret_var (free_vars stmt)) (of_list arg_vars)).

Require Import Bedrock.Platform.Cito.SetoidListFacts.
Require Import Bedrock.Platform.Cito.GeneralTactics2.

Lemma ret_in_vars : forall arg_vars s r, List.In r (arg_vars ++ get_local_vars s arg_vars r).
  intros; apply List.in_or_app.
  destruct (List.In_dec String.string_dec r arg_vars); try solve [intuition]; intros.
  right.
  unfold get_local_vars; simpl.
  eapply InA_eq_In_iff.
  eapply elements_1.
  eapply diff_iff.
  split.
  eapply add_iff; eauto.
  not_not.
  eapply of_list_spec; eauto.
Qed.