Require Import Metalib.Metatheory.
Require Import Program.Equality.
Require Export Infra.

Lemma sub_regular : forall E A B,
    Sub E A B -> wf_env E /\ WFS E A /\ WFS E B.
Proof with auto.
  intros.
  induction H...
  destruct IHSub1.
  destruct IHSub2.
  destruct H2.
  destruct H4.
  split...
  split.
  pick fresh X.
  specialize (H0 0 X).
  assert (X \notin L) by auto.
  apply H0 in H1.
  destruct H1.
  dependent destruction H1...
  split;apply WFS_rec with (L:=L);intros;
  apply H0...
Qed.

Lemma refl : forall E A,
    wf_env E -> WFS E A -> Sub E  A A.
Proof with auto.
  intros.
  induction H0...
  apply SA_rec with (L:=L \u dom E)...
Defined.

Lemma trans_aux: forall B E,
    WFS E B -> forall A C,
    Sub E A B -> Sub E B C -> Sub E A C.
Proof with auto.
  intros B E H.
  dependent induction H;intros...
  -
    dependent destruction H0.
    dependent destruction H...
  -
    dependent destruction H.
    dependent destruction H0...
  -
    dependent destruction H0.
    dependent destruction H2...
  -
    dependent destruction H1.
    dependent destruction H2...
    constructor...
    constructor...
    apply sub_regular in H1_...
    apply H1_.
    apply sub_regular in H1_0...
    apply H1_0.
  -
    dependent destruction H1.
    dependent destruction H2...
    constructor...
    apply WFS_rec with (L:=L0)...
    intros...
    specialize (H1 n X H4).
    apply sub_regular in H1...
    destruct H1...
    destruct H5...
    apply SA_rec with (L:=L \u L0 \u L1).
    intros.
    apply H0 with (n:=n)...
Qed.

Lemma Transitivity: forall B E A C,
    Sub E A B -> Sub E B C -> Sub E A C.
Proof with auto.
  intros.
  apply trans_aux with (B:=B)...
  apply sub_regular in H0.
  destruct H0.
  destruct H1...
Qed.

Lemma Sub_weakening: forall E E1 E2 A B,
    Sub (E1++E2) A B ->
    wf_env (E1 ++ E ++ E2) ->
    Sub (E1++E++E2) A B.
Proof with auto.
  intros.
  generalize dependent E.
  dependent induction H;intros...
  -
    constructor...
    apply wfs_weakening...
  -
    apply SA_rec with (L:=L \u dom (E1 ++ E ++ E2))...
    intros.
    rewrite_alist (([(X, bind_sub)] ++ E1) ++ E ++ E2).
    apply H0...
    rewrite_alist ([(X, bind_sub)] ++ E1 ++ E ++ E2)...
Qed.

Lemma wfs_replacing: forall E1 E2 T X Y,
    WFS (E1++ X ~ bind_sub ++E2) T ->
    X <> Y ->
    WFS (E1++ Y ~ bind_sub ++E2) (subst_tt X Y T).
Proof with auto.
  intros.
  generalize dependent Y.
  dependent induction H;intros...
  -
    simpl.
    destruct (X0==X)...
    constructor.
    analyze_binds H.
  -
    simpl.
    rewrite_alist (E1 ++ Y ~ bind_sub ++ E2).
    constructor...
  -
    simpl.
    apply WFS_rec with (L:=L \u {{X}}).
    intros.
    rewrite <- subst_open_unfoldn...
    rewrite_alist (([(X0, bind_sub)] ++ E1) ++ Y ~ bind_sub ++ E2).
    apply H0...
Qed.

Lemma Sub_replacing: forall E1 E2 A B X Y,
    Sub (E1++ X ~ bind_sub ++E2) A B ->
    X <> Y ->
    wf_env (E1 ++ Y ~ bind_sub ++ E2) ->
    Sub (E1++ Y ~ bind_sub ++E2) (subst_tt X Y A) (subst_tt X Y B).
Proof with auto.
  intros.
  generalize dependent Y.
  dependent induction H;intros...
  -
    simpl.
    destruct (X0==X)...
    analyze_binds H0.
  -
    simpl.
    constructor...
    rewrite_alist (E1 ++ [(Y, bind_sub)] ++ E2).
    apply wfs_replacing...
  -
    simpl.
    rewrite_alist (E1 ++ [(Y, bind_sub)] ++ E2).
    constructor...
  -
    simpl.
    apply SA_rec with (L:=L  \u {{X}} \u dom (E1 ++ [(Y, bind_sub)] ++ E2) )...
    intros.
    rewrite <- subst_open_unfoldn...
    rewrite <- subst_open_unfoldn...
    rewrite_alist (([(X0, bind_sub)] ++ E1) ++ Y ~ bind_sub ++ E2).
    apply H0...
    rewrite_alist ([(X0, bind_sub)] ++ E1 ++ [(Y, bind_sub)] ++ E2).
    constructor...
Qed.

Lemma subst_wfs_unfoldn: forall n T X E1 E2,
    WFS (E1 ++ X ~ bind_sub ++ E2) (unfoldT T X n) ->
    forall Y, Y \notin fv_tt T \u {{X}} -> X \notin fv_tt T ->
    WFS (E1 ++ Y ~ bind_sub ++ E2) (unfoldT T Y n).
Proof with auto.
  intros.
  rewrite <- unfoldT_subst with (X:=X)...
  apply wfs_replacing...
Qed.

Lemma subst_sub_unfoldn: forall n C D X E1 E2,
    Sub (E1 ++ X ~ bind_sub ++ E2) (unfoldT C X n) (unfoldT D X n) ->
    forall Y, Y \notin fv_tt C \u fv_tt D \u {{X}} ->
              X \notin fv_tt C \u fv_tt D ->
              wf_env (E1 ++ Y ~ bind_sub  ++ E2) ->
              Sub (E1 ++ Y ~ bind_sub  ++ E2) (unfoldT C Y n) (unfoldT D Y n).
Proof with auto.
  intros.
  rewrite <- unfoldT_subst with (X:=X)...
  remember (subst_tt X Y (unfoldT C X n)).
  rewrite <- unfoldT_subst with (X:=X)...
  subst.
  apply Sub_replacing...
Qed.

Lemma wfs_permutation: forall E E1 E2 E3 A,
    WFS (E ++ E1 ++ E2 ++ E3) A ->
    WFS (E ++ E2 ++ E1 ++ E3) A.
Proof with auto.
  intros.
  dependent induction H...
  -
    constructor.
    apply in_app_iff in H.
    destruct H.
    apply In_lemmaL...
    apply in_app_iff in H.
    destruct H.
    apply In_lemmaR.
    apply In_lemmaR...
    apply In_lemmaL...
    apply in_app_iff in H.
    destruct H.
    apply In_lemmaR...
    apply In_lemmaL...
    apply In_lemmaR...
    apply In_lemmaR...
    apply In_lemmaR...
  -
    apply WFS_rec with (L:=L)...
    intros.
    rewrite_alist (([(X, bind_sub)] ++ E) ++ E2 ++ E1 ++ E3).
    apply H0...
Qed.

Lemma Sub_permutation: forall E E1 E2 E3 A B,
    Sub (E ++ E1 ++ E2 ++ E3) A B ->
    wf_env (E ++ E2 ++ E1 ++ E3) ->
    Sub (E ++ E2 ++ E1 ++ E3) A B.
Proof with auto.
  intros.
  dependent induction H...
  -
    constructor...
    analyze_binds H0...
  -
    constructor...
    apply wfs_permutation...
  -
    apply SA_rec with (L:=L \u dom (E ++ E2 ++ E1 ++ E3 ))...
    intros.
    rewrite_alist (([(X, bind_sub)] ++ E) ++ E2 ++ E1 ++ E3).
    apply H0...
    rewrite_alist ([(X, bind_sub)] ++ E ++ E2 ++ E1 ++ E3)...
Qed.

Lemma strengthening_wfs: forall E1 E2 T X m,
    WFS (E1 ++ X ~ m ++ E2) T->
    X \notin fv_tt T ->
    WFS (E1 ++ E2) T.
Proof with auto.
  intros.
  dependent induction H...
  -
    analyze_binds H...
    simpl.
    apply D.F.singleton_iff...
  -
    simpl in H1.
    constructor...
    apply IHWFS1 with (X0:=X) (m0:=m)...
    apply IHWFS2 with (X0:=X) (m0:=m)...
  -
    simpl in H1.
    apply WFS_rec with (L:=L \u {{X}}).
    intros.
    rewrite_alist (([(X0, bind_sub)] ++ E1) ++ E2).
    apply H0 with (X1:=X) (m0:=m)...
    apply notin_fv_tt_open...
Qed.

Lemma strengthening_sub: forall E1 E2 A B X m,
    Sub (E1 ++ X ~ m ++ E2) A B ->
    X \notin (fv_tt A \u fv_tt B) ->
    wf_env  (E1 ++ E2 ) ->
    Sub (E1 ++ E2) A B.
Proof with auto.
  intros.
  dependent induction H...
  -
    constructor...
    analyze_binds H0...
    apply AtomSetImpl.union_2.
    apply D.F.singleton_iff...
  -
    constructor...
    apply strengthening_wfs with (X:=X) (m:=m)...
  -
    simpl in H1.
    constructor...
    apply IHSub1 with (X0:=X) (m0:=m)...
    apply IHSub2 with (X0:=X) (m0:=m)...
  -
    simpl in H1.
    apply SA_rec with (L:=L \u {{X}} \u dom (E1 ++ E2)).
    intros.
    rewrite_alist (([(X0, bind_sub)] ++ E1) ++ E2).
    apply H0 with (X1:=X) (m0:=m)...
    apply notin_union.
    split.
    apply notin_fv_tt_open...
    apply notin_fv_tt_open...
    rewrite_alist ([(X0, bind_sub)] ++ E1 ++ E2).
    constructor...
Qed.

Lemma wf_env_strengthening: forall E1 E2 X,
    wf_env (E1++E2) ->
    X \notin dom (E1++E2) ->
    wf_env (E1 ++ X ~ bind_sub ++ E2).
Proof with auto.
  induction E1;intros...
  constructor...
  rewrite_alist (a :: (E1 ++ [(X, bind_sub)] ++ E2)).
  destruct a.
  simpl in *.
  destruct b...
  constructor...
  eapply IHE1...
  dependent destruction H...
  dependent destruction H...
  constructor...
  eapply IHE1...
  dependent destruction H...
  dependent destruction H...
  rewrite_alist (E1 ++ (X~ bind_sub) ++ E2).
  apply wfs_weakening...
  dependent destruction H...
Qed.

Lemma subst_rec: forall E1 E2 X A B,
    Sub (E1 ++ X ~ bind_sub ++ E2) A B ->
    wf_env (E1 ++ E2) ->
    forall  C D ,
      WFS (E1 ++ E2) (typ_mu C) -> WFS (E1 ++ E2) (typ_mu D) ->
      X \notin fv_tt C \u fv_tt D \u dom (E1 ++ E2)  ->
    (forall n, Sub (E1 ++ X ~ bind_sub ++ E2) (subst_tt X (unfoldT C X n) A) (subst_tt X (unfoldT D X n) B)) ->
    Sub (E1 ++ E2) (subst_tt X (typ_mu C) A) (subst_tt X (typ_mu D) B).
Proof with auto.
  intros E1 E2 X A B H.
  dependent induction H;intros...
  -
    simpl in *...
    destruct (X0==X)...
    apply SA_rec with (L:={{X}} \u fv_tt C \u fv_tt D \u dom (E1 ++ E2)).
    intros...
    rewrite_alist (nil ++ [(X1, bind_sub)] ++ (E1 ++ E2)).
    apply subst_sub_unfoldn with (X:=X)...
    apply Sub_permutation...
    simpl...
    constructor...
    constructor...
    analyze_binds H0.
  -
    constructor...
    rewrite_alist (nil ++ E1 ++ E2).
    apply subst_tt_wfs2...
    simpl.
    rewrite_alist (nil ++ (X ~ bind_sub) ++ E1 ++ E2).
    apply wfs_permutation...
  -
    simpl in *.
    constructor...
    apply IHSub1...
    intros.
    specialize (H5 n).
    dependent destruction H5...
    apply IHSub2...
    intros.
    specialize (H5 n).
    dependent destruction H5...
  -
    assert (type (typ_mu C)). apply wfs_type with (E:=E1 ++ E2)...
    assert (type (typ_mu D)). apply wfs_type with (E:=E1 ++ E2)...
    simpl in *...
    apply SA_rec with (L:=L \u {{X}} \u fv_tt C \u fv_tt D \u fv_tt A1 \u fv_tt A2 \u dom (E1 ++ E2)).
    intros.
    rewrite <- subst_open_unfoldn...
    rewrite <- subst_open_unfoldn...
    rewrite_alist (([(X0, bind_sub)] ++ E1) ++ E2).
    apply H0...
    +
      constructor...
    +
      rewrite_alist  (nil ++ [(X0, bind_sub)] ++ (E1 ++ E2)).
      apply wfs_weakening...
    +
      rewrite_alist  (nil ++ [(X0, bind_sub)] ++ (E1 ++ E2)).
      apply wfs_weakening...
    +
      intros.
      specialize (H5 n0).
      dependent destruction H5.
      remember (unfoldT C X n0).
      remember (unfoldT D X n0).
      assert (type t).
      {
        dependent destruction H6.
        subst.
        pick fresh Y.
        rewrite <- unfoldT_subst with (X:=Y)...
        apply subst_tt_type...
        apply type_unfoldT...
      }
      assert (type t0).
      {
        dependent destruction H7.
        subst.
        pick fresh Y.
        rewrite <- unfoldT_subst with (X:=Y)...
        apply subst_tt_type...
        apply type_unfoldT...
      }
      rewrite subst_open_unfoldn...
      rewrite subst_open_unfoldn...
      pick fresh X1.
      remember (subst_tt X t A1).
      remember (subst_tt X t0 A2).
      rewrite_alist  (nil ++ [(X0, bind_sub)] ++ (E1 ++ (X, bind_sub) :: E2)) ...
      apply subst_sub_unfoldn with (X:=X1)...
      rewrite_alist ([(X1, bind_sub)] ++ E1 ++ (X, bind_sub) :: E2)...
      assert (X0 \notin fv_tt t1).
      {
        subst.
        apply notin_fv_subst...
        apply notin_fv_tt_open...
      }
      assert (X0 \notin fv_tt t2).
      {
        subst.
        apply notin_fv_subst...
        apply notin_fv_tt_open...
      }
      auto.
      assert (X1 \notin fv_tt t1).
      {
        subst.
        apply notin_fv_subst...
      }
      assert (X1 \notin fv_tt t2).
      {
        subst.
        apply notin_fv_subst...
      }
      auto.
      constructor...
      apply wf_env_strengthening...
Qed.

Lemma unfolding_lemma :
  forall E A B,
    Sub E (typ_mu A) (typ_mu B) ->
    Sub E (open_tt A (typ_mu A)) (open_tt B (typ_mu B)).
Proof with auto.
  intros.
  assert (Hq:=H).
  dependent destruction H.
  pick fresh X.
  assert (X \notin L) by auto.
  apply H with (n:=0) in H0...
  simpl in H0.
  rewrite_alist (nil ++ E).
  rewrite subst_tt_intro with (X:=X)...
  remember (subst_tt X (typ_mu A) (open_tt A X)).
  rewrite subst_tt_intro with (X:=X)...
  subst.
  apply sub_regular in Hq.
  destruct_hypos.
  apply subst_rec...
  intros.
  rewrite unfoldSn...
  rewrite unfoldSn...
  apply H...
Qed.

Lemma completeness_wfa : forall E A, WFS E A -> WFA E A.
  intros.
  induction H; eauto.
  apply WFA_rec with (L := L); intros; eauto.
  specialize (H0 0 X H1); simpl in *. eauto.
Defined.

Lemma completeness_wf : forall E A, WFS E A -> WF E A.
Proof with auto.
  intros.
  induction H...
  apply WF_rec with (L := L); intros...
  specialize (H0 0 X H1)...
  specialize (H0 1 X H1)...
Defined.

Lemma completeness : forall E A B,
    Sub E A B -> sub E A B.
Proof with auto.
  intros.
  induction H; eauto.
  - constructor...
    apply completeness_wf; eauto.
  - apply sa_rec with (L := L); intros.
    specialize (H0 0 X H1); eauto.
    specialize (H0 1 X H1); eauto.
Defined.

Lemma wfs_generalize : forall n E X A,
    X \notin fv_tt A ->
    WFS E (open_tt A (typ_fvar X)) ->
    WFS E (unfoldT A X n).
Proof with auto.
  induction n;intros...
  simpl.
  rewrite subst_tt_intro with (X:=X)...
  apply subst_tt_wfs...
Qed.

Lemma soundness_wfa : forall E A,
    WFA E A -> WFS E A.
Proof with auto.
  intros.
  induction H...
  apply WFS_rec with (L := L \u fv_tt A).
  intros...
  assert (X \notin L) by auto.
  specialize (H0 X H2).
  apply wfs_generalize...
Defined.

Lemma soundness_wf : forall E A,
    WF E A -> WFS E A.
Proof with auto.
  intros.
  induction H...
  apply WFS_rec with (L := L \u fv_tt A);intros...
  assert (X \notin L) by auto.
  specialize (H0 X H4).
  apply wfs_generalize...
Defined.

Lemma refl_algo : forall E A,
    wf_env E -> WFS E A -> sub E  A A.
Proof with auto.
  intros.
  induction H0...
  apply sa_rec with (L:=L \u dom E)...
  intros.
  assert (X \notin L) by auto.
  assert (wf_env ([(X, bind_sub)] ++ E)).
  constructor...
  specialize (H1 0 X H3 H4).
  simpl in H1...
  intros.
  assert (X \notin L) by auto.
  assert (wf_env ([(X, bind_sub)] ++ E)).
  constructor...
  specialize (H1 1 X H3 H4).
  simpl in H1...
Defined.

Lemma suba_regular : forall E A B,
    sub E A B -> wf_env E /\ WF E A /\ WF E B.
Proof with auto.
  intros.
  induction H...
  -
    destruct IHsub1.
    destruct IHsub2.
    destruct H2.
    destruct H4.
    split...
  -
    split.
    pick fresh X.
    specialize (H2 X).
    assert (X \notin L) by auto.
    apply H2 in H3.
    destruct H3.
    dependent destruction H3...
    split;apply WF_rec with (L:=L);intros...
    apply H0...
    apply H2...
    apply H0...
    apply H2...
Qed.

Lemma trans_aux_algo: forall B E,
    WF E B -> forall A C,
    sub E A B -> sub E B C -> sub E A C.
Proof with auto.
  intros B E H.
  dependent induction H;intros...
  -
    dependent destruction H0.
    dependent destruction H...
  -
    dependent destruction H.
    dependent destruction H0...
  -
    dependent destruction H0.
    dependent destruction H2...
  -
    dependent destruction H1.
    dependent destruction H2...
    constructor...
    constructor...
    apply suba_regular in H1_...
    apply H1_.
    apply suba_regular in H1_0...
    apply H1_0.
  -
    dependent destruction H3.
    dependent destruction H5...
    constructor...
    apply WF_rec with (L:=L0);intros...
    specialize (H3 X H7).
    apply suba_regular in H3...
    destruct H3...
    destruct H8...
    specialize (H4 X H7).
    apply suba_regular in H4...
    destruct H4...
    destruct H8...
    apply sa_rec with (L:=L \u L0 \u L1);intros...
Qed.

Lemma trans_algo: forall B E A C,
    sub E A B -> sub E B C -> sub E A C.
Proof with auto.
  intros.
  apply trans_aux_algo with (B:=B)...
  apply suba_regular in H0.
  destruct H0.
  destruct H1...
Qed.

Lemma sub_replacing: forall E1 E2 A B X Y,
    sub (E1++ X ~ bind_sub ++E2) A B ->
    X <> Y ->
    wf_env (E1 ++ Y ~ bind_sub ++ E2) ->
    sub (E1++ Y ~ bind_sub ++E2) (subst_tt X Y A) (subst_tt X Y B).
Proof with auto.
  intros.
  generalize dependent Y.
  dependent induction H;intros...
  -
    simpl.
    destruct (X0==X)...
    analyze_binds H0.
  -
    simpl.
    constructor...
    rewrite_alist (E1 ++ [(Y, bind_sub)] ++ E2).
    apply completeness_wf.
    apply wfs_replacing...
    apply soundness_wf...
  -
    simpl.
    rewrite_alist (E1 ++ [(Y, bind_sub)] ++ E2).
    constructor...
  -
    simpl.
    apply sa_rec with (L:=L  \u {{X}} \u dom (E1 ++ [(Y, bind_sub)] ++ E2) )...
    intros.
    rewrite  subst_tt_open_tt_var...
    rewrite subst_tt_open_tt_var...
    rewrite_alist (([(X0, bind_sub)] ++ E1) ++ Y ~ bind_sub ++ E2).
    apply H0...
    rewrite_alist ([(X0, bind_sub)] ++ E1 ++ [(Y, bind_sub)] ++ E2).
    constructor...
    intros.
    rewrite subst_tt_open_tt_var...
    rewrite subst_tt_open_tt_var...
    rewrite <- subst_tt_open_tt...
    rewrite <- subst_tt_open_tt...
    rewrite_alist (([(X0, bind_sub)] ++ E1) ++ Y ~ bind_sub ++ E2).
    apply H2...
    rewrite_alist ([(X0, bind_sub)] ++ E1 ++ [(Y, bind_sub)] ++ E2).
    constructor...
Qed.

Lemma open_subst_twice : forall A (X Y:atom),
    X \notin fv_tt A ->
    subst_tt X Y (open_tt A (open_tt A X)) = (open_tt A (open_tt A Y)).
Proof with auto.
  intros.
  remember (open_tt A X).
  rewrite subst_tt_open_tt...
  rewrite <- subst_tt_fresh...
  f_equal...
  subst.
  rewrite <- subst_tt_intro...
Qed.


From Undecidability.Shared.Libs.PSL Require Import Base.
Require Import Lia.
Require Import ssrbool.

Ltac simp_bool := repeat match goal with
                  | [ H: negb (?b) = true , H' : ?b = true |- _] => rewrite negb_true_iff in H; congruence
                  | [H : negb (?b) = false |- _] => apply ssrbool.negbFE in H; unfold is_true in H
                  | [H : negb (?b) = true |- _] => apply ssrbool.negbTE in H
                  | [ H : andb (?b1) (?b2) = true |- _] => apply andb_prop in H;
                                                         let a := fresh "H" in
                                                         let b := fresh "H" in
                                                         destruct H as [a b]
                  | [H : true = andb ?b1 ?b2 |- _ ] => symmetry in H; simp_bool
                  | [H : andb (?b1) (?b2) = false |- _] => apply andb_false_elim in H;
                                                         destruct H as [H | H]
                  | [H : false = andb (?b1) (?b2) |- _] => symmetry in H; simp_bool
                  | [ |- context[andb (?b1) (?b2) = false]] => rewrite andb_false_iff
                  | [ |- andb (?b1) (?b2) = true] => apply andb_true_intro
                  | [ H : context [orb (?b1) false] |- _] => rewrite orb_false_r in H
                  | [ |- context [orb ?b1 false] ] => rewrite orb_false_r
                  | [ |- context[negb ?b = true]] => rewrite negb_true_iff
                  | [ |- context[negb ?b = false]] => rewrite negb_false_iff
                  end; try congruence.

Ltac simp_bool' :=  repeat (match goal with
                  | [H : ?b = true |- _ ] => rewrite H in *; clear H
                  | [H : ?b = false |- _] => rewrite H in *; clear H
                  | [H : true = ?b |- _] => symmetry in H; simp_bool
                  | [H : false = ?b |- _] => symmetry in H; simp_bool
                           end; simp_bool).

Local Lemma eqb_false_iff a b : Bool.eqb a b = false <-> a <> b.
Proof.
  split.
  - intros H1 H2%eqb_true_iff; congruence.
  - intros H1; destruct (eqb a b) eqn:H2; try reflexivity. rewrite eqb_true_iff in H2; congruence.
Qed.

Ltac dec_bool := repeat match goal with
                   | [ H : Bool.eqb ?b ?b0 = true |- _ ] =>
                     let h := fresh "H" in assert (Is_true (Bool.eqb b b0)) as h by firstorder;
                                           apply eqb_eq in h; clear H
                   | [H : Bool.eqb ?b ?b0 = false |- _] => apply eqb_false_iff in H
                   | [ H : Nat.eqb ?n ?n0 = true |- _] => apply Nat.eqb_eq in H
                   | [ H : Nat.eqb ?n ?n0 = false |- _] => apply Nat.eqb_neq in H
                   | [  |- Nat.eqb ?n ?n0 = true ] => apply Nat.eqb_eq
                   | [  |- Nat.eqb ?n ?n0 = false] => apply Nat.eqb_neq
                   | [ |- Bool.eqb ?n ?n0 = true] => apply eqb_true_iff
                   | [ |- Bool.eqb ?n ?n0 = false] => apply eqb_false_iff
                   | [ H : Nat.leb ?n ?n0 = true |- _] => apply leb_complete in H
                   | [ H : Nat.leb ?n ?n0 = false |- _ ] => apply leb_complete_conv in H
                   | [  |- Nat.leb ?n ?n0 = true ] => apply leb_correct
                   | [  |- Nat.leb ?n ?n0 = false] => apply leb_correct_conv
                    end; try congruence; try tauto.

Lemma singleton_incl (X : Type) (a : X) (h : list X) :
  [a] <<= h <-> a el h.
Proof.
  split; intros.
  - now apply H.
  - now intros a' [-> | []].
Qed.

Ltac force_In := match goal with
                  | [ |- ?a el ?a :: ?h] => left; reflexivity
                  | [ |- ?a el ?b :: ?h] => right; force_In
                  | [ |- [?a] <<= ?h] => apply singleton_incl; force_In
                  end.

Ltac destruct_or H := match type of H with
                      | ?a \/ ?b => destruct H as [H | H]; try destruct_or H
                        end.
Lemma S_injective a b : S a = S b -> a = b.
Proof. congruence. Qed.

Ltac list_length_inv := repeat match goal with
    | [H : S _ = |?a| |- _] => is_var a; destruct a; cbn in H; [ congruence | apply S_injective in H]
    | [H : 0 = |?a| |- _] => is_var a; destruct a; cbn in H; [ clear H| congruence]
    | [H : |?a| = _ |- _] => symmetry in H
    | [H : S _ >= S _ |- _] => apply Peano.le_S_n in H
    | [H : S _ <= S _ |- _] => apply Peano.le_S_n in H
    | [H :  |?a| >= S _ |- _] => is_var a; destruct a; cbn in H; [lia | ]
    | [H : S _ <= |?a| |- _] => is_var a; destruct a; cbn in H; [lia | ]
end.

Ltac discr_list := repeat match goal with
                    | [ H : |[]| = |?x :: ?xs| |- _] => cbn in H; discriminate H
                    | [ H : |?x :: ?xs| = |[]| |- _] => cbn in H; discriminate H
                    | [H : |?x :: ?xs| = 0 |- _] => cbn in H; discriminate H
                    | [H : 0 = |?x :: ?xs| |- _] => cbn in H; discriminate H
                    | [H : |[]| = S ?z |- _] => cbn in H; discriminate H
                    | [H : S ?z = |[]| |- _] => cbn in H; discriminate H
                    end.
Ltac inv_list := repeat match goal with
                  | [H : |[]| = |?xs| |- _] => destruct xs; [ | discr_list]; cbn in H
                  | [H : |?x :: ?xs| = |?ys| |- _] => destruct ys; [ discr_list  | ]; cbn in H
                  | [H : |?xs| = 0 |- _] => destruct xs; [ | discr_list ]; cbn in H
                  | [H : 0 = |?xs| |- _] => destruct xs; [ | discr_list ]; cbn in H
                  | [H : |?xs| = S ?z |- _] => destruct xs ; [ discr_list | ]; cbn in H
                  | [H : S ?z = |?xs| |- _] => destruct xs; [ discr_list | ]; cbn in H
                  end.

Ltac simp_comp_arith := cbn -[Nat.add Nat.mul]; repeat change (fun x => ?h x) with h.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e256m2e224p2e192p2e96m1_6limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition add :
  { add : feBW_tight -> feBW_tight -> feBW_loose
  | forall a b, phiBW_loose (add a b) = F.add (phiBW_tight a) (phiBW_tight b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_add ().
  Show Ltac Profile.
Time Defined.

Print Assumptions add.


(**
CoLoR, a Coq library on rewriting and termination.
See the COPYRIGHTS and LICENSE files.

- Adam Koprowski, 2004-09-06
- William Delobel, 2005-10-07

* This file provides some basic results concerning relations that were
missing in the standard library.

*)

Set Implicit Arguments.

Require Import RelUtil LogicUtil Max Arith Setoid.
Require Export Relations.

(** Strict order. *)

Section StrictOrder.

  Variable A : Type.
  Variable R : relation A.

  Record strict_order : Prop := {
    sord_trans : transitive R;
    sord_irrefl : irreflexive R
  }.

  Variable so : strict_order.

  Lemma so_not_symmetric : forall a b, R a b -> R b a -> False.

  Proof.
    unfold not; intros a b Rab Rba.
    exact (sord_irrefl so (sord_trans so Rab Rba)).
  Qed.

  Variable eq : relation A.
  Variable Req_compat : forall x x' y y',
    eq x x' -> eq y y' -> R x y -> R x' y'.
  Variable eq_setoid : Setoid_Theory A eq.

  Lemma so_strict : forall x y, eq x y -> R x y -> False.

  Proof.
    intros.
    assert (R y x).
    apply Req_compat with x y; auto.
    apply (Seq_sym A eq eq_setoid); trivial.
    absurd (R x x).
    unfold not; intro xx; exact (sord_irrefl so xx).
    exact (sord_trans so H0 H1).
  Qed.

End StrictOrder.

(** Record types for setoids with decidable equality. *)

Section SetA.

  Record SetA : Type := mkSetA {
    A' : Type}.

End SetA.

(* Record signature Eqset. *)

Section Eqset.

  Parameter A : Type.

  Record Eqset : Type := mkEqset {
    eqA : A -> A -> Prop
  }.

  Variable e: Eqset.

  Parameter sid_theoryA : Setoid_Theory A (eqA e).

  Hint Resolve (Seq_refl  A (eqA e) sid_theoryA) : sets.
  Hint Resolve (Seq_trans A (eqA e) sid_theoryA) : sets.
  Hint Resolve (Seq_sym   A (eqA e) sid_theoryA) : sets.

End Eqset.

(** Record signature [Eqset_dec]. *)

Section Eqset_dec.

  Variable e: Eqset.

  Notation eqA := (eqA e).
  Notation "X =A= Y" := (eqA X Y) (at level 70).

  Parameter eqA_dec : forall x y, {x =A= y} + {~x =A= y}.

End Eqset_dec.

(** Functor Eqset_def. *)

Section Eqset_def.

  Variable e : Eqset.

  Definition eqA' := eq(A:=A).

  Definition sid_theoryA' := Build_Setoid_Theory _ eqA'
    (refl_equal(A:=A) ) (sym_eq (A:=A)) (trans_eq(A:=A)).

  Hint Resolve (Seq_refl A eqA' sid_theoryA') : sets.
  Hint Resolve (Seq_trans A eqA' sid_theoryA') : sets.
  Hint Resolve (Seq_sym A eqA' sid_theoryA') : sets.

End Eqset_def.

(** Record types for ordered setoids. *)

Section Eqset_def_gtA_eqA_compat.

  Variable A : Type.

  Variable gtA : A -> A -> Prop.

  Lemma Eqset_def_gtA_eqA_compat :
    forall x x' y y', x = x' -> y = y' -> gtA x y -> gtA x' y'.

  Proof.
    intros x x' y y' x_x' y_y' x_y.
    rewrite <- x_x'; rewrite <- y_y'; trivial.
  Qed.

End Eqset_def_gtA_eqA_compat.

(** Record signature [Ord]. *)

Section Ord.

  Variable e: Eqset.
  Notation "X =A= Y" := ((eqA e) X Y)(at level 70).

  Record Ord : Type := mkOrd {
    gtA : A -> A -> Prop;
    gtA_eqA_compat : forall x x' y y',
      x =A= x' -> y =A= y' -> gtA x y -> gtA x' y'
    }.

  Notation "X >A Y" := (gtA X Y) (at level 70).

  Hint Resolve gtA_eqA_compat : sets.

End Ord.

(** Functor OrdLemmas (P: Ord). *)

Section OrdLemmas.

  Variable e: Eqset.
  Variable P: Ord e.

  Definition ltA := transp (gtA P).
  Definition geA x y := ~ ltA x y.
  Definition leA x y := ~ (gtA P) x y.
  Definition AccA := Acc ltA.

  Notation "X =A= Y" := (eqA X Y)(at level 70).
  Notation "X <A Y" := (ltA X Y) (at level 70).
  Notation "X >=A Y" := (geA X Y) (at level 70).
  Notation "X <=A Y" := (leA X Y) (at level 70).

  Hint Unfold ltA geA leA AccA : sets.

  Add Setoid A (eqA e) (sid_theoryA e) as sidA.

  Add Morphism (gtA P)
    with signature (eqA e)  ==> (eqA e) ==> iff
      as gtA_morph.
  Proof.
   destruct P; simpl in *.
    split;
    eauto with sets. apply gtA_eqA_compat0.
    sym. hyp.
    apply (Seq_sym _ _ (sid_theoryA e)). hyp.
  Qed.

  Add Morphism ltA
    with signature (eqA e) ==> (eqA e) ==> iff
      as ltA_morph.

  Proof.
    destruct P; simpl in *.
    split; eauto with sets.
    unfold ltA. unfold transp.
    destruct P; simpl in *. eauto with sets.
    unfold ltA. unfold transp.
    destruct P; simpl in *. eauto with sets.
    apply gtA_eqA_compat1. sym. hyp.
    sym. hyp.
  Qed.

  Add Morphism AccA
    with signature (eqA e) ==> iff
      as AccA_morph.

  Proof.
    destruct P. simpl in *.
    intros a b eq_ab. split.
    intro acc_a. inversion acc_a. constructor. intros.
    apply H. rewrite eq_ab. hyp.
    intros acc_b. inversion acc_b. constructor. intros.
    apply H. rewrite <- eq_ab. hyp.
  Qed.

End OrdLemmas.

(** Record signature Poset. *)

Section Poset.

  Variable e: Eqset.
  Variable O : Ord e.

  Parameter gtA_so : strict_order (gtA O).

  Hint Resolve (sord_trans gtA_so) : sets.
  Hint Resolve (sord_irrefl gtA_so) : sets.
  Hint Resolve (so_not_symmetric gtA_so) : sets.
  Hint Resolve (so_strict gtA_so (gtA_eqA_compat O) (sid_theoryA e)) : sets.

End Poset.

(** Functor nat_ord. *)

Section nat_ord.

  Section natSet.
    Definition AN := nat.
    Definition eq_decN := eq_nat_dec.
  End natSet.

  Lemma gtA_eqA_compatnat : forall x x' y y',
    x = x' -> y = y' -> x > y -> x' > y'.

  Proof.
    intros x x' y y' xx' yy'.
    rewrite <- xx'; rewrite <- yy'; trivial.
  Qed.

End nat_ord.

(** Lemmas on transitive closure. *)

Section Transitive_Closure.

  Variable A : Type.
  Variable R : A -> A -> Prop.

  Lemma trans_clos_step_l : forall x y,
    R! x y -> R x y \/ (exists2 z, R x z & R! z y).

  Proof.
    intros x y; compute; intro xy; induction xy.
    left; trivial.
    inversion IHxy1; inversion IHxy2; right; solve [eauto |
      inversion H; try inversion H0; exists x0;
      [trivial | constructor 2 with y; auto]].
  Qed.

  Lemma trans_clos_step_r : forall x y,
    R! x y -> R x y \/ (exists2 z, R! x z & R z y).

  Proof.
    intros x y; compute; intro xy; induction xy.
    left; trivial.
    inversion_clear IHxy1; inversion_clear IHxy2; right;
      solve [eauto | inversion H0; exists x0;
      [constructor 2 with y; auto | trivial]].
  Qed.

  Variable eqA : A -> A -> Prop.

  Parameter sid_theoryAc : Setoid_Theory A eqA.
  Parameter R_eqA_comp : forall x y x' y',
    eqA x x' -> eqA y y' -> R x y -> R x' y'.
  Parameter R_so : strict_order R.

  Hint Resolve R_eqA_comp.

  Lemma trans_clos_mirror : forall x y x' y',
    eqA x x' -> eqA y y' -> R! x y -> R! x' y'.

  Proof.
    intros x y x' y' eq_xx' eq_yy' R_xy.
    case (trans_clos_step_l R_xy).
    intro Rxy; constructor 1; eauto.
    intro R_xzy; destruct R_xzy as [w Rxw R_wy].
    case (trans_clos_step_r R_wy).
    intro Rwy; constructor 1; apply R_eqA_comp with x y;
      solve [trivial | apply (sord_trans R_so) with w; trivial].
    intro R_wpy; destruct R_wpy as [p Rwp R_py].
    constructor 2 with w.
    constructor 1; apply R_eqA_comp with x w;
      solve [trivial | apply (Seq_refl A eqA sid_theoryAc)].
    constructor 2 with p.
    trivial.
    constructor 1; apply R_eqA_comp with p y;
      solve [trivial | apply (Seq_refl A eqA sid_theoryAc)].
  Qed.

  Lemma trans_clos_transp : forall x y, transp (R!) x y <-> (transp R)! x y.

  Proof.
    intros; split; compute.
    induction 1.
    constructor; trivial.
    constructor 2 with y; auto.
    induction 1.
    constructor; trivial.
    constructor 2 with y; auto.
  Qed.

End Transitive_Closure.

(** Specification *)

Section Specif.

  Inductive sigPS2 (A : Type) (P: A -> Prop) (Q: A -> Set) : Type :=
    existPS2: forall x:A, P x -> Q x -> sigPS2 (A:=A) P Q.

  Notation "{ x : A # P & Q }"
    := (sigPS2 (fun x:A => P) (fun x:A => Q)) : type_scope.

  Variable A : Type.
  Variables P Q : A -> Prop.

  Definition proj1_sig2 (e: sig2 P Q) :=
    match e with
    | exist2 a p q => a
    end.

End Specif.

(** Lemmas on the option type. *)

Section option.

  Variable A : Type.

  Lemma option_dec : forall (el: option A),
    el = None \/ exists w: A, el = Some w.

  Proof.
    intros.
    destruct el.
    right; exists a; trivial.
    left; trivial.
  Qed.

End option.

(** Tactics *)

Ltac pair_destruct t0 t1 :=
  first [destruct t0 | intros until t0; destruct t0];
  first [destruct t1 | intros until t1; destruct t1];
  try contr; simpl.

Ltac rewrite_lr term := apply (proj1 term).
Ltac rewrite_rl term := apply (proj2 term).

Ltac try_solve :=
   simpl in *; try (intros; solve
     [ contr
     | discr
     | auto with terms
     | tauto
     | congruence
     ]
).


(**********************************************************************)
(* This Program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

(**********************************************************************)
(*                       SF-Calculus                                  *)
(*                                                                    *)
(* is implemented in Coq by adapting the implementation of            *)
(* Lambda Calculus from Project Coq                                   *)
(* 2015                                                               *)
(**********************************************************************)

(**********************************************************************)
(*                    Extensions.v                                    *)
(*                                                                    *)
(*                     Barry Jay                                      *)
(*                                                                    *)
(**********************************************************************)

Require Import ArithRing.
Require Import List.
Require Import Max.
Require Import Test.
Require Import General.
Require Import SF_Terms.
Require Import SF_Tactics.
Require Import Substitution_term.
Require Import SF_reduction.
Require Import SF_Normal.
Require Import SF_Closed.
Require Import SF_Eval.
Require Import Star.

Lemma fold_subst_list:
  forall sigma M N,  App (fold_left subst sigma M) N =
                     fold_left subst sigma (App M (lift (length sigma) N)).
Proof.
  induction sigma; split_all.
  (* 2 *)
  unfold lift; rewrite lift_rec_null. auto.
  (* 1 *)
  rewrite IHsigma. unfold subst. simpl. unfold lift. rewrite subst_rec_lift_rec; try omega. auto.
Qed.

Lemma list_subst_preserves_op:
  forall sigma o, fold_left subst sigma (Op o) = Op o.
  Proof. induction sigma; split_all. unfold subst in *. split_all. Qed.

Lemma list_subst_preserves_app:
  forall sigma M N, fold_left subst sigma (App M N) =
                    App (fold_left subst sigma M) (fold_left subst sigma N).
  Proof. induction sigma; split_all. unfold subst in *. split_all. Qed.

Lemma list_subst_preserves_sf_red:
  forall sigma M N, sf_red M N -> sf_red (fold_left subst sigma M) (fold_left subst sigma N).
Proof.  induction sigma; split_all. eapply2 IHsigma. eapply2 subst_preserves_sf_red. Qed.

Lemma list_subst_lift: forall sigma M, fold_left subst sigma (lift (length sigma) M) = M.
Proof.
  induction sigma; split_all. unfold lift; rewrite lift_rec_null. auto.
unfold lift, subst. rewrite subst_rec_lift_rec; try omega. unfold lift in *. rewrite IHsigma. auto.
Qed.

Fixpoint star_opt M :=
match M with
| Ref 0 => App (App (Op Sop) (App (Op Fop) (Op Fop))) (App (Op Fop) (Op Fop))
| Ref (S n) => App (App (Op Fop) (Op Fop)) (Ref n)
| Op o => App (App (Op Fop) (Op Fop)) (Op o)
| App M1 M2 =>
  match star_opt M1 with
    | App (App (Op Fop) (Op Fop)) M3 =>
      match star_opt M2 with
        | App (App (Op Fop) (Op Fop)) M4 => App (App (Op Fop) (Op Fop)) (App M3 M4)
        | App (App (Op Sop) (App (Op Fop) (Op Fop)))  (App (Op Fop) (Op Fop)) => M3
        | M4 => App (App (Op Sop) (App (App (Op Fop) (Op Fop)) M3)) M4
      end
    | M3 => App (App (Op Sop) M3) (star_opt M2)
  end
end
.

Definition S_not_F M :=
  App (App (App (App M (Op Fop)) (App (Op Fop) (Op Fop))) (App (Op Fop) (Op Fop)))
      (App (App (Op Sop) (App (Op Fop) (Op Fop))) (App (Op Fop) (Op Fop))).
Definition eq_op :=
   App
     (App (Op Sop)
        (App (App (Op Sop) (App (App (Op Fop) (Op Fop)) (Op Sop)))
           (App
              (App (Op Sop)
                 (App (App (Op Sop) (App (App (Op Fop) (Op Fop)) (Op Sop)))
                    (App
                       (App (Op Sop)
                          (App (App (Op Fop) (Op Fop))
                             (App (Op Fop) (Op Fop))))
                       (App
                          (App (Op Sop)
                             (App
                                (App (Op Sop)
                                   (App
                                      (App (Op Sop)
                                         (App
                                            (App (Op Sop)
                                               (App
                                                  (App
                                                  (Op Sop)
                                                  (App (Op Fop) (Op Fop)))
                                                  (App (Op Fop) (Op Fop))))
                                            (App (App (Op Fop) (Op Fop))
                                               (Op Fop))))
                                      (App (App (Op Fop) (Op Fop))
                                         (App (Op Fop) (Op Fop)))))
                                (App (App (Op Fop) (Op Fop))
                                   (App (Op Fop) (Op Fop)))))
                          (App (App (Op Fop) (Op Fop))
                             (App (App (Op Sop) (App (Op Fop) (Op Fop)))
                                (App (Op Fop) (Op Fop))))))))
              (App (App (Op Fop) (Op Fop))
                 (App
                    (App (Op Sop)
                       (App
                          (App (Op Sop)
                             (App
                                (App (Op Sop)
                                   (App
                                      (App (Op Sop)
                                         (App
                                            (App (Op Sop)
                                               (App (Op Fop) (Op Fop)))
                                            (App (Op Fop) (Op Fop))))
                                      (App (App (Op Fop) (Op Fop)) (Op Fop))))
                                (App (App (Op Fop) (Op Fop))
                                   (App (Op Fop) (Op Fop)))))
                          (App (App (Op Fop) (Op Fop))
                             (App (Op Fop) (Op Fop)))))
                    (App (App (Op Fop) (Op Fop))
                       (App (App (Op Sop) (App (Op Fop) (Op Fop)))
                          (App (Op Fop) (Op Fop)))))))))
     (App (App (Op Fop) (Op Fop))
        (App
           (App (Op Sop)
              (App
                 (App (Op Sop)
                    (App
                       (App (Op Sop)
                          (App
                             (App (Op Sop)
                                (App
                                   (App (Op Sop)
                                      (App
                                         (App (Op Sop)
                                            (App
                                               (App
                                                  (Op Sop)
                                                  (App (Op Fop) (Op Fop)))
                                               (App (Op Fop) (Op Fop))))
                                         (App (App (Op Fop) (Op Fop))
                                            (Op Fop))))
                                   (App (App (Op Fop) (Op Fop))
                                      (App (Op Fop) (Op Fop)))))
                             (App (App (Op Fop) (Op Fop))
                                (App (Op Fop) (Op Fop)))))
                       (App (App (Op Fop) (Op Fop))
                          (App (App (Op Sop) (App (Op Fop) (Op Fop)))
                             (App (Op Fop) (Op Fop))))))
                 (App (App (Op Fop) (Op Fop))
                    (App (App (Op Fop) (Op Fop))
                       (App (App (Op Sop) (App (Op Fop) (Op Fop)))
                          (App (Op Fop) (Op Fop)))))))
           (App (App (Op Fop) (Op Fop)) (App (Op Fop) (Op Fop)))))
.

Lemma aux_eq_op: eq_op = star_opt (star_opt (iff (S_not_F (Ref 1)) (S_not_F (Ref 0)))).
Proof. unfold eq_op, S_not_F, iff, not; unfold_op; unfold star_opt; split_all. Qed.

Lemma maxvar_eq_op: maxvar eq_op = 0.
Proof. split_all. Qed.

Hint Resolve maxvar_eq_op.

Lemma eq_op_true: forall o, sf_red (App (App eq_op (Op o)) (Op o)) k_op.
Proof. unfold eq_op; unfold_op; split_all; case o; repeat eval_SF0. Qed.

Lemma eq_op_false: forall o1 o2, o1<>o2 -> sf_red (App(App eq_op(Op o1))(Op o2)) (App k_op i_op).
Proof.
  unfold eq_op; unfold_op; intros.
  gen_case H o1; gen_case H o2; try discriminate; repeat eval_SF0.
  eapply2 preserves_app_sf_red. eval_SF0.
Qed.

Definition swap M := App (App s_op i_op) (App k_op M).

Lemma swap_check : forall M N, sf_red (App (swap M) N) (App N M).
Proof.
unfold swap; split_all; unfold_op; eval_SF0. eval_SF0. eapply2 preserves_app_sf_red;  eval_SF0.
Qed.

Fixpoint case P M :=
  match P with
    | Ref _ => star (App k_op M)
               (* the indices are renumbered, with binding from left to right *)
    | Op o =>
      star(App (App (App (Op Fop) (Ref 0))
                    (App (App (App (App eq_op (Op o)) (Ref 0)) (App k_op (lift 1 M)))
                         (swap (Ref 0))))
               (App k_op (App k_op ((swap (Ref 0))))))
    | App P1 P2 =>
      star(App (App (App (App (Op Fop) (Ref 0)) i_op)
                    (lift 1 (star (star (App (App (App (App
                               (lift 2 (case P1 (case P2 (App k_op (App k_op M)))))
                               (Ref 1))
                                                       (App k_op (App k_op (App k_op i_op))))
                                                  (Ref 0))
                                             (App k_op i_op))))))
               (swap (Ref 0)))
  end.

Fixpoint pattern_size P :=
  match P with
    | Ref _ => 1
    | Op _ => 0
    | App P1 P2 => pattern_size P1 + (pattern_size P2)
  end.

Lemma lift_rec_preserves_case:
  forall P M n k, lift_rec (case P M) n k = case P (lift_rec M (n+ pattern_size P) k).
Proof.
  induction P; intros.
  (* 3 *)
  split_all; rewrite lift_rec_preserves_star. replace (n0+1) with (S n0) by omega.  auto.
  (* 2 *)
  unfold pattern_size, case. rewrite lift_rec_preserves_star.
  unfold lift_rec; fold lift_rec. relocate_lt. rewrite lift_rec_closed.
  2: unfold eq_op; auto. unfold_op; unfold lift_rec; fold lift_rec.
  unfold lift, swap. unfold_op; unfold lift_rec; fold lift_rec.  relocate_lt.
  rewrite (lift_lift_rec M); try omega.
  replace (n+0) with n by omega. auto.
  (* 1 *)
  unfold pattern_size, case; fold pattern_size; fold case.
  repeat rewrite lift_rec_preserves_star.
  unfold lift, lift_rec; fold lift_rec.
  relocate_lt. rewrite lift_rec_closed.
  2: unfold i_op; auto.
  repeat rewrite lift_rec_preserves_star.
  unfold_op; unfold lift, lift_rec; fold lift_rec.
  unfold relocate at 2. elim(test 2 1); intro. noway. relocate_lt.
  repeat rewrite IHP1. repeat rewrite IHP2.
  unfold relocate at 2. elim(test 2 0); intro. noway. relocate_lt.
  unfold swap; unfold_op. unfold lift, lift_rec; fold lift_rec. relocate_lt.
  replace(0 + pattern_size P1 + pattern_size P2) with (pattern_size P1 + pattern_size P2) by omega.
  replace(2 + pattern_size P1 + pattern_size P2) with (2+ (pattern_size P1 + pattern_size P2)) by omega.
rewrite lift_lift_rec; try omega.
rewrite lift_lift_rec; try omega.
replace(S (S (S n)) + pattern_size P1 + pattern_size P2) with (2+ (1 +(n + pattern_size P1 + pattern_size P2))) by omega.
rewrite lift_lift_rec; try omega.
rewrite lift_lift_rec; try omega.
replace  (n + pattern_size P1 + pattern_size P2) with (n + (pattern_size P1 + pattern_size P2))
                                                        by omega. auto.
Qed.

(* matching *)

Inductive matching : SF -> SF -> list SF -> Prop :=
| match_ref : forall i M, matching (Ref i) M (cons M nil)
| match_op: forall o, matching (Op o) (Op o) nil
| match_app: forall p1 p2 M1 M2 sigma1 sigma2,
               normal (App p1 p2) -> compound (App M1 M2) ->
               matching p1 M1 sigma1 -> matching p2 M2 sigma2 ->
               matching (App p1 p2) (App M1 M2) ((map (lift (length sigma1)) sigma2) ++ sigma1)
.

Hint Constructors matching.

Lemma matching_lift:
  forall P M sigma, matching P M sigma -> forall k, matching P (lift k M) (map (lift k) sigma).
Proof.
  induction P; split_all; inversion H; subst; unfold map; fold map; auto.
replace (lift k (App M1 M2)) with (App (lift k M1) (lift k M2)) by (unfold lift; auto).
replace(fix map (l : list SF) : list SF :=
            match l with
            | nil => nil
            | a :: t => lift (length sigma1) a :: map t
            end) with (map (lift (length sigma1))) by auto.
replace (fix map (l : list SF) : list SF :=
         match l with
         | nil => nil
         | a :: t => lift k a :: map t
         end) with (map (lift k)) by auto.
rewrite map_app.
replace (map (lift k) (map (lift (length sigma1)) sigma2)) with
         (map (lift (length (map (lift k) sigma1))) (map (lift k) sigma2)).
eapply2 match_app.
replace (App (lift k M1) (lift k M2)) with  (lift k (App M1 M2)) by (unfold lift; auto).
unfold lift. eapply2 lift_rec_preserves_compound.
clear. induction sigma2; split_all. rewrite IHsigma2. rewrite map_length.
unfold lift; repeat rewrite lift_rec_lift_rec; try omega.
replace (length sigma1 + k) with (k+ length sigma1) by omega. auto.
Qed.

Lemma program_matching: forall M, program M -> matching M M nil.
Proof.
  induction M; split_all.
  inversion H; split_all. simpl in *; noway.
  inversion H; split_all. inversion H0.
  assert(status (App M1 M2) = Passive) by eapply2 closed_implies_passive.
  rewrite H6 in H7; discriminate.
  replace (nil: list SF)
  with (List.map (lift (length (nil: list SF))) (nil: list SF) ++ (nil: list SF))
    by split_all.
  eapply2 match_app. simpl in *. max_out. eapply2 IHM1. unfold program; auto.
  simpl in *. max_out. eapply2 IHM2. unfold program; auto.
Qed.

Lemma pattern_normal: forall p M sigma, matching p M sigma -> normal p.
Proof. induction p; split_all. inversion H; subst; split_all. Qed.

Hint Resolve pattern_normal.

Lemma app_comb_matching:
  forall p1 p2 M1 M2 sigma1 sigma2,
    matching p1 M1 sigma1 -> matching p2 M2 sigma2 ->
    matching (app_comb p1 p2) (app_comb M1 M2) (map (lift (length sigma1)) sigma2 ++ sigma1).
Proof.
  intros; unfold app_comb; unfold_op.
  replace (map (lift (length sigma1)) sigma2 ++ sigma1)
  with (map (lift (length (map (lift (length sigma1)) sigma2 ++ sigma1))) nil ++
            (map (lift (length sigma1)) sigma2 ++ sigma1))
    by split_all.
  eapply2 match_app. repeat eapply2 nf_compound.
  2: eapply2 program_matching; unfold program; auto.
  replace (map (lift (length sigma1)) sigma2 ++ sigma1)
  with (map (lift (length (nil: list SF)))(map (lift (length sigma1)) sigma2 ++ sigma1) ++ nil)
    by (split_all; rewrite map_lift0; rewrite append_nil; auto).
  eapply2 match_app. repeat eapply2 nf_compound.
  eapply2 match_app. repeat eapply2 nf_compound.
  replace sigma1 with (map (lift (length (nil : list SF))) sigma1 ++ nil)
     by (split_all; rewrite map_lift0; rewrite append_nil; auto).
  eapply2 match_app.
  replace sigma1 with (map (lift (length (nil : list SF))) sigma1 ++ nil)
     by (split_all; rewrite map_lift0; rewrite append_nil; auto).
  eapply2 match_app.
  eapply2 program_matching; unfold program; auto.
  replace sigma2 with (map (lift (length (nil : list SF))) sigma2 ++ nil)
     by (split_all; rewrite map_lift0; rewrite append_nil; auto).
  eapply2 match_app.
  eapply2 program_matching; unfold program; auto.
Qed.

Lemma var_matching:
    forall p1 p2 M1 M2 sigma1 sigma2,
    matching p1 M1 sigma1 -> matching p2 M2 sigma2 ->
    matching (var p1 p2) (var M1 M2) (map (lift (length sigma1)) sigma2 ++ sigma1).
Proof.
  intros; unfold var; unfold_op. eapply2 app_comb_matching.
  replace sigma1 with (map (lift (length (nil: list SF))) sigma1 ++ nil)
    by (split_all; rewrite map_lift0; rewrite append_nil; auto).
  eapply2 app_comb_matching.
eapply2 program_matching. unfold program; split_all. eapply2 vee_normal.
Qed.

Lemma pattern_is_program:
forall P, program P -> forall M sigma, matching P M sigma -> M = P /\ sigma = nil.
Proof.
induction P; intros; inversion H; subst.
(* 3 *)
simpl in *; discriminate.
(* 2 *)
inversion H0; auto.
(* 1 *)
simpl in *; max_out. inversion H0; inversion H1; subst.
(* 2 *)
assert(M1 = P1 /\ sigma1 = nil).
eapply2 IHP1 . unfold program; auto.
assert(M2 = P2 /\ sigma2 = nil).
eapply2 IHP2 . unfold program; auto.
split_all; subst.
auto.
(* 1 *)
assert(M1 = P1 /\ sigma1 = nil).
eapply2 IHP1 . unfold program; auto.
assert(M2 = P2 /\ sigma2 = nil).
eapply2 IHP2 . unfold program; auto.
split_all; subst.
auto.
Qed.

Lemma matching_app_comb:
forall P1 P2 N sigma, matching (app_comb P1 P2) N sigma ->
exists N1 N2 sigma1 sigma2, N = app_comb N1 N2 /\ matching P1 N1 sigma1 /\
matching P2 N2 sigma2 /\ sigma = (map (lift (length sigma1)) sigma2) ++ sigma1.
Proof.
intros.
inversion H; subst.
assert(M2 = i_op /\ sigma2 = nil). eapply2 pattern_is_program.
unfold_op; split_all.
split_all; subst.
inversion H4; subst.
assert(M0 = s_op /\ sigma0 = nil). eapply2 pattern_is_program.
unfold_op; split_all. split_all; subst.
unfold length at 1. unfold length in H4.
clear - H11 ;  inversion H11; subst.
inversion H6; subst.
assert(M2 = k_op /\ sigma2 = nil). eapply2 pattern_is_program.
unfold_op; split_all. split_all; subst.
clear - H3 H10.
inversion H3; subst.
assert(M0 = s_op /\ sigma0 = nil). eapply2 pattern_is_program.
unfold_op; split_all. split_all; subst.
inversion H7; subst.
assert(M1 = k_op /\ sigma1 = nil). eapply2 pattern_is_program.
unfold_op; split_all. split_all; subst.
exist M0; exist M3; exist sigma0; exist sigma3.
repeat rewrite map_lift0.

Lemma aux: forall (sigma : list SF), sigma ++ nil = sigma.
Proof. induction sigma; split_all. Qed.

repeat rewrite aux. auto.
Qed.

Lemma matching_var:
forall N sigma, matching (var (Ref 1) (Ref 0)) N sigma ->
exists N1 N2, N = var N1 N2 /\ sigma = (lift_rec N2 0 1 :: N1 :: nil).
Proof.
intros.
inversion H; subst.
assert(M2 = i_op /\ sigma2 = nil). eapply2 pattern_is_program.
unfold_op; split_all.
split_all; subst.
inversion H4; subst.
assert(M0 = s_op /\ sigma0 = nil). eapply2 pattern_is_program.
unfold_op; split_all. split_all; subst.
clear - H11. inversion H11; subst.
inversion H6; subst.
assert(M2 = k_op /\ sigma2 = nil). eapply2 pattern_is_program.
unfold_op; split_all. split_all; subst.
inversion H10; subst.
clear - H3.
inversion H3; subst.
assert(M0 = s_op /\ sigma0 = nil). eapply2 pattern_is_program.
unfold_op; split_all. split_all; subst.
clear - H7.
inversion H7; subst.
assert(M1 = k_op /\ sigma1 = nil). eapply2 pattern_is_program.
unfold_op; split_all. split_all; subst.
clear - H6.
unfold app_comb in H6.
inversion H6; subst.
assert(M2 = i_op /\ sigma2 = nil). eapply2 pattern_is_program.
unfold_op; split_all. split_all; subst.
clear - H3.
inversion H3; subst.
assert(M0 = s_op /\ sigma0 = nil). eapply2 pattern_is_program.
unfold_op; split_all. split_all; subst.
clear - H7.
inversion H7; subst.
assert(M1 = (App s_op (App k_op vee)) /\ sigma1 = nil). eapply2 pattern_is_program.
unfold_op; split_all.
eapply2 nf_compound. eapply2 nf_compound. eapply2 vee_normal.
split_all; subst.
clear - H6.
inversion H6; subst.
assert(M1 = k_op /\ sigma1 = nil). eapply2 pattern_is_program.
unfold_op; split_all.
split_all; subst.
clear - H7.
inversion H7; subst.
exist M2; exist M3.
unfold lift. repeat rewrite lift_rec_null. auto.
Qed.

Lemma maxvar_case : forall P M, maxvar (case P M) = maxvar M - (pattern_size P).
Proof.
  induction P; split_all. rewrite maxvar_star. omega.
  rewrite maxvar_star. repeat rewrite max_zero.
  replace (pred(maxvar (lift 1 M))) with (maxvar (lift 1 M) -1) by omega.
  rewrite lift_preserves_maxvar2. omega.
  repeat rewrite lift_rec_preserves_star. repeat rewrite maxvar_star.
  repeat rewrite max_zero.
  unfold lift; rewrite lift_rec_lift_rec; try omega.  simpl.
  replace (pred
     (pred
        (pred
           (maxvar (lift_rec (case P1 (case P2 (App k_op (App k_op M)))) 0 3)))))
  with  (maxvar (lift 3 (case P1 (case P2 (App k_op (App k_op M))))) - 3)
    by (unfold lift; auto;omega).
  rewrite lift_preserves_maxvar2.
  rewrite IHP1. rewrite IHP2. unfold_op; split_all. omega.
Qed.

Lemma case_by_matching:
  forall P N sigma,  matching P N sigma ->
                     forall M, sf_red (App (case P M) N) (App k_op (fold_left subst sigma M)).
Proof.
  induction P; intros.
  (* 3 *)
  eval_SF0. eval_SF0. eval_SF0. eval_SF0. eapply2 preserves_app_sf_red.
  inversion H; subst. simpl. eapply2 star_beta.
  (* 2 *)
  inversion H; subst. simpl; case o; repeat eval_SF0. eapply2 preserves_app_sf_red;
  eapply transitive_red. eapply2 star_beta.
  unfold subst, lift; rewrite subst_rec_lift_rec; try omega.   rewrite lift_rec_null.  auto.
  eapply2 preserves_app_sf_red; eapply transitive_red. eapply2 star_beta.
  unfold subst, lift; rewrite subst_rec_lift_rec; try omega.   rewrite lift_rec_null.  auto.
  (* 1 *)
  inversion H; subst.
  unfold case; fold case. eapply transitive_red. eapply2 star_beta.
  unfold subst, subst_rec; fold subst_rec. insert_Ref_out. repeat rewrite lift_rec_null.
  eapply transitive_red. eapply preserves_app_sf_red. eapply succ_red. eapply2 f_compound_red.
  rewrite subst_rec_lift_rec; try omega. rewrite lift_rec_null.
  eapply2 star_beta2.
  unfold swap; unfold_op.  unfold subst_rec; fold subst_rec. insert_Ref_out.
  repeat rewrite lift_rec_null. auto.
  unfold subst, lift, subst_rec; fold subst_rec; repeat (rewrite subst_rec_lift_rec; try omega).
  rewrite lift_rec_null.
  insert_Ref_out. unfold_op.
  unfold subst_rec; fold subst_rec; repeat (rewrite subst_rec_lift_rec; try omega).
  unfold left_component, right_component.   insert_Ref_out. repeat rewrite lift_rec_null.
  repeat (rewrite subst_rec_lift_rec; try omega). repeat rewrite lift_rec_null.
(* 1 *)
eapply transitive_red. eapply preserves_app_sf_red.
eapply preserves_app_sf_red. eapply preserves_app_sf_red. eapply preserves_app_sf_red.
eapply preserves_app_sf_red. auto. auto. auto. auto. auto. auto.
eapply transitive_red. eapply preserves_app_sf_red.
eapply preserves_app_sf_red. eapply preserves_app_sf_red. eapply preserves_app_sf_red.
eapply2 IHP1. auto. auto. auto. auto.
eapply transitive_red. eapply preserves_app_sf_red.
eapply preserves_app_sf_red. eapply preserves_app_sf_red.
eval_SF0. auto. auto. auto.
rewrite fold_left_app.
rewrite fold_subst_list.
eapply transitive_red. eapply preserves_app_sf_red.  eapply preserves_app_sf_red.
eapply list_subst_preserves_sf_red.
eapply2 IHP2. eapply2 matching_lift. auto. auto.
eapply transitive_red. eapply preserves_app_sf_red.
rewrite fold_subst_list.
eapply list_subst_preserves_sf_red.
eval_SF0. auto.
rewrite fold_subst_list.
rewrite fold_subst_list.
fold sf_red.
eapply transitive_red. eapply list_subst_preserves_sf_red. eapply list_subst_preserves_sf_red.
eval_SF0.

  repeat rewrite list_subst_preserves_app. repeat rewrite list_subst_preserves_op.
  repeat eapply2 preserves_app_sf_red.
Qed.

Definition extension P M R := App (App s_op (case P M)) (App k_op R).

Proposition extensions_by_matching:
  forall P N sigma,  matching P N sigma ->
                     forall M R, sf_red (App (extension P M R) N) (fold_left subst sigma M) .
Proof.
  intros. unfold extension. eapply succ_red. eapply2 s_red.
  eapply transitive_red. eapply preserves_app_sf_red. eapply2 case_by_matching. eval_SF0. eval_SF0.
Qed.

Lemma lift_rec_preserves_extension:
  forall P M R n k, lift_rec (extension P M R) n k =
                    extension P (lift_rec M (n+ pattern_size P) k) (lift_rec R n k).
Proof.
  intros. unfold extension. unfold_op. unfold lift_rec; fold lift_rec.
rewrite lift_rec_preserves_case. auto.
Qed.

Lemma maxvar_extension :
forall P M R, maxvar (extension P M R) = max (maxvar M - (pattern_size P)) (maxvar R).
Proof.  intros. unfold extension; simpl. rewrite maxvar_case. auto. Qed.

Lemma extension_ref: forall i M R N, sf_red (App (extension (Ref i) M R) N) (App (star M) N).
Proof. split_all. unfold extension.  repeat eval_SF0. Qed.

Lemma extension_op : forall o M R, sf_red (App (extension (Op o) M R) (Op o)) M.
Proof.
  intros. unfold extension. eapply transitive_red.  eapply succ_red. eapply2 s_red.
  unfold case. eapply preserves_app_sf_red. eapply2 star_beta. eval_SF0.
  unfold subst, subst_rec; fold subst_rec. insert_Ref_out.
  unfold swap; unfold_op.  unfold subst_rec; fold subst_rec.
  rewrite subst_rec_closed; auto. eval_SF0. rewrite subst_rec_lift_rec; try omega.
  insert_Ref_out. repeat rewrite lift_rec_null.
  eapply transitive_red. eapply preserves_app_sf_red.  eapply preserves_app_sf_red.
  eapply preserves_app_sf_red. eapply2 eq_op_true. auto. auto. auto. eval_SF0.
Qed.

Lemma extension_op_fail :
forall o M R N, factorable N -> Op o <> N -> sf_red (App (extension (Op o) M R) N) (App R N).
Proof.
  intros. unfold extension. eapply transitive_red.  eapply succ_red. eapply2 s_red.
  unfold case. eapply preserves_app_sf_red. eapply2 star_beta. eval_SF0.
  unfold subst, subst_rec; fold subst_rec. insert_Ref_out.
  unfold swap; unfold_op.  unfold subst_rec; fold subst_rec.
  rewrite subst_rec_closed; auto. rewrite subst_rec_lift_rec; try omega.
  insert_Ref_out. repeat rewrite lift_rec_null.
  inversion H; split_all; subst.
  (* 2 *)
  eapply transitive_red. eapply preserves_app_sf_red.  eval_SF0. auto.
  eapply transitive_red. eapply preserves_app_sf_red.  eapply preserves_app_sf_red.
  eapply preserves_app_sf_red.
  eapply2 eq_op_false. intro; subst; eapply2 H0. auto. auto. auto. eval_SF0. eval_SF0.
  eval_SF0. eapply2 preserves_app_sf_red; eval_SF0.
  (* 1 *)
  eapply transitive_red. eapply preserves_app_sf_red.
  eapply succ_red. eapply2 f_compound_red. eval_SF0. auto. eval_SF0. eval_SF0.
  eapply2 preserves_app_sf_red; eval_SF0.
Qed.

Lemma extension_compound_op: forall P1 P2 M R o,
sf_red (App (extension (App P1 P2) M R) (Op o)) (App R (Op o)).
Proof.
  intros. unfold extension, case; fold case. unfold_op.
eapply transitive_red. eapply succ_red. eapply2 s_red.
eapply preserves_app_sf_red. eapply2 star_beta. eval_SF0.
unfold subst, subst_rec; fold subst_rec. insert_Ref_out.
eval_SF0. eval_SF0. eval_SF0. eapply2 preserves_app_sf_red;  eval_SF0.
Qed.

Inductive matchfail : SF -> SF -> Prop :=
| matchfail_op: forall o M, factorable M -> Op o <> M -> matchfail (Op o) M
| matchfail_app_op: forall p1 p2 o, normal (App p1 p2) -> matchfail (App p1 p2) (Op o)
| matchfail_app_l: forall p1 p2 M1 M2, normal (App p1 p2) -> compound (App M1 M2) ->
               matchfail p1 M1 -> matchfail (App p1 p2) (App M1 M2)
| matchfail_app_r: forall p1 p2 M1 M2 sigma1, normal (App p1 p2) -> compound (App M1 M2) ->
               matching p1 M1 sigma1 -> matchfail p2 M2 -> matchfail (App p1 p2) (App M1 M2)
.

Hint Constructors matchfail.

Lemma matchfail_lift: forall P M, matchfail P M -> forall k, matchfail P (lift k M).
Proof.
  induction P; split_all; inversion H; subst.
  gen2_case H1 H2 M. inversion H1; split_all. inv1 compound.
  eapply2 matchfail_op. unfold lift. inversion H1; split_all. unfold factorable. right.
  replace (App (lift_rec s 0 k) (lift_rec s0 0 k)) with (lift_rec (App s s0) 0 k) by auto.
  eapply2 lift_rec_preserves_compound. discriminate.
unfold lift; split_all.
(* 2 *)
replace (lift k (App M1 M2)) with (App (lift k M1) (lift k M2)) by auto.
eapply2 matchfail_app_l.
replace (App (lift k M1) (lift k M2)) with (lift k (App M1 M2)) by auto.
unfold lift. eapply2 lift_rec_preserves_compound.
(* 1 *)
replace (lift k (App M1 M2)) with (App (lift k M1) (lift k M2)) by auto.
eapply2 matchfail_app_r.
replace (App (lift k M1) (lift k M2)) with (lift k (App M1 M2)) by auto.
unfold lift. eapply2 lift_rec_preserves_compound.
eapply2 matching_lift.
Qed.

Lemma case_by_matchfail:
  forall P N,  matchfail P N  -> forall M, sf_red (App (case P M) N) (swap N).
Proof.
  induction P; intros; inversion H; subst.
  (* 4 *)
  unfold case. eapply transitive_red. eapply star_beta.
  unfold swap; unfold_op; unfold subst, subst_rec; fold subst_rec.  insert_Ref_out.
  repeat rewrite lift_rec_null. rewrite subst_rec_closed. 2: rewrite maxvar_eq_op; omega.
  inversion H1; split_all; subst.
  eval_SF0. eapply transitive_red. eapply preserves_app_sf_red. eapply preserves_app_sf_red.
  eapply2 eq_op_false. intro; subst. eapply2 H2.
  rewrite subst_rec_lift_rec; try omega. rewrite lift_rec_null. auto. auto. eval_SF0. eval_SF0.
  eapply succ_red. eapply2 f_compound_red. eval_SF0.
  (* 3 *)
  unfold case; fold case. eapply transitive_red. eapply star_beta.
  unfold swap; unfold_op; unfold subst, subst_rec; fold subst_rec.  insert_Ref_out.
  eval_SF0. eval_SF0.
  (* 2 *)
  unfold case; fold case. eapply transitive_red. eapply star_beta.
  unfold swap; unfold_op; unfold subst, subst_rec; fold subst_rec.  insert_Ref_out.
  repeat rewrite lift_rec_null.
  eapply transitive_red. eapply preserves_app_sf_red.
  eapply succ_red. eapply2 f_compound_red. unfold left_component, right_component.
  rewrite subst_rec_lift_rec; try omega.   rewrite lift_rec_null. eapply2 star_beta2. auto.
  unfold subst, subst_rec; fold subst_rec.
  repeat rewrite (subst_rec_lift_rec); try omega. insert_Ref_out.
  repeat rewrite lift_rec_null.
  repeat rewrite (subst_rec_lift_rec); try omega.
  unfold subst_rec; fold subst_rec;   repeat rewrite lift_rec_null.
  insert_Ref_out.   repeat rewrite lift_rec_null.
  eapply transitive_red. eapply preserves_app_sf_red. eapply preserves_app_sf_red.
  eapply preserves_app_sf_red. eapply preserves_app_sf_red.
  eapply2 IHP1. auto. auto. auto. auto. unfold swap. eval_SF0.  eval_SF0.  eval_SF0.  eval_SF0.
  (* 1 *)
  unfold case; fold case. eapply transitive_red. eapply star_beta.
  unfold swap; unfold_op; unfold subst, subst_rec; fold subst_rec.  insert_Ref_out.
  repeat rewrite lift_rec_null.
  eapply transitive_red. eapply preserves_app_sf_red.
  eapply succ_red. eapply2 f_compound_red. unfold left_component, right_component.
  rewrite subst_rec_lift_rec; try omega.   rewrite lift_rec_null. eapply2 star_beta2. auto.
  unfold subst, subst_rec; fold subst_rec.
  repeat rewrite (subst_rec_lift_rec); try omega. insert_Ref_out.
  repeat rewrite lift_rec_null.
  repeat rewrite (subst_rec_lift_rec); try omega.
  unfold subst_rec; fold subst_rec;   repeat rewrite lift_rec_null.
  insert_Ref_out.   repeat rewrite lift_rec_null.
  eapply transitive_red. eapply preserves_app_sf_red. eapply preserves_app_sf_red.
  eapply preserves_app_sf_red. eapply preserves_app_sf_red.
  eapply2 case_by_matching. auto. auto. auto. auto. unfold swap.
  eapply transitive_red. eapply preserves_app_sf_red. eapply preserves_app_sf_red.
  eapply preserves_app_sf_red. eval_SF0. auto. auto. auto.
  rewrite fold_subst_list.
  eapply transitive_red. eapply preserves_app_sf_red. eapply preserves_app_sf_red.
  eapply list_subst_preserves_sf_red. eapply2 IHP2. eapply2 matchfail_lift. auto. auto.
  rewrite fold_subst_list. rewrite fold_subst_list.
  eapply transitive_red. eapply list_subst_preserves_sf_red.
  unfold swap.
eapply transitive_red. eval_SF0.
eapply transitive_red. eval_SF0.
eapply transitive_red. eval_SF0.
eapply transitive_red. eval_SF0.
unfold lift; simpl. auto.
repeat rewrite list_subst_preserves_app.
repeat rewrite list_subst_preserves_op.
eapply2 preserves_app_sf_red. eapply2 preserves_app_sf_red.
replace(lift_rec M1 0 (length sigma1)) with (lift (length sigma1) M1) by auto.
replace(lift_rec M2 0 (length sigma1)) with (lift (length sigma1) M2) by auto.
eapply2 preserves_app_sf_red; rewrite list_subst_lift; auto.
Qed.

Proposition extensions_by_matchfail:
  forall P N,  matchfail P N -> forall M R, sf_red (App (extension P M R) N) (App R N).
Proof.
  intros. inversion H; subst.
  (* 4 *)
  eapply2 extension_op_fail.
  (* 3 *)
  eapply2 extension_compound_op.
  (* 2 *)
  unfold extension, swap.   unfold case at 1; fold case.
  eapply succ_red. eapply2 s_red.
  eapply transitive_red. eapply preserves_app_sf_red. eapply2 star_beta. eval_SF0.
  unfold subst, subst_rec; fold subst_rec. insert_Ref_out. repeat rewrite lift_rec_null_term.
  unfold_op. rewrite subst_rec_lift_rec; auto; try omega. repeat rewrite lift_rec_null_term.
  eapply transitive_red. eapply preserves_app_sf_red. eapply preserves_app_sf_red.
  eapply succ_red. eapply2 f_compound_red. unfold left_component, right_component.
  eapply2 star_beta2.
  unfold swap; simpl; insert_Ref_out; rewrite lift_rec_null.  auto. auto.
  unfold subst, subst_rec; fold subst_rec.
  repeat rewrite subst_rec_lift_rec; try omega. repeat rewrite lift_rec_null.
  insert_Ref_out; rewrite lift_rec_null. unfold subst, subst_rec; fold subst_rec.
  insert_Ref_out; rewrite lift_rec_null. repeat rewrite subst_rec_lift_rec; try omega.
  repeat rewrite lift_rec_null.
  eapply transitive_red. eapply preserves_app_sf_red. eapply preserves_app_sf_red.
  eapply preserves_app_sf_red. eapply preserves_app_sf_red. eapply preserves_app_sf_red.
  eapply2 case_by_matchfail. auto. auto. auto. auto. auto.
  unfold swap. eval_SF0. eval_SF0. eval_SF0. eval_SF0. eval_SF0.
  eapply preserves_app_sf_red; eval_SF0.
  (* 1 *)
  unfold extension, swap.   unfold case at 1; fold case.
  eapply succ_red. eapply2 s_red.
  eapply transitive_red. eapply preserves_app_sf_red. eapply2 star_beta. eval_SF0.
  unfold subst, subst_rec; fold subst_rec. insert_Ref_out. repeat rewrite lift_rec_null_term.
  unfold_op. rewrite subst_rec_lift_rec; auto; try omega. repeat rewrite lift_rec_null_term.
  eapply transitive_red. eapply preserves_app_sf_red. eapply preserves_app_sf_red.
  eapply succ_red. eapply2 f_compound_red. unfold left_component, right_component.
  eapply2 star_beta2.
  unfold swap; simpl; insert_Ref_out; rewrite lift_rec_null.  auto. auto.
  unfold subst, subst_rec; fold subst_rec.
  repeat rewrite subst_rec_lift_rec; try omega. repeat rewrite lift_rec_null.
  insert_Ref_out; rewrite lift_rec_null. unfold subst, subst_rec; fold subst_rec.
  insert_Ref_out; rewrite lift_rec_null. repeat rewrite subst_rec_lift_rec; try omega.
  repeat rewrite lift_rec_null.
  eapply transitive_red. eapply preserves_app_sf_red. eapply preserves_app_sf_red.
  eapply preserves_app_sf_red. eapply preserves_app_sf_red. eapply preserves_app_sf_red.
  eapply2 case_by_matching. auto. auto. auto. auto. auto.
  eapply transitive_red. eapply preserves_app_sf_red. eapply preserves_app_sf_red.
  eapply preserves_app_sf_red. eapply preserves_app_sf_red. eval_SF0. auto. auto. auto. auto.
  eapply transitive_red. eapply preserves_app_sf_red. eapply preserves_app_sf_red.
  eapply preserves_app_sf_red.   rewrite fold_subst_list. eapply list_subst_preserves_sf_red.
  eapply2 case_by_matchfail. eapply2 matchfail_lift. auto. auto. auto.
  repeat rewrite fold_subst_list.
  eapply transitive_red. eapply list_subst_preserves_sf_red.
  unfold swap.
  eapply transitive_red. eval_SF0.
  eapply transitive_red. eval_SF0.
  eapply transitive_red. eval_SF0.
  eapply transitive_red. eval_SF0.
  eapply transitive_red. eval_SF0.
  eapply transitive_red. eapply preserves_app_sf_red. eval_SF0. eval_SF0. auto.
  rewrite list_subst_preserves_app. eapply2 preserves_app_sf_red.
  rewrite list_subst_lift. auto.
  replace(lift_rec M1 0 (length sigma1)) with (lift (length sigma1) M1) by auto.
  replace(lift_rec M2 0 (length sigma1)) with (lift (length sigma1) M2) by auto.
    rewrite list_subst_preserves_app. eapply2 preserves_app_sf_red; rewrite list_subst_lift; auto.
Qed.

Lemma match_program:
forall P M, normal P -> program M -> matchfail P M \/ exists sigma, matching P M sigma.
Proof.
induction P; split_all.
(* 3 *)
right. exist (cons M nil).
(* 2 *)
gen_case H0 M. inversion H0; split_all. simpl in *; discriminate.
case o; case o0; split_all.
right.  exist (nil: list SF).
left; auto. eapply2 matchfail_op. unfold factorable; split_all. left; eauto. discriminate.
left; auto. eapply2 matchfail_op. unfold factorable; split_all. left; eauto. discriminate.
right.  exist (nil: list SF).
left; auto. eapply2 matchfail_op. eapply2 programs_are_factorable.  discriminate.
(* 1 *)
gen_case H0 M; inversion H0; auto. simpl in *; discriminate.
inversion H1; subst.
assert(status (App s s0) = Passive) by eapply2 closed_implies_passive.
rewrite H7 in H3; discriminate.
simpl in *; max_out.
assert(normal P1 /\ normal P2) by (inversion H; auto). inversion H2.
assert(matchfail P1 s \/ (exists sigma : list SF, matching P1 s sigma))
by (eapply2 IHP1; unfold program; auto).
assert(matchfail P2 s0 \/ (exists sigma : list SF, matching P2 s0 sigma))
by (eapply2 IHP2; unfold program; auto).
inversion H10. left; eapply2 matchfail_app_l.
split_all.
inversion H11. left; eapply2 matchfail_app_r.
split_all.
right; eauto.
Qed.

Lemma pattern_is_program2:
forall P, program P -> forall M, matchfail P M  -> M <> P.
Proof.
induction P; intros; inversion H; subst.
(* 3 *)
simpl in *; discriminate.
(* 2 *)
inversion H0; auto.
(* 1 *)
simpl in *; max_out. inversion H0; inversion H1; subst.
intro; discriminate.
intro; discriminate.
assert(status (App P1 P2) = Passive). eapply2 closed_implies_passive. inversion H; auto.
rewrite H14 in H2; discriminate.
assert(M1 <> P1). eapply2 IHP1. unfold program; auto. intro. inversion H5. eapply2 H2.
assert(status (App P1 P2) = Passive). eapply2 closed_implies_passive. inversion H; auto.
rewrite H15 in H2; discriminate.
assert(M2 <> P2). eapply2 IHP2. unfold program; auto. intro. inversion H5. eapply2 H2.
Qed.

Lemma app_comb_matchfail :
  forall P1 P2 M1 M2, matchfail (App (App (Op Sop) P1) P2)  (App (App (Op Sop) M1) M2)  ->
                      matchfail (app_comb P1 P2)  (app_comb M1 M2)  .
Proof.
unfold app_comb; unfold_op. intros. inv matchfail.
(* 2 *)
assert (normal P1 /\ normal P2) by inv1 normal. inversion H.
eapply2 matchfail_app_l; repeat eapply2 nf_compound.
eapply2 matchfail_app_r; repeat eapply2 nf_compound.
eapply2 matchfail_app_l; repeat eapply2 nf_compound.
eapply2 matchfail_app_r; repeat eapply2 nf_compound.
eapply2 matchfail_app_r; repeat eapply2 nf_compound.
(* 1 *)
assert (normal P1 /\ normal P2) by inv1 normal. inversion H.
eapply2 matchfail_app_l; repeat eapply2 nf_compound.
eapply2 matchfail_app_r; repeat eapply2 nf_compound.
inversion H6.
eapply2 matchfail_app_r; repeat eapply2 nf_compound.
repeat (eapply2 match_app; repeat eapply2 nf_compound).
eapply2 matchfail_app_r; repeat eapply2 nf_compound.
Qed.

Lemma pattern_is_program3:
forall P, program P -> forall M, program M -> M<>P -> matchfail P M .
Proof.
induction P; intros; inversion H; subst.
(* 3 *)
simpl in *; discriminate.
(* 2 *)
inversion H0. eapply2 matchfail_op.  eapply2 programs_are_factorable.
(* 1 *)
gen2_case H0 H1 M. inversion H0; simpl in *; discriminate.
assert(s = P1 \/ s<> P1) by eapply decidable_term_equality.
inversion H4. subst.
eapply2 matchfail_app_r.
assert(factorable (App P1 P2)) by eapply2 programs_are_factorable.
inversion H5; split_all. gen_case H6 P1.
inversion H6. gen_case H6 s; inversion H6.
eapply2 program_matching.
simpl in *; max_out; inversion H2; split_all.
eapply2 IHP2. simpl in *; max_out; inversion H2; split_all.
inversion H0; inversion H5; simpl in *; max_out; split_all.
intro; subst; eapply2 H1.
eapply2 matchfail_app_l.
assert(factorable (App s s0)) by eapply2 programs_are_factorable.
inversion H6; split_all; subst.
eapply2 IHP1. simpl in *; max_out; inversion H2; split_all.
inversion H0. simpl in *; max_out.  inversion H6; split_all.
Qed.

Lemma matchfail_lift_rec: forall P M k, matchfail P M -> matchfail P (lift k M).
Proof.
induction P; split_all; inversion H; auto.
eapply matchfail_op. inversion H1; split_all; subst; split_all.
unfold factorable.  right. unfold lift; inversion H4; split_all.
unfold lift; intro. gen2_case H2 H4 M.
subst; split_all.
unfold lift; split_all.
inversion H; subst. discriminate.
eapply2 matchfail_app_l.
inversion H3; simpl; auto.
eapply2 matchfail_app_r.
inversion H3; simpl; auto.
inversion H11; subst. eapply matching_lift. eexact H10.
inversion H11; subst. eapply2 IHP2.
unfold lift; simpl.
eapply2 matchfail_app_r. inversion H3; split_all.
eapply matching_lift. eexact H4.
Qed.

Lemma matchfail_app_comb:
forall P1 P2 M1 M2, matchfail (App (App (Op Sop) P1) P2) (App (App (Op Sop) M1) M2) ->
matchfail (app_comb P1 P2) (app_comb M1 M2).
Proof.
intros. unfold app_comb; unfold_op.
inversion H; subst; split_all.  inversion H6; subst. inversion H9.
assert False by eapply2 H2. noway.
(* 2 *)
assert(normal P1 /\ normal P2) by (inversion H4; inversion H7; split_all).
inversion H0.
eapply2 matchfail_app_l. repeat eapply2 nf_compound.
eapply2 matchfail_app_r. repeat eapply2 nf_compound.
eapply2 matchfail_app_l. repeat eapply2 nf_compound.
eapply2 matchfail_app_r. repeat eapply2 nf_compound.
eapply2 matchfail_app_r.
 assert(normal P1 /\ normal P2) by (inversion H4; inversion H2; split_all). inversion H0.
 inversion H6. subst.
eapply2 matchfail_app_l.  repeat eapply2 nf_compound.
eapply2 matchfail_app_r. repeat eapply2 nf_compound.
eapply2 matchfail_app_r. repeat eapply2 nf_compound.
eapply2 match_app. eapply2 match_app.
eapply2 matchfail_app_r.
Qed.

Lemma matchfail_app_comb2:
forall P1 P2 M1 M2, matchfail (app_comb P1 P2) (app_comb M1 M2) ->
matchfail (App (App (Op Sop) P1) P2) (App (App (Op Sop) M1) M2).
Proof.
intros. unfold app_comb; unfold_op.
inversion H; subst; split_all.  inversion H6; subst. inversion H9.
assert False by eapply2 H2. noway.
(* 2 *)
inversion H10; subst. inversion H13; subst. inversion H16; subst.
assert False by eapply2 H2. noway.
inversion H17; subst. inversion H20; subst. inversion H23.
assert False by eapply2 H2. noway. inversion H24.
assert False by eapply2 H2. noway.
eapply2 matchfail_app_l. repeat eapply2 nf_compound; inversion H18; auto.
inversion H11; inversion H26; auto.
inversion H11; inversion H26; auto.
eapply2 matchfail_app_r. repeat eapply2 nf_compound. inversion H18; auto.
inversion H13.  inversion H19. subst.
inversion H14. inversion H21. inversion H32. assert False by eapply2 H35. noway.
inversion H33. assert False by eapply2 H36. noway.
eapply2 matchfail_app_r. repeat eapply2 nf_compound.
inversion H11; inversion H21; inversion H27; auto.
inversion H17; auto. inversion H17; auto.
inversion H7 .  inversion H10.
inversion H17. assert False by eapply2 H20. noway.
inversion H18. inversion H25. assert False by eapply2 H28. noway.
inversion H26. assert False by eapply2 H29. noway.
inversion H11. inversion H18. assert False by eapply2 H21. noway.
inversion H19. assert False by eapply2 H22. noway.
Qed.

Lemma matchfail_fix_comb: forall P M, matchfail P M -> matchfail (fix_comb P) (fix_comb M).
Proof.
intros. unfold fix_comb.
eapply2 matchfail_app_comb.
eapply2 matchfail_app_r. repeat eapply2 nf_compound. inversion H; auto.
eapply2 program_matching. split_all.
Qed.


(** *** Full Syntax **)

Require Export unscoped.

Class Signature := { Funcs : Type; fun_ar : Funcs -> nat ;
              Preds : Type; pred_ar : Preds -> nat }.

Section fix_sig.

Context {Sigma : Signature}.

Inductive term  : Type :=
  | var_term : (nat)  -> term
  | Func : forall (f : Funcs), Vector.t term (fun_ar f) -> term .

Definition congr_Func { f : Funcs }  { s0 : Vector.t term (fun_ar f) } { t0 : Vector.t term (fun_ar f)} (H1 : s0 = t0) : Func  f s0 = Func  f t0 :=
  (eq_trans) (eq_refl) ((ap) (fun x => Func  f x) H1).

Fixpoint subst_term   (sigmaterm : (nat)  -> term ) (s : term ) : _ :=
    match s with
    | var_term  s => sigmaterm s
    | Func  f s0 => Func  f (Vector.map (subst_term sigmaterm) s0)
    end.

Definition up_term_term   (sigma : (nat)  -> term ) : _ :=
  (scons) ((var_term ) (var_zero)) ((funcomp) (subst_term ((funcomp) (var_term ) (shift))) sigma).

Definition upId_term_term  (sigma : (nat)  -> term ) (Eq : forall x, sigma x = (var_term ) x) : forall x, (up_term_term sigma) x = (var_term ) x :=
  fun n => match n with
  | S fin_n => (ap) (subst_term ((funcomp) (var_term ) (shift))) (Eq fin_n)
  | 0 => eq_refl
  end.

Fixpoint idSubst_term  (sigmaterm : (nat)  -> term ) (Eqterm : forall x, sigmaterm x = (var_term ) x) (s : term ) : subst_term sigmaterm s = s :=
    match s with
    | var_term  s => Eqterm s
    | Func  f s0 => congr_Func ((vec_id (idSubst_term sigmaterm Eqterm)) s0)
    end.

Definition upExt_term_term   (sigma : (nat)  -> term ) (tau : (nat)  -> term ) (Eq : forall x, sigma x = tau x) : forall x, (up_term_term sigma) x = (up_term_term tau) x :=
  fun n => match n with
  | S fin_n => (ap) (subst_term ((funcomp) (var_term) (shift))) (Eq fin_n)
  | 0 => eq_refl
  end.

Fixpoint ext_term   (sigmaterm : (nat)  -> term ) (tauterm : (nat)  -> term ) (Eqterm : forall x, sigmaterm x = tauterm x) (s : term ) : subst_term sigmaterm s = subst_term tauterm s :=
    match s with
    | var_term  s => Eqterm s
    | Func  f s0 => congr_Func ((vec_ext (ext_term sigmaterm tauterm Eqterm)) s0)
    end.

Fixpoint compSubstSubst_term    (sigmaterm : (nat)  -> term ) (tauterm : (nat)  -> term ) (thetaterm : (nat)  -> term ) (Eqterm : forall x, ((funcomp) (subst_term tauterm) sigmaterm) x = thetaterm x) (s : term ) : subst_term tauterm (subst_term sigmaterm s) = subst_term thetaterm s :=
    match s with
    | var_term  s => Eqterm s
    | Func  f s0 => congr_Func ((vec_comp (compSubstSubst_term sigmaterm tauterm thetaterm Eqterm)) s0)
    end.

Definition up_subst_subst_term_term    (sigma : (nat)  -> term ) (tauterm : (nat)  -> term ) (theta : (nat)  -> term ) (Eq : forall x, ((funcomp) (subst_term tauterm) sigma) x = theta x) : forall x, ((funcomp) (subst_term (up_term_term tauterm)) (up_term_term sigma)) x = (up_term_term theta) x :=
  fun n => match n with
  | S fin_n => (eq_trans) (compSubstSubst_term ((funcomp) (var_term) (shift)) (up_term_term tauterm) ((funcomp) (up_term_term tauterm) (shift)) (fun x => eq_refl) (sigma fin_n)) ((eq_trans) ((eq_sym) (compSubstSubst_term tauterm ((funcomp) (var_term) (shift)) ((funcomp) (subst_term ((funcomp) (var_term ) (shift))) tauterm) (fun x => eq_refl) (sigma fin_n))) ((ap) (subst_term ((funcomp) (var_term ) (shift))) (Eq fin_n)))
  | 0 => eq_refl
  end.

Lemma instId_term  : subst_term (var_term ) = (@id) (term ) .
Proof. exact ((FunctionalExtensionality.functional_extensionality _ _ ) (fun x => idSubst_term (var_term ) (fun n => eq_refl) (((@id) (term )) x))). Qed.

Lemma varL_term   (sigmaterm : (nat)  -> term ) : (funcomp) (subst_term sigmaterm) (var_term ) = sigmaterm .
Proof. exact ((FunctionalExtensionality.functional_extensionality _ _ ) (fun x => eq_refl)). Qed.

Lemma compComp_term    (sigmaterm : (nat)  -> term ) (tauterm : (nat)  -> term ) (s : term ) : subst_term tauterm (subst_term sigmaterm s) = subst_term ((funcomp) (subst_term tauterm) sigmaterm) s .
Proof. exact (compSubstSubst_term sigmaterm tauterm (_) (fun n => eq_refl) s). Qed.

Lemma compComp'_term    (sigmaterm : (nat)  -> term ) (tauterm : (nat)  -> term ) : (funcomp) (subst_term tauterm) (subst_term sigmaterm) = subst_term ((funcomp) (subst_term tauterm) sigmaterm) .
Proof. exact ((FunctionalExtensionality.functional_extensionality _ _ ) (fun n => compComp_term sigmaterm tauterm n)). Qed.

Inductive form  : Type :=
  | Fal : form
  | Top : form
  | Pred : forall (P : Preds), Vector.t term (pred_ar P) -> form
  | Impl : form  -> form  -> form
  | Conj : form  -> form  -> form
  | Disj : form  -> form  -> form
  | All : form  -> form
  | Ex : form  -> form .

Definition congr_Fal  : Fal  = Fal  :=
  eq_refl.

Definition congr_Top  : Top  = Top  :=
  eq_refl.

Definition congr_Pred { P : Preds }  { s0 : Vector.t term (pred_ar P) } { t0 : Vector.t term (pred_ar P) } (H1 : s0 = t0) : Pred  P s0 = Pred  P t0 :=
  (eq_trans) (eq_refl) ((ap) (fun x => Pred  P x) H1).

Definition congr_Impl  { s0 : form  } { s1 : form  } { t0 : form  } { t1 : form  } (H1 : s0 = t0) (H2 : s1 = t1) : Impl  s0 s1 = Impl  t0 t1 :=
  (eq_trans) ((eq_trans) (eq_refl) ((ap) (fun x => Impl  x (_)) H1)) ((ap) (fun x => Impl  (_) x) H2).

Definition congr_Conj  { s0 : form  } { s1 : form  } { t0 : form  } { t1 : form  } (H1 : s0 = t0) (H2 : s1 = t1) : Conj  s0 s1 = Conj  t0 t1 :=
  (eq_trans) ((eq_trans) (eq_refl) ((ap) (fun x => Conj  x (_)) H1)) ((ap) (fun x => Conj  (_) x) H2).

Definition congr_Disj  { s0 : form  } { s1 : form  } { t0 : form  } { t1 : form  } (H1 : s0 = t0) (H2 : s1 = t1) : Disj  s0 s1 = Disj  t0 t1 :=
  (eq_trans) ((eq_trans) (eq_refl) ((ap) (fun x => Disj  x (_)) H1)) ((ap) (fun x => Disj  (_) x) H2).

Definition congr_All  { s0 : form  } { t0 : form  } (H1 : s0 = t0) : All  s0 = All  t0 :=
  (eq_trans) (eq_refl) ((ap) (fun x => All  x) H1).

Definition congr_Ex  { s0 : form  } { t0 : form  } (H1 : s0 = t0) : Ex  s0 = Ex  t0 :=
  (eq_trans) (eq_refl) ((ap) (fun x => Ex  x) H1).

Fixpoint subst_form   (sigmaterm : (nat)  -> term ) (s : form ) : _ :=
    match s with
    | Fal   => Fal
    | Top => Top
    | Pred  P s0 => Pred  P ((Vector.map (subst_term sigmaterm)) s0)
    | Impl  s0 s1 => Impl  ((subst_form sigmaterm) s0) ((subst_form sigmaterm) s1)
    | Conj  s0 s1 => Conj  ((subst_form sigmaterm) s0) ((subst_form sigmaterm) s1)
    | Disj  s0 s1 => Disj  ((subst_form sigmaterm) s0) ((subst_form sigmaterm) s1)
    | All  s0 => All  ((subst_form (up_term_term sigmaterm)) s0)
    | Ex  s0 => Ex  ((subst_form (up_term_term sigmaterm)) s0)
    end.

Fixpoint idSubst_form  (sigmaterm : (nat)  -> term ) (Eqterm : forall x, sigmaterm x = (var_term ) x) (s : form ) : subst_form sigmaterm s = s :=
    match s with
    | Fal   => congr_Fal
    | Top   => congr_Top
    | Pred  P s0 => congr_Pred ((vec_id (idSubst_term sigmaterm Eqterm)) s0)
    | Impl  s0 s1 => congr_Impl ((idSubst_form sigmaterm Eqterm) s0) ((idSubst_form sigmaterm Eqterm) s1)
    | Conj  s0 s1 => congr_Conj ((idSubst_form sigmaterm Eqterm) s0) ((idSubst_form sigmaterm Eqterm) s1)
    | Disj  s0 s1 => congr_Disj ((idSubst_form sigmaterm Eqterm) s0) ((idSubst_form sigmaterm Eqterm) s1)
    | All  s0 => congr_All ((idSubst_form (up_term_term sigmaterm) (upId_term_term (_) Eqterm)) s0)
    | Ex  s0 => congr_Ex ((idSubst_form (up_term_term sigmaterm) (upId_term_term (_) Eqterm)) s0)
    end.

Fixpoint ext_form   (sigmaterm : (nat)  -> term ) (tauterm : (nat)  -> term ) (Eqterm : forall x, sigmaterm x = tauterm x) (s : form ) : subst_form sigmaterm s = subst_form tauterm s :=
    match s with
    | Fal   => congr_Fal
    | Top   => congr_Top
    | Pred  P s0 => congr_Pred ((vec_ext (ext_term sigmaterm tauterm Eqterm)) s0)
    | Impl  s0 s1 => congr_Impl ((ext_form sigmaterm tauterm Eqterm) s0) ((ext_form sigmaterm tauterm Eqterm) s1)
    | Conj  s0 s1 => congr_Conj ((ext_form sigmaterm tauterm Eqterm) s0) ((ext_form sigmaterm tauterm Eqterm) s1)
    | Disj  s0 s1 => congr_Disj ((ext_form sigmaterm tauterm Eqterm) s0) ((ext_form sigmaterm tauterm Eqterm) s1)
    | All  s0 => congr_All ((ext_form (up_term_term sigmaterm) (up_term_term tauterm) (upExt_term_term (_) (_) Eqterm)) s0)
    | Ex  s0 => congr_Ex ((ext_form (up_term_term sigmaterm) (up_term_term tauterm) (upExt_term_term (_) (_) Eqterm)) s0)
    end.

Fixpoint compSubstSubst_form    (sigmaterm : (nat)  -> term ) (tauterm : (nat)  -> term ) (thetaterm : (nat)  -> term ) (Eqterm : forall x, ((funcomp) (subst_term tauterm) sigmaterm) x = thetaterm x) (s : form ) : subst_form tauterm (subst_form sigmaterm s) = subst_form thetaterm s :=
    match s with
    | Fal   => congr_Fal
    | Top   => congr_Top
    | Pred  P s0 => congr_Pred ((vec_comp (compSubstSubst_term sigmaterm tauterm thetaterm Eqterm)) s0)
    | Impl  s0 s1 => congr_Impl ((compSubstSubst_form sigmaterm tauterm thetaterm Eqterm) s0) ((compSubstSubst_form sigmaterm tauterm thetaterm Eqterm) s1)
    | Conj  s0 s1 => congr_Conj ((compSubstSubst_form sigmaterm tauterm thetaterm Eqterm) s0) ((compSubstSubst_form sigmaterm tauterm thetaterm Eqterm) s1)
    | Disj  s0 s1 => congr_Disj ((compSubstSubst_form sigmaterm tauterm thetaterm Eqterm) s0) ((compSubstSubst_form sigmaterm tauterm thetaterm Eqterm) s1)
    | All  s0 => congr_All ((compSubstSubst_form (up_term_term sigmaterm) (up_term_term tauterm) (up_term_term thetaterm) (up_subst_subst_term_term (_) (_) (_) Eqterm)) s0)
    | Ex  s0 => congr_Ex ((compSubstSubst_form (up_term_term sigmaterm) (up_term_term tauterm) (up_term_term thetaterm) (up_subst_subst_term_term (_) (_) (_) Eqterm)) s0)
    end.

Lemma instId_form  : subst_form (var_term ) = (@id) (form ) .
Proof. exact ((FunctionalExtensionality.functional_extensionality _ _ ) (fun x => idSubst_form (var_term ) (fun n => eq_refl) (((@id) (form )) x))). Qed.

Lemma compComp_form    (sigmaterm : (nat)  -> term ) (tauterm : (nat)  -> term ) (s : form ) : subst_form tauterm (subst_form sigmaterm s) = subst_form ((funcomp) (subst_term tauterm) sigmaterm) s .
Proof. exact (compSubstSubst_form sigmaterm tauterm (_) (fun n => eq_refl) s). Qed.

Lemma compComp'_form    (sigmaterm : (nat)  -> term ) (tauterm : (nat)  -> term ) : (funcomp) (subst_form tauterm) (subst_form sigmaterm) = subst_form ((funcomp) (subst_term tauterm) sigmaterm) .
Proof. exact ((FunctionalExtensionality.functional_extensionality _ _ ) (fun n => compComp_form sigmaterm tauterm n)). Qed.

End fix_sig.

Instance Subst_term (Sigma : Signature)   : Subst1 ((nat)  -> term ) (term ) (term ) := @subst_term Sigma.

Instance Subst_form (Sigma : Signature)   : Subst1 ((nat)  -> term ) (form ) (form ) := @subst_form Sigma.

Instance VarInstance_term (Sigma : Signature) : Var ((nat) ) (term ) := @var_term Sigma.

Notation "x '__term'" := (var_term x) (at level 5, format "x __term") : subst_scope.

Notation "x '__term'" := (@ids (_) (_) VarInstance_term x) (at level 5, only printing, format "x __term") : subst_scope.

Notation "'var'" := (var_term) (only printing, at level 1) : subst_scope.

Class Up_term X Y := up_term : X -> Y.

Notation "↑__term" := (up_term) (only printing) : subst_scope.

Notation "↑__term" := (up_term_term) (only printing) : subst_scope.

Instance Up_term_term (Sigma : Signature)   : Up_term (_) (_) := @up_term_term Sigma.

Notation "s [ sigmaterm ]" := (subst_term sigmaterm s) (at level 7, left associativity, only printing) : subst_scope.

(* Notation "[ sigmaterm ]" := (subst_term sigmaterm) (at level 0, left associativity, only printing) : fscope. *)

Notation "s [ sigmaterm ]" := (subst_form sigmaterm s) (at level 7, left associativity, only printing) : subst_scope.

(* Notation "[ sigmaterm ]" := (subst_form sigmaterm) (at level 0, left associativity, only printing) : fscope. *)

Ltac auto_unfold := repeat unfold subst1,  subst2,  Subst1,  Subst2,  ids,  Subst_term,  Subst_form,  VarInstance_term.

Tactic Notation "auto_unfold" "in" "*" := repeat unfold subst1,  subst2,  Subst1,  Subst2,  ids,  Subst_term,  Subst_form,  VarInstance_term in *.

Ltac asimpl' := repeat first [progress rewrite ?instId_term| progress rewrite ?term| progress rewrite ?compComp_term| progress rewrite ?compComp'_term| progress rewrite ?instId_form| progress rewrite ?form| progress rewrite ?compComp_form| progress rewrite ?compComp'_form| progress rewrite ?varL_term| progress (unfold up_ren, up_term_term)| progress (cbn [subst_term subst_form])| fsimpl].

Ltac asimpl := repeat try unfold_funcomp; auto_unfold in *; asimpl'; repeat try unfold_funcomp.

Tactic Notation "asimpl" "in" hyp(J) := revert J; asimpl; intros J.

Tactic Notation "auto_case" := auto_case (asimpl; cbn; eauto).

Tactic Notation "asimpl" "in" "*" := auto_unfold in *; repeat first [progress rewrite ?instId_term in *| progress rewrite ?term in *| progress rewrite ?compComp_term in *| progress rewrite ?compComp'_term in *| progress rewrite ?instId_form in *| progress rewrite ?form in *| progress rewrite ?compComp_form in *| progress rewrite ?compComp'_form in *| progress rewrite ?varL_term in *| progress (unfold up_ren, up_term_term)| progress (cbn [subst_term subst_form] in *)| fsimpl in *].


(**
This file is part of the Flocq formalization of floating-point
arithmetic in Coq: http://flocq.gforge.inria.fr/

Copyright (C) 2010-2011 Sylvie Boldo
#<br />#
Copyright (C) 2010-2011 Guillaume Melquiond

This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License as published by the Free Software Foundation; either
version 3 of the License, or (at your option) any later version.

This library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
COPYING file for more details.
*)

(** * Helper functions and theorems for computing the rounded square root of a floating-point number. *)

Require Import Fcore_Raux.
Require Import Fcore_defs.
Require Import Fcore_digits.
Require Import Fcore_float_prop.
Require Import Fcalc_bracket.
Require Import Fcalc_digits.

Section Fcalc_sqrt.

Fixpoint Zsqrt_aux (p : positive) : Z * Z :=
  match p with
  | xH => (1, 0)%Z
  | xO xH => (1, 1)%Z
  | xI xH => (1, 2)%Z
  | xO (xO p) =>
    let (q, r) := Zsqrt_aux p in
    let r' := (4 * r)%Z in
    let d := (r' - (4 * q + 1))%Z in
    if Zlt_bool d 0 then (2 * q, r')%Z else (2 * q + 1, d)%Z
  | xO (xI p) =>
    let (q, r) := Zsqrt_aux p in
    let r' := (4 * r + 2)%Z in
    let d := (r' - (4 * q + 1))%Z in
    if Zlt_bool d 0 then (2 * q, r')%Z else (2 * q + 1, d)%Z
  | xI (xO p) =>
    let (q, r) := Zsqrt_aux p in
    let r' := (4 * r + 1)%Z in
    let d := (r' - (4 * q + 1))%Z in
    if Zlt_bool d 0 then (2 * q, r')%Z else (2 * q + 1, d)%Z
  | xI (xI p) =>
    let (q, r) := Zsqrt_aux p in
    let r' := (4 * r + 3)%Z in
    let d := (r' - (4 * q + 1))%Z in
    if Zlt_bool d 0 then (2 * q, r')%Z else (2 * q + 1, d)%Z
  end.

Lemma Zsqrt_ind :
  forall P : positive -> Prop,
  P xH -> P (xO xH) -> P (xI xH) ->
  ( forall p, P p -> P (xO (xO p)) /\ P (xO (xI p)) /\ P (xI (xO p)) /\ P (xI (xI p)) ) ->
  forall p, P p.
Proof.
intros P H1 H2 H3 Hp.
fix 1.
intros [[p|p|]|[p|p|]|].
refine (proj2 (proj2 (proj2 (Hp p _)))).
apply Zsqrt_ind.
refine (proj1 (proj2 (proj2 (Hp p _)))).
apply Zsqrt_ind.
exact H3.
refine (proj1 (proj2 (Hp p _))).
apply Zsqrt_ind.
refine (proj1 (Hp p _)).
apply Zsqrt_ind.
exact H2.
exact H1.
Qed.

Lemma Zsqrt_aux_correct :
  forall p,
  let (q, r) := Zsqrt_aux p in
  Zpos p = (q * q + r)%Z /\ (0 <= r <= 2 * q)%Z.
Proof.
intros p.
elim p using Zsqrt_ind ; clear p.
now repeat split.
now repeat split.
now repeat split.
intros p.
Opaque Zmult. simpl. Transparent Zmult.
destruct (Zsqrt_aux p) as (q, r).
intros (Hq, Hr).
change (Zpos p~0~0) with (4 * Zpos p)%Z.
change (Zpos p~0~1) with (4 * Zpos p + 1)%Z.
change (Zpos p~1~0) with (4 * Zpos p + 2)%Z.
change (Zpos p~1~1) with (4 * Zpos p + 3)%Z.
rewrite Hq. clear Hq.
repeat split.
generalize (Zlt_cases (4 * r - (4 * q + 1)) 0).
case Zlt_bool ; ( split ; [ ring | omega ] ).
generalize (Zlt_cases (4 * r + 2 - (4 * q + 1)) 0).
case Zlt_bool ; ( split ; [ ring | omega ] ).
generalize (Zlt_cases (4 * r + 1 - (4 * q + 1)) 0).
case Zlt_bool ; ( split ; [ ring | omega ] ).
generalize (Zlt_cases (4 * r + 3 - (4 * q + 1)) 0).
case Zlt_bool ; ( split ; [ ring | omega ] ).
Qed.

(** Computes the integer square root and its remainder, but
    without carrying a proof, contrarily to the operation of
    the standard libary. *)

Definition Zsqrt p :=
  match p with
  | Zpos p => Zsqrt_aux p
  | _ => (0, 0)%Z
  end.

Theorem Zsqrt_correct :
  forall x,
  (0 <= x)%Z ->
  let (q, r) := Zsqrt x in
  x = (q * q + r)%Z /\ (0 <= r <= 2 * q)%Z.
Proof.
unfold Zsqrt.
intros [|p|p] Hx.
now repeat split.
apply Zsqrt_aux_correct.
now elim Hx.
Qed.

Variable beta : radix.
Notation bpow e := (bpow beta e).

(** Computes a mantissa of precision p, the corresponding exponent,
    and the position with respect to the real square root of the
    input floating-point number.

The algorithm performs the following steps:
- Shift the mantissa so that it has at least 2p-1 digits;
  shift it one digit more if the new exponent is not even.
- Compute the square root s (at least p digits) of the new
  mantissa, and its remainder r.
- Compute the position according to the remainder:
  -- r == 0  =>  Eq,
  -- r <= s  =>  Lo,
  -- r >= s  =>  Up.

Complexity is fine as long as p1 <= 2p-1.
*)

Definition Fsqrt_core prec m e :=
  let d := Zdigits beta m in
  let s := Zmax (2 * prec - d) 0 in
  let e' := (e - s)%Z in
  let (s', e'') := if Zeven e' then (s, e') else (s + 1, e' - 1)%Z in
  let m' :=
    match s' with
    | Zpos p => (m * Zpower_pos beta p)%Z
    | _ => m
    end in
  let (q, r) := Zsqrt m' in
  let l :=
    if Zeq_bool r 0 then loc_Exact
    else loc_Inexact (if Zle_bool r q then Lt else Gt) in
  (q, Zdiv2 e'', l).

Theorem Fsqrt_core_correct :
  forall prec m e,
  (0 < m)%Z ->
  let '(m', e', l) := Fsqrt_core prec m e in
  (prec <= Zdigits beta m')%Z /\
  inbetween_float beta m' e' (sqrt (F2R (Float beta m e))) l.
Proof.
intros prec m e Hm.
unfold Fsqrt_core.
set (d := Zdigits beta m).
set (s := Zmax (2 * prec - d) 0).
(* . exponent *)
case_eq (if Zeven (e - s) then (s, (e - s)%Z) else ((s + 1)%Z, (e - s - 1)%Z)).
intros s' e' Hse.
assert (He: (Zeven e' = true /\ 0 <= s' /\ 2 * prec - d <= s' /\ s' + e' = e)%Z).
revert Hse.
case_eq (Zeven (e - s)) ; intros He Hse ; inversion Hse.
repeat split.
exact He.
unfold s.
apply Zle_max_r.
apply Zle_max_l.
ring.
assert (H: (Zmax (2 * prec - d) 0 <= s + 1)%Z).
fold s.
apply Zle_succ.
repeat split.
unfold Zminus at 1.
now rewrite Zeven_plus, He.
apply Zle_trans with (2 := H).
apply Zle_max_r.
apply Zle_trans with (2 := H).
apply Zle_max_l.
ring.
clear -Hm He.
destruct He as (He1, (He2, (He3, He4))).
(* . shift *)
set (m' := match s' with
  | Z0 => m
  | Zpos p => (m * Zpower_pos beta p)%Z
  | Zneg _ => m
  end).
assert (Hs: F2R (Float beta m' e') = F2R (Float beta m e) /\ (2 * prec <= Zdigits beta m')%Z /\ (0 < m')%Z).
rewrite <- He4.
unfold m'.
destruct s' as [|p|p].
repeat split ; try easy.
fold d.
omega.
fold (Zpower beta (Zpos p)).
split.
replace (Zpos p) with (Zpos p + e' - e')%Z by ring.
rewrite <- F2R_change_exp.
apply (f_equal (fun v => F2R (Float beta m v))).
ring.
assert (0 < Zpos p)%Z by easy.
omega.
split.
rewrite Zdigits_mult_Zpower.
fold d.
omega.
apply sym_not_eq.
now apply Zlt_not_eq.
easy.
apply Zmult_lt_0_compat.
exact Hm.
now apply Zpower_gt_0.
now elim He2.
clearbody m'.
destruct Hs as (Hs1, (Hs2, Hs3)).
generalize (Zsqrt_correct m' (Zlt_le_weak _ _ Hs3)).
destruct (Zsqrt m') as (q, r).
intros (Hq, Hr).
rewrite <- Hs1. clear Hs1.
split.
(* . mantissa width *)
apply Zmult_le_reg_r with 2%Z.
easy.
rewrite Zmult_comm.
apply Zle_trans with (1 := Hs2).
rewrite Hq.
apply Zle_trans with (Zdigits beta (q + q + q * q)).
apply Zdigits_le.
rewrite <- Hq.
now apply Zlt_le_weak.
omega.
replace (Zdigits beta q * 2)%Z with (Zdigits beta q + Zdigits beta q)%Z by ring.
apply Zdigits_mult_strong.
omega.
omega.
(* . round *)
unfold inbetween_float, F2R. simpl.
rewrite sqrt_mult.
2: now apply (Z2R_le 0) ; apply Zlt_le_weak.
2: apply Rlt_le ; apply bpow_gt_0.
destruct (Zeven_ex e') as (e2, Hev).
rewrite He1, Zplus_0_r in Hev. clear He1.
rewrite Hev.
replace (Zdiv2 (2 * e2)) with e2 by now case e2.
replace (2 * e2)%Z with (e2 + e2)%Z by ring.
rewrite bpow_plus.
fold (Rsqr (bpow e2)).
rewrite sqrt_Rsqr.
2: apply Rlt_le ; apply bpow_gt_0.
apply inbetween_mult_compat.
apply bpow_gt_0.
rewrite Hq.
case Zeq_bool_spec ; intros Hr'.
(* .. r = 0 *)
rewrite Hr', Zplus_0_r, Z2R_mult.
fold (Rsqr (Z2R q)).
rewrite sqrt_Rsqr.
now constructor.
apply (Z2R_le 0).
omega.
(* .. r <> 0 *)
constructor.
split.
(* ... bounds *)
apply Rle_lt_trans with (sqrt (Z2R (q * q))).
rewrite Z2R_mult.
fold (Rsqr (Z2R q)).
rewrite sqrt_Rsqr.
apply Rle_refl.
apply (Z2R_le 0).
omega.
apply sqrt_lt_1.
rewrite Z2R_mult.
apply Rle_0_sqr.
rewrite <- Hq.
apply (Z2R_le 0).
now apply Zlt_le_weak.
apply Z2R_lt.
omega.
apply Rlt_le_trans with (sqrt (Z2R ((q + 1) * (q + 1)))).
apply sqrt_lt_1.
rewrite <- Hq.
apply (Z2R_le 0).
now apply Zlt_le_weak.
rewrite Z2R_mult.
apply Rle_0_sqr.
apply Z2R_lt.
ring_simplify.
omega.
rewrite Z2R_mult.
fold (Rsqr (Z2R (q + 1))).
rewrite sqrt_Rsqr.
apply Rle_refl.
apply (Z2R_le 0).
omega.
(* ... location *)
rewrite Rcompare_half_r.
rewrite <- Rcompare_sqr.
replace ((2 * sqrt (Z2R (q * q + r))) * (2 * sqrt (Z2R (q * q + r))))%R
  with (4 * Rsqr (sqrt (Z2R (q * q + r))))%R by (unfold Rsqr ; ring).
rewrite Rsqr_sqrt.
change 4%R with (Z2R 4).
rewrite <- Z2R_plus, <- 2!Z2R_mult.
rewrite Rcompare_Z2R.
replace ((q + (q + 1)) * (q + (q + 1)))%Z with (4 * (q * q) + 4 * q + 1)%Z by ring.
generalize (Zle_cases r q).
case (Zle_bool r q) ; intros Hr''.
change (4 * (q * q + r) < 4 * (q * q) + 4 * q + 1)%Z.
omega.
change (4 * (q * q + r) > 4 * (q * q) + 4 * q + 1)%Z.
omega.
rewrite <- Hq.
apply (Z2R_le 0).
now apply Zlt_le_weak.
apply Rmult_le_pos.
now apply (Z2R_le 0 2).
apply sqrt_ge_0.
rewrite <- Z2R_plus.
apply (Z2R_le 0).
omega.
Qed.

End Fcalc_sqrt.