From Coq Require Export Morphisms Setoid Program.Equality.
From ITree Require Export ITree ITreeFacts Eq.Rutt.
From Paco Require Import paco.
From Coq Require Export Eqdep EqdepFacts.

From Equations Require Import Equations.

Require Export HeterogeneousEventRelations.

Ltac inj_existT := repeat match goal with | H : existT _ _ _ = _ |- _ => apply inj_pair2 in H end.

Lemma rutt_inv_Vis :   forall (E1 E2 : Type -> Type) (R1 R2 : Type) (REv : forall A B : Type, E1 A -> E2 B -> Prop)
    (RAns : forall A B : Type, E1 A -> A -> E2 B -> B -> Prop) (RR : R1 -> R2 -> Prop) A B
    (e1 : E1 A) (e2 : E2 B) k1 k2,
    rutt REv RAns RR (Vis e1 k1) (Vis e2 k2) ->
    REv A B e1 e2 /\ (forall a b, RAns A B e1 a e2 b -> rutt REv RAns RR (k1 a) (k2 b)).
Proof.
  intros. pinversion H. inj_existT. subst. pclearbot. split; auto.
  intros. apply H7 in H0. pclearbot. auto.
Qed.

Definition extract {E1 E2 A B} (REAns : relationEAnsH E1 E2)
           (e1 : E1 A) (e2 : E2 B) : relationH A B :=
  fun a b => REAns A B e1 a e2 b.

Section Rutt6.

Context (D1 D2 E1 E2 : Type -> Type).
Context (REvE : relationEH E1 E2).
Context (REvAns : forall A B : Type, E1 A -> A -> E2 B -> B -> Prop ).

Context (REvInv : relationEH D1 D2).
Context (REvAnsInv : forall A B : Type, D1 A -> A -> D2 B -> B -> Prop).

Inductive rutt6F (sim : forall (A B : Type), D1 A -> D2 B -> itree E1 A -> itree E2 B -> Prop) :
   forall (A B : Type), D1 A -> D2 B -> itree' E1 A -> itree' E2 B -> Prop :=
  (* shows how the post condition of the itrees is reliant on d1 and d2*)
  | rutt6RetF (A B : Type) (d1 : D1 A) (d2 : D2 B) a b :
    REvAnsInv A B d1 a d2 b -> rutt6F sim A B d1 d2 (RetF a) (RetF b)
  | rutt6TauF (A B : Type) (d1 : D1 A) (d2 : D2 B) t1 t2 :
    sim A B d1 d2 t1 t2 -> rutt6F sim A B d1 d2 (TauF t1) (TauF t2)
  | rutt6VisF (A B C D : Type) (d1 : D1 A) (d2 : D2 B) (e1 : E1 C) (e2 : E2 D) k1 k2 :
    REvE C D e1 e2 ->
    (forall c d, REvAns C D e1 c e2 d -> sim A B d1 d2 (k1 c) (k2 d) ) ->
    rutt6F sim A B d1 d2 (VisF e1 k1) (VisF e2 k2)

  | rutt5TauL (A B : Type) (d1 : D1 A) (d2 : D2 B) t1 ot2 :
    rutt6F sim A B d1 d2 (observe t1) ot2 ->
    rutt6F sim A B d1 d2 (TauF t1) ot2
  | rutt5TauR (A B : Type) (d1 : D1 A) (d2 : D2 B) ot1 t2 :
    rutt6F sim A B d1 d2 ot1 (observe t2) ->
    rutt6F sim A B d1 d2 ot1 (TauF t2)
.

Hint Constructors rutt6F : itree.

Definition rutt6_ sim A B d1 d2 t1 t2 := rutt6F sim A B d1 d2 (observe t1) (observe t2).

Hint Unfold rutt6_ : itree.

Lemma rutt6_monot : monotone6 rutt6_.
Proof.
  repeat intro. red in IN. red.
  induction IN; eauto with itree.
Qed.

Definition rutt6 : forall (A B : Type), D1 A -> D2 B -> itree E1 A -> itree E2 B -> Prop := paco6 rutt6_ bot6.

#[local] Hint Resolve rutt6_monot : paco.

Lemma rutt6_to_rutt (A B : Type) (d1 : D1 A) (d2 : D2 B) :
  forall (t1 : itree E1 A) (t2 : itree E2 B),
    rutt6 A B d1 d2 t1 t2 ->
    rutt REvE REvAns (extract REvAnsInv d1 d2) t1 t2.
Proof.
  pcofix CIH. intros t1 t2 Ht12. punfold Ht12. red in Ht12. pstep. red.
  hinduction Ht12 before r; intros; pclearbot; eauto with itree.
  - constructor; auto.
  - constructor. right. apply CIH; auto.
  - constructor; auto. intros. apply H0 in H1. pclearbot. right.
    apply CIH; auto.
  - constructor. eauto.
  - constructor; eauto.
Qed.

Lemma rutt_to_rutt6 (A B : Type) (d1 : D1 A) (d2 : D2 B) :
  forall (t1 : itree E1 A) (t2 : itree E2 B),
    rutt REvE REvAns (extract REvAnsInv d1 d2) t1 t2 ->
    rutt6 A B d1 d2 t1 t2.
Proof.
  pcofix CIH. intros t1 t2 Ht12. punfold Ht12. red in Ht12. pstep. red.
  hinduction Ht12 before r; intros; pclearbot; eauto with itree.
  constructor; auto. intros. apply H0 in H1. pclearbot. right. apply CIH; auto.
Qed.

End Rutt6.

#[global] Hint Resolve rutt6_monot : paco.

Ltac use_simpobs := repeat match goal with
                           | H : RetF _ = observe ?t |- _ => apply simpobs in H
                           | H : TauF _ = observe ?t |- _ => apply simpobs in H
                           | H : VisF _ _ = observe ?t |- _ => apply simpobs in H
                           end.

Instance grutt_cong_eqit_eq {E1 E2 R1 R2 r rg} {RR : R1 -> R2 -> Prop} {REv RAns} :

  Proper (@eq_itree E1 R1 R1 eq ==> @eq_itree E2 R2 R2 eq  ==> flip impl)
         (gpaco2 (rutt_ REv RAns RR) (euttge_trans_clo RR) r rg  ).
Proof. eapply grutt_cong_eqit; intros; subst; auto. Qed.

Instance grutt_cong_euttge_eq {E1 E2 R1 R2 r rg} {RR : R1 -> R2 -> Prop} {REv RAns} :

  Proper (@euttge E1 R1 R1 eq ==> @euttge E2 R2 R2 eq  ==> flip impl)
         (gpaco2 (rutt_ REv RAns RR) (euttge_trans_clo RR) r rg  ).
Proof. eapply grutt_cong_euttge; intros; subst; auto. Qed.

(*move this to rutt theory*)
Lemma rutt_bind (E1 E2 : Type -> Type) (R1 R2 S1 S2 : Type) (REvE : relationEH E1 E2) (REvAns : relationEAnsH E1 E2)
  (RR : R1 -> R2 -> Prop) (RS : S1 -> S2 -> Prop) k1 k2 :
  (forall r1 r2, RR r1 r2 -> rutt REvE REvAns RS (k1 r1) (k2 r2) ) ->
  forall t1 t2, rutt REvE REvAns RR t1 t2 -> rutt REvE REvAns RS (bind t1 k1) (bind t2 k2).
Proof.
  intros Hk. ginit. gcofix CIH. intros. punfold H0. red in H0.
  remember (observe t1) as x. remember (observe t2) as y.
  hinduction H0 before r; intros; use_simpobs.
  - rewrite Heqx, Heqy. setoid_rewrite bind_ret_l. gfinal. right.
    eapply paco2_mon; [eapply Hk; eauto | intros; contradiction].
  - rewrite Heqx, Heqy. setoid_rewrite bind_tau. gstep. constructor.
    gfinal. pclearbot. left. apply CIH. auto.
  - rewrite Heqx, Heqy. setoid_rewrite bind_vis. gstep. constructor. auto.
    intros. apply H0 in H1. pclearbot. gfinal. left. eapply CIH. auto.
  - rewrite Heqx. rewrite tau_euttge. eauto.
  - rewrite Heqy. rewrite tau_euttge. eauto.
Qed.

Variant EvEq {E : Type -> Type} : forall (A B : Type), E A -> E B -> Prop :=
  | eveq (A : Type) (e : E A) : EvEq A A e e.

Variant EvEqAns {E : Type -> Type} : forall A B, E A -> A -> E B -> B -> Prop :=
  | eveqans A (e : E A) (a : A) : EvEqAns A A e a e a.

Lemma rutt_to_eutt (E : Type -> Type) R1 R2 RR :
  forall (t1 : itree E R1) (t2 : itree E R2),
    rutt EvEq EvEqAns RR t1 t2 -> eutt RR t1 t2.
Proof.
  ginit. gcofix CIH. intros t1 t2 Ht12. punfold Ht12. red in Ht12.
  remember (observe t1) as ot1. remember (observe t2) as ot2.
  hinduction Ht12 before r; intros; use_simpobs.
  - rewrite Heqot1, Heqot2. gstep. constructor. auto.
  - rewrite Heqot1, Heqot2. gstep. constructor. gfinal. left. pclearbot. eauto.
  - rewrite Heqot1, Heqot2. dependent destruction H. gstep. constructor. intros.
    gfinal. left. apply CIH. assert (EvEqAns A A e v e v). constructor. apply H0 in H. pclearbot. auto.
  - rewrite Heqot1, tau_euttge. auto.
  - rewrite Heqot2, tau_euttge. auto.
Qed.

(*this is working fine but very annoying finish it monday morning*)
Lemma rutt_cong_eqit_eql: forall (E1 E2 : Type -> Type) (R1 R2 : Type)
                            (RR : R1 -> R2 -> Prop)
                            (REv : forall A B : Type, E1 A -> E2 B -> Prop)
                            (RAns : forall A B : Type, E1 A -> A -> E2 B -> B -> Prop)
                            (b1 b2 : bool) (t1 t2 : itree E1 R1) (t4 : itree E2 R2),
    eqit eq b1 b2 t1 t2 ->
    rutt REv RAns RR t2 t4 -> rutt REv RAns RR t1 t4.
Proof.
  intros E1 E2 R1 R2 RR REv RAns b1 b2. ginit. gcofix CIH.
  intros t1 t2 t4 Ht12 Ht24. punfold Ht24. red in Ht24.
  punfold Ht12. red in Ht12. remember (observe t1) as x.
  remember (observe t2) as y. remember (observe t4) as z.
  hinduction Ht24 before r; intros; use_simpobs.
  - remember (RetF r1) as or. hinduction Ht12 before r; intros; inv Heqor; use_simpobs; eauto.
    + rewrite Heqz. rewrite Heqx. gstep. constructor. auto.
    + rewrite Heqx. rewrite tau_euttge. eauto.
  - assert (DEC: (exists m3, x = TauF m3) \/ (forall m3, x <> TauF m3)).
     { destruct x; eauto; right; repeat intro; discriminate. }
     destruct DEC as [ [m3 Hm3]  | Hx ].
     + subst. symmetry in Hm3. use_simpobs. rewrite Hm3, Heqz. gstep. constructor.
       gfinal. left. pclearbot. eapply CIH; eauto. apply eqit_inv_Tau. rewrite <- Hm3.
       pstep. auto.
     + destruct x; try (exfalso; eapply Hx; eauto; fail).
       {
         pclearbot. use_simpobs. rewrite Heqx. clear Heqx t1. rewrite Heqz, tau_euttge. clear Heqz t4 Hx.
         inv Ht12. punfold H. red in H. remember (RetF r0) as x.
         hinduction REL before r; intros; inv Heqx; use_simpobs.
         - gfinal. right. eapply paco2_mon; [ pstep; apply H | intros; contradiction].
         - eapply IHREL; eauto. pstep_reverse. apply rutt_inv_Tau_l. pstep. auto.
       }
       {
         pclearbot. rewrite Heqz, tau_euttge. use_simpobs. rewrite Heqx. inv Ht12.
         punfold H. red in H. remember (VisF e k) as x. hinduction REL before r; intros; inv Heqx0; inj_existT; subst.
         - pclearbot. remember (VisF e0 k2) as x. remember (observe m2) as om2.
           hinduction H before r; intros; inv Heqx0; inj_existT; subst.
           + use_simpobs. rewrite Heqom2. gstep. constructor; auto. intros. apply H0 in H1.
             pclearbot. gfinal. left. eapply CIH; eauto. apply REL.
           + use_simpobs. rewrite Heqom2. rewrite tau_euttge. eauto.
         - eapply IHREL; eauto. pstep_reverse. apply rutt_inv_Tau_l. pstep. auto.
       }
  - rewrite Heqz. remember (VisF e1 k1) as y. hinduction Ht12 before r; intros; inv Heqy0; inj_existT; subst; use_simpobs.
    + rewrite Heqx. gstep. constructor; auto. intros. pclearbot. gfinal. left. eapply CIH; eauto.
      apply REL. apply H0 in H1. pclearbot. auto.
    + rewrite Heqx, tau_euttge; eauto.
  - subst.
    inv Ht12. pclearbot; use_simpobs.
    + rewrite H0, tau_euttge. eapply IHHt24; eauto. pstep_reverse.
    + use_simpobs. rewrite H0, tau_euttge. inv CHECK. eapply IHHt24; eauto.
      pstep_reverse. apply eqit_inv_Tau_r. pstep. auto.
    + eapply IHHt24; eauto.
  - rewrite Heqz, tau_euttge. eauto.
Qed.

Lemma rutt_cong_eqit_eqr: forall (E1 E2 : Type -> Type) (R1 R2 : Type)
                            (RR : R1 -> R2 -> Prop)
                            (REv : forall A B : Type, E1 A -> E2 B -> Prop)
                            (RAns : forall A B : Type, E1 A -> A -> E2 B -> B -> Prop)
                            (b1 b2 : bool) (t1 : itree E1 R1) (t2 t4 : itree E2 R2),
    eqit eq b1 b2 t2 t4 ->
    rutt REv RAns RR t1 t2 -> rutt REv RAns RR t1 t4.
Proof.
  intros E1 E2 R1 R2 RR REv RAns b1 b2. ginit. gcofix CIH.
  intros t1 t2 t4 Ht12 Ht24. punfold Ht24. red in Ht24.
  punfold Ht12. red in Ht12. remember (observe t1) as x.
  remember (observe t2) as y. remember (observe t4) as z.
  hinduction Ht24 before r; intros; use_simpobs.
  - remember (RetF r2) as or. hinduction Ht12 before r; intros; inv Heqor; use_simpobs; eauto.
    + rewrite Heqz. rewrite Heqx. gstep. constructor. auto.
    + rewrite Heqz. rewrite tau_euttge. eauto.
  - assert (DEC: (exists m3, z = TauF m3) \/ (forall m3, z <> TauF m3)).
     { destruct z; eauto; right; repeat intro; discriminate. }
     destruct DEC as [ [m3 Hm3]  | Hz ].
     + subst. symmetry in Hm3. use_simpobs. rewrite Hm3, Heqx. gstep. constructor.
       gfinal. left. pclearbot. eapply CIH; eauto. apply eqit_inv_Tau. rewrite <- Hm3.
       pstep. auto.
     + destruct z; try (exfalso; eapply Hz; eauto; fail).
       {
         pclearbot. use_simpobs. rewrite Heqx. clear Heqx t1. rewrite Heqz, tau_euttge.
         inv Ht12. punfold H. red in H. remember (RetF r0) as x.
         hinduction REL before r; intros; inv Heqx; use_simpobs.
         - gfinal. right. eapply paco2_mon; [ pstep; apply H | intros; contradiction].
         - eapply IHREL; eauto. pstep_reverse. apply rutt_inv_Tau_r. pstep. auto.
       }
       {
         pclearbot. use_simpobs. rewrite Heqz, Heqx, tau_euttge. inv Ht12.
         punfold H. red in H. remember (VisF e k) as x. hinduction REL before r; intros; inv Heqx0; inj_existT; subst.
         - pclearbot. remember (VisF e0 k1) as x. remember (observe m1) as om2.
           hinduction H before r; intros; inv Heqx0; inj_existT; subst.
           + use_simpobs. rewrite Heqom2. gstep. constructor; auto. intros. apply H0 in H1.
             pclearbot. gfinal. left. eapply CIH; eauto. apply REL.
           + use_simpobs. rewrite Heqom2. rewrite tau_euttge. eauto.
         - eapply IHREL; eauto. pstep_reverse. apply rutt_inv_Tau_r. pstep. auto.
       }
  - rewrite Heqx. remember (VisF e2 k2) as y. hinduction Ht12 before r; intros; inv Heqy0; inj_existT; subst; use_simpobs.
    + rewrite Heqz. gstep. constructor; auto. intros. pclearbot. gfinal. left. eapply CIH; eauto.
      apply REL. apply H0 in H1. pclearbot. auto.
    + rewrite Heqz, tau_euttge; eauto.
  - rewrite Heqx, tau_euttge. eapply IHHt24; eauto.
  - inv Ht12. pclearbot; use_simpobs.
    + rewrite H1, tau_euttge. eapply IHHt24; eauto. pstep_reverse.
    + eapply IHHt24; eauto.
    + use_simpobs. rewrite H0, tau_euttge. eapply IHHt24; eauto. inv CHECK. pstep_reverse.
      eapply eqit_inv_Tau_l. pstep. auto.
Qed.

Instance rutt_cong_eqit_eq {E1 E2 R1 R2} {RR : R1 -> R2 -> Prop} {REv RAns} b1 b2 :
  Proper (@eqit E1 R1 R1 eq b1 b2 ==> @eqit E2 R2 R2 eq b1 b2 ==> flip impl) (rutt REv RAns RR).
Proof.
  intros t1 t2 Ht12 t3 t4 Ht34 H.
  eapply rutt_cong_eqit_eql; eauto. eapply rutt_cong_eqit_eqr; eauto. apply eqit_flip in Ht34.
  eapply eqit_mon; try apply Ht34; eauto.
Qed.

Section MRec.

Context (D1 D2 E : Type -> Type).
Context (bodies1 : D1 ~> itree (D1 +' E)).
Context (bodies2 : D2 ~> itree (D2 +' E)).
(*
Context (A B :Type).
Context (init1 : D1 A).
Context (init2 : D2 B).
*)
Context (REvE : relationEH E E).
Context (REvAns : forall A B : Type, E A -> A -> E B -> B -> Prop ).

Context (REvInv : relationEH D1 D2).
Context (REvAnsInv : forall A B : Type, D1 A -> A -> D2 B -> B -> Prop).

Context (Hbodies : forall A B (d1 : D1 A) (d2 : D2 B), REvInv A B d1 d2 ->
         rutt (sum_relE REvInv REvE) (sum_relAns REvAnsInv REvAns) (extract REvAnsInv d1 d2)
            (bodies1 A d1) (bodies2 B d2) ).
(*maybe rutt actually needs to be changed? the types seem a little too constrained here
  if rutt took in a family of relations indexed by types? then there might be more hope *)

Instance eq_itree_Proper {E1 E2 R1 R2} {R : itree E1 R1 -> itree E2 R2 -> Prop} :  Proper (@eq_itree E1 R1 R1 eq ==> @eq_itree E2 R2 R2 eq ==> flip impl) R.
Admitted. (* needs an axiom to prove this, can be more specific later, possibly even do some gpaco stuff, but for now I just
             want to see how it works out *)

Lemma rutt_mrec_interp_mrec_aux:
  forall (A : Type) (d1 : D1 A) (B : Type)
    (d2 : D2 B)
    (r : forall x x0 : Type, D1 x -> D2 x0 -> itree E x -> itree E x0 -> Prop),
    (forall (A0 : Type) (init1 : D1 A0) (B0 : Type)
       (init2 : D2 B0),
        REvInv A0 B0 init1 init2 ->
        r A0 B0 init1 init2 (mrec bodies1 init1) (mrec bodies2 init2)) ->
    (forall (m1 : itree (D1 +' E) A) (m2 : itree (D2 +' E) B),
        paco2
          (rutt_ (sum_relE REvInv REvE) (sum_relAns REvAnsInv REvAns)
                 (extract REvAnsInv d1 d2)) bot2 m1 m2 ->
        r A B d1 d2 (interp_mrec bodies1 m1) (interp_mrec bodies2 m2)) ->
    forall (m1 : itree (D1 +' E) A) (m2 : itree (D2 +' E) B),
      paco2
        (rutt_ (sum_relE REvInv REvE) (sum_relAns REvAnsInv REvAns)
               (extract REvAnsInv d1 d2)) bot2 m1 m2 ->
      paco6 (rutt6_ D1 D2 E E REvE REvAns REvAnsInv) r A B d1 d2
            (interp_mrec bodies1 m1) (interp_mrec bodies2 m2).
Proof.
  intros A d1 B d2 r. intros CIH1 CIH2 m1 m2 Hm.
  punfold Hm. red in Hm. remember (observe m1) as x. remember (observe m2) as y.
  hinduction Hm before r; intros; use_simpobs.
  - rewrite Heqx, Heqy. setoid_rewrite unfold_iter. cbn. setoid_rewrite bind_ret_l.
    pstep. constructor; auto.
  - pclearbot. rewrite Heqx, Heqy. setoid_rewrite unfold_iter.
    cbn. setoid_rewrite bind_ret_l. pstep. constructor. right.
    eapply CIH2; eauto.
  - rewrite Heqx, Heqy. inversion H; inj_existT; subst.
    + setoid_rewrite unfold_iter. cbn.
      setoid_rewrite bind_ret_l. pstep. constructor. right. eapply CIH2.
      eapply rutt_bind; eauto.
      intros. red in H1.
      eapply sum_relEAns_inl in H1. apply H0 in H1. pclearbot. auto.
    + setoid_rewrite unfold_iter. cbn.
      setoid_rewrite bind_vis. setoid_rewrite bind_ret_l.
      pstep. constructor; auto. intros. left. pstep. constructor.
      right. eapply CIH2; eauto.
      assert (sum_relAns REvAnsInv REvAns A0 B0 (inr1 f1) c (inr1 f2) d). constructor. auto.
      apply H0 in H2. pclearbot. auto.
  - rewrite Heqx. setoid_rewrite unfold_iter at 1. cbn. setoid_rewrite bind_ret_l.
    pstep. constructor. pstep_reverse.
  - rewrite Heqy. setoid_rewrite unfold_iter at 2. cbn. setoid_rewrite bind_ret_l.
    pstep. constructor. pstep_reverse.
Qed.

Theorem rutt_mrec :
  forall A B (init1 : D1 A) (init2 : D2 B),
    REvInv A B init1 init2 -> rutt REvE REvAns (extract REvAnsInv init1 init2)
         (mrec bodies1 init1) (mrec bodies2 init2).
Proof.
  intros. apply rutt6_to_rutt. generalize dependent B. generalize dependent A.
  pcofix CIH. unfold mrec. intros A d1 B d2 Hd12.
  specialize (Hbodies A B d1 d2 Hd12) as Hbodiesd.
  punfold Hbodiesd. red in Hbodiesd. remember (observe (bodies1 A d1)) as x.
  remember (observe (bodies2 B d2)) as y. hinduction Hbodiesd before r; intros; use_simpobs; pclearbot.
  - rewrite Heqx, Heqy. unfold interp_mrec. setoid_rewrite unfold_iter. setoid_rewrite bind_ret_l.
    pstep. constructor. auto.
  - rewrite Heqx, Heqy.
    unfold interp_mrec at 1. rewrite unfold_iter. cbn. rewrite bind_ret_l.
    fold (interp_mrec bodies1 m1).
    unfold interp_mrec at 2. rewrite unfold_iter. cbn. rewrite bind_ret_l.
    fold (interp_mrec bodies2 m2). pstep. constructor. left.
    clear Heqx Heqy. generalize dependent m2. revert m1.
    pcofix CIH'. eapply rutt_mrec_interp_mrec_aux; eauto.
  - (* this may be set up wrong*)
    assert (Vis e1 k1 ≅ bind (trigger e1) k1 ). setoid_rewrite bind_trigger. reflexivity.
    assert (Vis e2 k2 ≅ bind (trigger e2) k2 ). setoid_rewrite bind_trigger. reflexivity.
    rewrite Heqx, Heqy. rewrite H1, H2. setoid_rewrite interp_mrec_bind. inversion H; inj_existT; subst; pclearbot.
    + (*interp_mrec_trigger   : interp_mrec ctx (ITree.trigger a) ≳ mrecursive ctx U a *)
      unfold interp_mrec at 1. rewrite unfold_iter. cbn. setoid_rewrite bind_ret_l. rewrite bind_tau.
      fold (interp_mrec bodies1  (ITree.bind (bodies1 A0 e0) (fun x : A0 => Ret x))).
      setoid_rewrite <- interp_mrec_bind.
      unfold interp_mrec at 2. rewrite unfold_iter. cbn. rewrite bind_ret_l. setoid_rewrite bind_ret_l.
      fold (interp_mrec bodies2  (ITree.bind (bodies2 _ e3) (fun x => k2 x))). setoid_rewrite bind_ret_r.
      pstep. constructor. left.
      assert (Hb12 : rutt (sum_relE REvInv REvE)
               (sum_relAns REvAnsInv REvAns)
               (extract REvAnsInv d1 d2) (ITree.bind (bodies1 A0 e0) k1) (ITree.bind (bodies2 B0 e3) k2)).
      {
        eapply rutt_bind; eauto.
        intros. red in H3. eapply sum_relEAns_inl in H3. apply H0 in H3.
        pclearbot. auto.
      }
      remember (ITree.bind (bodies1 A0 e0) k1) as t1.
      remember (ITree.bind (bodies2 B0 e3) k2) as t2. clear Heqt1 Heqt2.
      generalize dependent t2. generalize dependent t1. pcofix CIH'.
      eapply rutt_mrec_interp_mrec_aux; eauto.
    + unfold interp_mrec at 1. rewrite unfold_iter. cbn. rewrite bind_vis. setoid_rewrite bind_ret_l.
      rewrite bind_vis. setoid_rewrite unfold_iter at 1. cbn. setoid_rewrite bind_ret_l.
      setoid_rewrite bind_tau. setoid_rewrite bind_ret_l.
      unfold interp_mrec at 2. rewrite unfold_iter. cbn. rewrite bind_vis. setoid_rewrite bind_ret_l.
      rewrite bind_vis. setoid_rewrite unfold_iter at 2. cbn. setoid_rewrite bind_ret_l.
      setoid_rewrite bind_tau. setoid_rewrite bind_ret_l. pstep. constructor; auto.
      intros. left. pstep. constructor. left.
      assert (Hcd : sum_relAns REvAnsInv REvAns _ _ (inr1 f1) c (inr1 f2) d). econstructor. auto.
      apply H0 in Hcd. pclearbot. remember (k1 c) as kc. remember (k2 d) as kd.
      clear Heqkc Heqkd. generalize dependent kd. revert kc. pcofix CIH.
      eapply rutt_mrec_interp_mrec_aux; eauto.
  - rewrite Heqx.
    unfold interp_mrec at 1. rewrite unfold_iter. cbn. rewrite bind_ret_l.
    fold (interp_mrec bodies1 t1). pstep. constructor. pstep_reverse.
    assert (Htd2 : rutt (sum_relE REvInv REvE)
               (sum_relAns REvAnsInv REvAns)
               (extract REvAnsInv d1 d2) t1 (bodies2 B d2) ).
    {
      apply Hbodies in Hd12.
      assert (bodies1 A d1 ≈ t1). rewrite Heqx, tau_eutt. reflexivity. rewrite <- H. auto.
    }
    remember (bodies2 B d2) as t2. clear Heqx Heqy Heqt2 IHHbodiesd Hbodiesd. generalize dependent t2. generalize dependent t1.
    pcofix CIH. intros. eapply rutt_mrec_interp_mrec_aux; eauto.
  - rewrite Heqy.
    unfold interp_mrec at 2. rewrite unfold_iter. cbn. rewrite bind_ret_l.
    fold (interp_mrec bodies2 t2). pstep. constructor. pstep_reverse.
    assert (Htd2 : rutt (sum_relE REvInv REvE)
               (sum_relAns REvAnsInv REvAns)
               (extract REvAnsInv d1 d2) (bodies1 A d1) t2 ).
    {
      apply Hbodies in Hd12.
      assert (bodies2 _ d2 ≈ t2). rewrite Heqy, tau_eutt. reflexivity. rewrite <- H. auto.
    }
    remember (bodies1 _ d1) as t1. clear Heqx Heqy Heqt1 IHHbodiesd Hbodiesd. generalize dependent t2. generalize dependent t1.
    pcofix CIH. intros. eapply rutt_mrec_interp_mrec_aux; eauto.
Qed.

End MRec.

Theorem eutt_mrec (E D1 D2 : Type -> Type)
        (REvInv : relationEH D1 D2)  (REvAnsInv : forall A B : Type, D1 A -> A -> D2 B -> B -> Prop)
        (bodies1 : D1 ~> itree (D1 +' E) ) (bodies2 : D2 ~> itree (D2 +' E) ) :
  ( forall A B (d1 : D1 A) (d2 : D2 B), REvInv A B d1 d2 ->
                                   rutt (sum_relE REvInv EvEq) (sum_relAns REvAnsInv EvEqAns) (extract REvAnsInv d1 d2)
                                        (bodies1 A d1) (bodies2 B d2) ) ->
  forall A B (init1 : D1 A) (init2 : D2 B) ,
    REvInv A B init1 init2 -> eutt (extract REvAnsInv init1 init2)
         (mrec bodies1 init1) (mrec bodies2 init2).
Proof.
  intros.
  apply rutt_to_eutt. eapply rutt_mrec; eauto.
Qed.

Section MrecTauTest.

  Variant BoolRec : Type -> Type :=
    boolrec : BoolRec bool.

  Definition bodies1 (A : Type) (b : BoolRec A) : itree (BoolRec +' BoolRec)  A.
    destruct b. apply (Ret false).
  Defined.

  Definition bodies2 (A : Type) (b : BoolRec A) : itree (BoolRec +' BoolRec) A.
    destruct b. apply (Vis (inr1 boolrec) (fun b => Ret b)).
  Defined.

  Goal mrec bodies1 boolrec ≅ (Ret false).
    Proof.
      unfold mrec, interp_mrec. rewrite unfold_iter. cbn. rewrite bind_ret_l.
      reflexivity.
    Qed.

  Goal mrec bodies2 boolrec ≅ ((Vis (boolrec) (fun b => Tau (Ret b)))).
  Proof.
    setoid_rewrite unfold_iter. cbn. rewrite bind_vis.
    setoid_rewrite bind_ret_l. setoid_rewrite unfold_iter. cbn.
    setoid_rewrite bind_ret_l. reflexivity.
  Qed.

  (*
    Ret false <= Vis exists (fun b => Ret b)

    ~ Ret false <= Vis exists (fun b => Tau (Ret b))

    ~ Ret false <= Tau (Ret false)

   *)

  (*this demonstrates that extra taus get in which is why I need a solution to the eutt
    problem, the thing is that it is not clear what that problem would be
    the saturated thing sounds like a good idea but I looked at the proof and don't see
    where it helps, suggesting there may be other counter examples
   *)

End MrecTauTest.


Set Implicit Arguments.

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

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

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

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


(* *********************************************************************)
(*                                                                     *)
(*              The Compcert verified compiler                         *)
(*                                                                     *)
(*          Xavier Leroy, INRIA Paris-Rocquencourt                     *)
(*                                                                     *)
(*  Copyright Institut National de Recherche en Informatique et en     *)
(*  Automatique.  All rights reserved.  This file is distributed       *)
(*  under the terms of the INRIA Non-Commercial License Agreement.     *)
(*                                                                     *)
(* *********************************************************************)

(** Translation of parallel moves into sequences of individual moves.

  In this file, we adapt the generic "parallel move" algorithm
  (developed and proved correct in module [Parmov]) to the idiosyncraties
  of the [LTLin] and [Linear] intermediate languages.  While the generic
  algorithm assumes that registers never overlap, the locations
  used in [LTLin] and [Linear] can overlap, and assigning one location
  can set the values of other, overlapping locations to [Vundef].
  We address this issue in the remainder of this file.
*)

Require Import Coqlib.
Require Parmov.
Require Import Values.
Require Import Events.
Require Import AST.
Require Import Locations.
Require Import Conventions.

(** * Instantiating the generic parallel move algorithm *)

(** The temporary location to use for a move is determined
  by the type of the data being moved: register [IT2] for an
  integer datum, and register [FT2] for a floating-point datum. *)

Definition temp_for (l: loc) : loc :=
  match Loc.type l with Tint => R IT2 | Tfloat => R FT2 end.

Definition parmove (srcs dsts: list loc) :=
  Parmov.parmove2 loc Loc.eq temp_for srcs dsts.

Definition moves := (list (loc * loc))%type.

(** [exec_seq m] gives semantics to a sequence of elementary moves.
  This semantics ignores the possibility of overlap: only the
  target locations are updated, but the locations they
  overlap with are not set to [Vundef].  See [effect_seqmove] below
  for a semantics that accounts for overlaps. *)

Definition exec_seq (m: moves) (e: Locmap.t) : Locmap.t :=
  Parmov.exec_seq loc Loc.eq val m e.

Lemma temp_for_charact:
  forall l, temp_for l = R IT2 \/ temp_for l = R FT2.
Proof.
  intro; unfold temp_for. destruct (Loc.type l); tauto.
Qed.

Lemma is_not_temp_charact:
  forall l,
  Parmov.is_not_temp loc temp_for l <-> l <> R IT2 /\ l <> R FT2.
Proof.
  intros. unfold Parmov.is_not_temp.
  destruct (Loc.eq l (R IT2)).
  subst l. intuition. apply (H (R IT2)). reflexivity. discriminate.
  destruct (Loc.eq l (R FT2)).
  subst l. intuition. apply (H (R FT2)). reflexivity.
  assert (forall d, l <> temp_for d).
    intro. elim (temp_for_charact d); congruence.
  intuition.
Qed.

Lemma disjoint_temp_not_temp:
  forall l, Loc.notin l temporaries -> Parmov.is_not_temp loc temp_for l.
Proof.
  intros. rewrite is_not_temp_charact.
  unfold temporaries in H; simpl in H.
  split; apply Loc.diff_not_eq; tauto.
Qed.

Lemma loc_norepet_norepet:
  forall l, Loc.norepet l -> list_norepet l.
Proof.
  induction 1; constructor.
  apply Loc.notin_not_in; auto. auto.
Qed.

(** Instantiating the theorems proved in [Parmov], we obtain
  the following properties of semantic correctness and well-typedness
  of the generated sequence of moves.  Note that the semantic
  correctness result is stated in terms of the [exec_seq] semantics,
  and therefore does not account for overlap between locations. *)

Lemma parmove_prop_1:
  forall srcs dsts,
  List.length srcs = List.length dsts ->
  Loc.norepet dsts ->
  Loc.disjoint srcs temporaries ->
  Loc.disjoint dsts temporaries ->
  forall e,
  let e' := exec_seq (parmove srcs dsts) e in
  List.map e' dsts = List.map e srcs /\
  forall l, ~In l dsts -> l <> R IT2 -> l <> R FT2 -> e' l = e l.
Proof.
  intros.
  assert (NR: list_norepet dsts) by (apply loc_norepet_norepet; auto).
  assert (NTS: forall r, In r srcs -> Parmov.is_not_temp loc temp_for r).
    intros. apply disjoint_temp_not_temp. apply Loc.disjoint_notin with srcs; auto.
  assert (NTD: forall r, In r dsts -> Parmov.is_not_temp loc temp_for r).
    intros. apply disjoint_temp_not_temp. apply Loc.disjoint_notin with dsts; auto.
  generalize (Parmov.parmove2_correctness loc Loc.eq temp_for val srcs dsts H NR NTS NTD e).
  change (Parmov.exec_seq loc Loc.eq val (Parmov.parmove2 loc Loc.eq temp_for srcs dsts) e) with e'.
  intros [A B].
  split. auto. intros. apply B. auto. rewrite is_not_temp_charact; auto.
Qed.

Lemma parmove_prop_2:
  forall srcs dsts s d,
  In (s, d) (parmove srcs dsts) ->
     (In s srcs \/ s = R IT2 \/ s = R FT2)
  /\ (In d dsts \/ d = R IT2 \/ d = R FT2).
Proof.
  intros srcs dsts.
  set (mu := List.combine srcs dsts).
  assert (forall s d, Parmov.wf_move loc temp_for mu s d ->
            (In s srcs \/ s = R IT2 \/ s = R FT2)
         /\ (In d dsts \/ d = R IT2 \/ d = R FT2)).
  unfold mu; induction 1.
  split.
    left. eapply List.in_combine_l; eauto.
    left. eapply List.in_combine_r; eauto.
  split.
    right. apply temp_for_charact.
    tauto.
  split.
    tauto.
    right. apply temp_for_charact.
  intros. apply H.
  apply (Parmov.parmove2_wf_moves loc Loc.eq temp_for srcs dsts s d H0).
Qed.

Lemma loc_type_temp_for:
  forall l, Loc.type (temp_for l) = Loc.type l.
Proof.
  intros; unfold temp_for. destruct (Loc.type l); reflexivity.
Qed.

Lemma loc_type_combine:
  forall srcs dsts,
  List.map Loc.type srcs = List.map Loc.type dsts ->
  forall s d,
  In (s, d) (List.combine srcs dsts) ->
  Loc.type s = Loc.type d.
Proof.
  induction srcs; destruct dsts; simpl; intros; try discriminate.
  elim H0.
  elim H0; intros. inversion H1; subst. congruence.
  apply IHsrcs with dsts. congruence. auto.
Qed.

Lemma parmove_prop_3:
  forall srcs dsts,
  List.map Loc.type srcs = List.map Loc.type dsts ->
  forall s d,
  In (s, d) (parmove srcs dsts) -> Loc.type s = Loc.type d.
Proof.
  intros srcs dsts TYP.
  set (mu := List.combine srcs dsts).
  assert (forall s d, Parmov.wf_move loc temp_for mu s d ->
            Loc.type s = Loc.type d).
  unfold mu; induction 1.
  eapply loc_type_combine; eauto.
  rewrite loc_type_temp_for; auto.
  rewrite loc_type_temp_for; auto.
  intros. apply H.
  apply (Parmov.parmove2_wf_moves loc Loc.eq temp_for srcs dsts s d H0).
Qed.

(** * Accounting for overlap between locations *)

Section EQUIVALENCE.

(** We now prove the correctness of the generated sequence of elementary
  moves, accounting for possible overlap between locations.
  The proof is conducted under the following hypotheses: there must
  be no partial overlap between
- two distinct destinations (hypothesis [NOREPET]);
- a source location and a destination location (hypothesis [NO_OVERLAP]).
*)

Variables srcs dsts: list loc.
Hypothesis LENGTH: List.length srcs = List.length dsts.
Hypothesis NOREPET: Loc.norepet dsts.
Hypothesis NO_OVERLAP: Loc.no_overlap srcs dsts.
Hypothesis NO_SRCS_TEMP: Loc.disjoint srcs temporaries.
Hypothesis NO_DSTS_TEMP: Loc.disjoint dsts temporaries.

(** [no_overlap_dests l] holds if location [l] does not partially overlap
  a destination location: either it is identical to one of the
  destinations, or it is disjoint from all destinations. *)

Definition no_overlap_dests (l: loc) : Prop :=
  forall d, In d dsts -> l = d \/ Loc.diff l d.

(** We show that [no_overlap_dests] holds for any destination location
  and for any source location. *)

Lemma dests_no_overlap_dests:
  forall l, In l dsts -> no_overlap_dests l.
Proof.
  assert (forall d, Loc.norepet d ->
          forall l1 l2, In l1 d -> In l2 d -> l1 = l2 \/ Loc.diff l1 l2).
  induction 1; simpl; intros.
  contradiction.
  elim H1; intro; elim H2; intro.
  left; congruence.
  right. subst l1. eapply Loc.in_notin_diff; eauto.
  right. subst l2. apply Loc.diff_sym. eapply Loc.in_notin_diff; eauto.
  eauto.
  intros; red; intros. eauto.
Qed.

Lemma notin_dests_no_overlap_dests:
  forall l, Loc.notin l dsts -> no_overlap_dests l.
Proof.
  intros; red; intros.
  right. eapply Loc.in_notin_diff; eauto.
Qed.

Lemma source_no_overlap_dests:
  forall s, In s srcs \/ s = R IT2 \/ s = R FT2 -> no_overlap_dests s.
Proof.
  intros. elim H; intro. exact (NO_OVERLAP s H0).
  elim H0; intro; subst s; red; intros;
  right; apply Loc.diff_sym; apply NO_DSTS_TEMP; auto; simpl; tauto.
Qed.

Lemma source_not_temp1:
  forall s, In s srcs \/ s = R IT2 \/ s = R FT2 ->
  Loc.diff s (R IT1) /\ Loc.diff s (R FT1) /\ Loc.notin s destroyed_at_move.
Proof.
  intros. destruct H.
  exploit Loc.disjoint_notin. eexact NO_SRCS_TEMP. eauto.
  simpl; tauto.
  destruct H; subst s; simpl; intuition congruence.
Qed.

Lemma dest_noteq_diff:
  forall d l,
  In d dsts \/ d = R IT2 \/ d = R FT2 ->
  l <> d ->
  no_overlap_dests l ->
  Loc.diff l d.
Proof.
  intros. elim H; intro.
  elim (H1 d H2); intro. congruence. auto.
  assert (forall r, l <> R r -> Loc.diff l (R r)).
    intros. destruct l; simpl. congruence. destruct s; auto.
  elim H2; intro; subst d; auto.
Qed.

(** [locmap_equiv e1 e2] holds if the location maps [e1] and [e2]
  assign the same values to all locations except temporaries [IT1], [FT1]
  and except locations that partially overlap a destination. *)

Definition locmap_equiv (e1 e2: Locmap.t): Prop :=
  forall l,
  no_overlap_dests l -> Loc.diff l (R IT1) -> Loc.diff l (R FT1) -> Loc.notin l destroyed_at_move -> e2 l = e1 l.

(** The following predicates characterize the effect of one move
  move ([effect_move]) and of a sequence of elementary moves
  ([effect_seqmove]).  We allow the code generated for one move
  to use the temporaries [IT1] and [FT1] and [destroyed_at_move] in any way it needs. *)

Definition effect_move (src dst: loc) (e e': Locmap.t): Prop :=
  e' dst = e src /\
  forall l, Loc.diff l dst -> Loc.diff l (R IT1) -> Loc.diff l (R FT1) -> Loc.notin l destroyed_at_move -> e' l = e l.

Inductive effect_seqmove: list (loc * loc) -> Locmap.t -> Locmap.t -> Prop :=
  | effect_seqmove_nil: forall e,
      effect_seqmove nil e e
  | effect_seqmove_cons: forall s d m e1 e2 e3,
      effect_move s d e1 e2 ->
      effect_seqmove m e2 e3 ->
      effect_seqmove ((s, d) :: m) e1 e3.

(** The following crucial lemma shows that [locmap_equiv] is preserved
  by executing one move [d <- s], once using the [effect_move]
  predicate that accounts for partial overlap and the use of
  temporaries [IT1], [FT1], or via the [Parmov.update] function that
  does not account for any of these. *)

Lemma effect_move_equiv:
  forall s d e1 e2 e1',
  (In s srcs \/ s = R IT2 \/ s = R FT2) ->
  (In d dsts \/ d = R IT2 \/ d = R FT2) ->
  locmap_equiv e1 e2 -> effect_move s d e1 e1' ->
  locmap_equiv e1' (Parmov.update loc Loc.eq val d (e2 s) e2).
Proof.
  intros. destruct H2. red; intros.
  unfold Parmov.update. destruct (Loc.eq l d).
  subst l. destruct (source_not_temp1 _ H) as [A [B C]].
  rewrite H2. apply H1; auto. apply source_no_overlap_dests; auto.
  rewrite H3; auto. apply dest_noteq_diff; auto.
Qed.

(** We then extend the previous lemma to a sequence [mu] of elementary moves.
*)

Lemma effect_seqmove_equiv:
  forall mu e1 e1',
  effect_seqmove mu e1 e1' ->
  forall e2,
  (forall s d, In (s, d) mu ->
     (In s srcs \/ s = R IT2 \/ s = R FT2) /\
     (In d dsts \/ d = R IT2 \/ d = R FT2)) ->
  locmap_equiv e1 e2 ->
  locmap_equiv e1' (exec_seq mu e2).
Proof.
  induction 1; intros.
  simpl. auto.
  simpl. apply IHeffect_seqmove.
  intros. apply H1. apply in_cons; auto.
  destruct (H1 s d (in_eq _ _)).
  eapply effect_move_equiv; eauto.
Qed.

(** Here is the main result in this file: executing the sequence
  of moves returned by the [parmove] function results in the
  desired state for locations: the final values of destination locations
  are the initial values of source locations, and all locations
  that are disjoint from the temporaries and the destinations
  keep their initial values. *)

Lemma effect_parmove:
  forall e e',
  effect_seqmove (parmove srcs dsts) e e' ->
  List.map e' dsts = List.map e srcs /\
  forall l, Loc.notin l dsts -> Loc.notin l temporaries -> e' l = e l.
Proof.
  set (mu := parmove srcs dsts). intros.
  assert (locmap_equiv e e) by (red; auto).
  generalize (effect_seqmove_equiv mu e e' H e (parmove_prop_2 srcs dsts) H0).
  intro.
  generalize (parmove_prop_1 srcs dsts LENGTH NOREPET NO_SRCS_TEMP NO_DSTS_TEMP e).
  fold mu. intros [A B].
  (* e' dsts = e srcs *)
  split. rewrite <- A. apply list_map_exten; intros.
  exploit Loc.disjoint_notin. eexact NO_DSTS_TEMP. eauto. simpl; intros.
  apply H1. apply dests_no_overlap_dests; auto.
  tauto. tauto. simpl; tauto.
  (* other locations *)
  intros. transitivity (exec_seq mu e l).
  symmetry. apply H1. apply notin_dests_no_overlap_dests; auto.
  eapply Loc.in_notin_diff; eauto. simpl; tauto.
  eapply Loc.in_notin_diff; eauto. simpl; tauto.
  simpl in H3; simpl; tauto.
  apply B. apply Loc.notin_not_in; auto.
  apply Loc.diff_not_eq. eapply Loc.in_notin_diff; eauto. simpl; tauto.
  apply Loc.diff_not_eq. eapply Loc.in_notin_diff; eauto. simpl; tauto.
Qed.

End EQUIVALENCE.


(**********************************************************************)
(* 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 *)
(* 021101301 USA                                                     *)
(**********************************************************************)

(**********************************************************************)
(*                        Case.v                                      *)
(*                                                                    *)
(*                     Barry Jay                                      *)
(*                                                                    *)
(**********************************************************************)

Require Import Omega Max Bool List.
Require Import IntensionalLib.SF_calculus.Test.
Require Import IntensionalLib.SF_calculus.General.
Require Import IntensionalLib.Tree_calculus.Tree_Terms.
Require Import IntensionalLib.Tree_calculus.Tree_Tactics.
Require Import IntensionalLib.Tree_calculus.Tree_reduction.
Require Import IntensionalLib.Tree_calculus.Tree_Normal.
Require Import IntensionalLib.Tree_calculus.Tree_Closed.
Require Import IntensionalLib.Tree_calculus.Substitution.
Require Import IntensionalLib.Tree_calculus.Tree_Eval.
Require Import IntensionalLib.Tree_calculus.Star.
Require Import IntensionalLib.Tree_calculus.Wait.
Require Import IntensionalLib.Tree_calculus.Fixpoints.
Require Import IntensionalLib.Tree_calculus.Wave_Factor.
Require Import IntensionalLib.Tree_calculus.Wave_Factor2.
Require Import IntensionalLib.Tree_calculus.Equal.

Lemma aux1: forall p q, S(S(S(S(S p)))) <= q ->
                        pred (pred (pred (q - S p))) = q - S (S (S (S p))).
  intros.
  replace (pred (q - S p)) with (q - (S (S p)))  by omega.
  replace (pred (q - S(S p))) with (q - (S (S (S p))))  by omega.
omega.
Qed.

Lemma aux3 : forall M, pred (max match maxvar (lift 1 M) with
             | 0 => 1
             | S m' => S m'
             end 1) = maxvar M - 0.
Proof.
intros. rewrite max_pred. simpl. rewrite max_zero.
  replace (maxvar M - 0) with (maxvar M) by omega.
assert(maxvar M = 0 \/ maxvar M <> 0) by decide equality.
inversion H. unfold lift; rewrite lift_rec_closed. rewrite H0; auto. auto.
clear H.
assert(maxvar (lift 1 M) = S(maxvar M)).
induction M; split_all. gen_case H0 n.
simpl in *. noway.
simpl in *.
assert (maxvar M1 = 0 -> maxvar (lift_rec M1 0 1) = 0) by (split_all; rewrite lift_rec_closed; auto).

gen3_case H0 H IHM1  (maxvar M1) . rewrite H; auto.
unfold lift in *; rewrite IHM1; auto.
assert (maxvar M2 = 0 -> maxvar (lift_rec M2 0 1) = 0) by (split_all; rewrite lift_rec_closed; auto).
gen3_case H0 H1 IHM2  (maxvar M2) . rewrite H1; auto.
rewrite IHM2; auto.
rewrite H. auto.
Qed.

Lemma max_aux: forall m n, max m n = m \/ max m n = n .
Proof.
induction m; split_all. induction n; split_all.
assert(max m n = m \/ max m n = n) by eapply2 IHm.
inversion H; rewrite H0; auto.
Qed.

Lemma maxvar_lift_rec_compare:
forall M p  n k, p>= maxvar M  -> p+k >= maxvar (lift_rec M n k).
Proof.
induction M; split_all.
unfold relocate. elim(test n0 n); split_all.  omega. omega. omega.
elim(max_is_max (maxvar M1) (maxvar M2)). intros.
eapply2 max_max2.
eapply2 IHM1. omega.
eapply2 IHM2. omega.
Qed.

Lemma lift_rec_misses:
forall M n k, n >= maxvar M  -> lift_rec M n k = M.
Proof.
induction M; split_all. relocate_lt. auto.
assert(max (maxvar M1) (maxvar M2) >= maxvar M1 /\ max (maxvar M1) (maxvar M2) >= maxvar M2)
by eapply2 max_is_max. split_all.
rewrite IHM1; try omega. rewrite IHM2; auto; omega.
Qed.

Lemma maxvar_lift_rec_compare2:
forall M N n k, maxvar M >= maxvar N -> maxvar (lift_rec M n k) >= maxvar (lift_rec N n k).
Proof.
induction M; split_all.
gen_case H N.
(* 5 *)
unfold relocate. elim(test n0 n); split_all. elim(test n0 n1); split_all; try noway.
omega. omega. elim(test n0 n1); split_all; try noway.
(* 4 *)
omega.
(* 3 *)
unfold relocate. elim(test n0 n); split_all.
assert(max (maxvar t) (maxvar t0) >= maxvar t /\ max (maxvar t) (maxvar t0) >= maxvar t0) by eapply2 max_is_max.
split_all.
replace (S(k+n)) with (S n + k) by omega.
eapply2 max_max2; eapply2 maxvar_lift_rec_compare; omega.
assert(max (maxvar t) (maxvar t0) >= maxvar t /\ max (maxvar t) (maxvar t0) >= maxvar t0) by eapply2 max_is_max.
split_all.
rewrite ! lift_rec_misses; try omega.
(* 2 *)
rewrite lift_rec_closed; auto. omega.
(* 1 *)
assert(max (maxvar M1) (maxvar M2)  = maxvar M1 \/
max (maxvar M1) (maxvar M2) = maxvar M2) by eapply2 max_aux.
assert(max (maxvar (lift_rec M1 n k)) (maxvar (lift_rec M2 n k)) >=(maxvar (lift_rec M1 n k)) /\
max (maxvar (lift_rec M1 n k)) (maxvar (lift_rec M2 n k)) >=(maxvar (lift_rec M2 n k)))
by eapply2 max_is_max.
split_all. inversion H0.
assert(maxvar (lift_rec M1 n k) >= maxvar (lift_rec N n k)). eapply2 IHM1; omega.  omega.
assert(maxvar (lift_rec M2 n k) >= maxvar (lift_rec N n k)). eapply2 IHM2; omega.  omega.
Qed.

Lemma aux4 : forall M p,
     match
       pred
         (pred
            (maxvar (lift_rec M p 3) - p))
     with
     | 0 => 0
     | S m' => m'
     end = maxvar M - p
.
Proof.
induction M; split_all.
(* 2 *)
 case p; split_all. relocate_lt.
simpl. auto.
unfold relocate.
elim(test (S n0) n); split_all.
(* 3 *)
gen_case a n0. omega.
gen_case a n1. gen_case a n. omega.
gen_case a n2. gen_case a n. gen_case a n3. omega.
unfold minus at 2; fold minus.
assert(forall m n, m - (S n) = pred (m-n)) by (intros; omega).
rewrite ! H. unfold pred at 3;  auto.
case (pred(pred (n-n3))); auto.
(* 2 *)
assert(pred(pred(n-n0)) = 0) by omega.
rewrite H. omega.
(* 1 *)
assert(max (maxvar M1) (maxvar M2) = maxvar M1 \/ max (maxvar M1) (maxvar M2) = maxvar M2) by
eapply2 max_aux.
inversion H.  rewrite H0.
assert( maxvar(lift_rec M1 p 3) >= max (maxvar (lift_rec M1 p 3)) (maxvar (lift_rec M2 p 3))).
eapply2 max_max2. eapply2 maxvar_lift_rec_compare2.
assert(max (maxvar M1) (maxvar M2) >= maxvar M2) by eapply2 max_is_max.
rewrite H0 in H1. auto.
assert(max (maxvar (lift_rec M1 p 3)) (maxvar (lift_rec M2 p 3))>= maxvar(lift_rec M1 p 3))
by eapply2 max_is_max.
assert(max (maxvar (lift_rec M1 p 3)) (maxvar (lift_rec M2 p 3)) = maxvar(lift_rec M1 p 3))
by omega.
rewrite H3. eapply2 IHM1.
(* 1 *)
assert( maxvar(lift_rec M2 p 3) >= max (maxvar (lift_rec M1 p 3)) (maxvar (lift_rec M2 p 3))).
eapply2 max_max2. eapply2 maxvar_lift_rec_compare2.
assert(max (maxvar M1) (maxvar M2) >= maxvar M1) by eapply2 max_is_max.
rewrite H0 in H1. auto.
assert(max (maxvar (lift_rec M1 p 3)) (maxvar (lift_rec M2 p 3))>= maxvar(lift_rec M2 p 3))
by eapply2 max_is_max.
assert(max (maxvar (lift_rec M1 p 3)) (maxvar (lift_rec M2 p 3)) = maxvar(lift_rec M2 p 3))
by omega.
rewrite H3. rewrite H0. eapply2 IHM2.
Qed.

Definition swap M := App (App (Op Node) (App (Op Node) (App k_op M))) i_op.

Lemma swap_check : forall M N, sf_red (App (swap M) N) (App N M).
Proof.
unfold swap; split_all; eval_tac. eval_tac.
eapply succ_red. eapply app_sf_red. eapply2 k_red.  eval_tac.
eapply2 preserves_app_sf_red;  eval_tac.
Qed.

(*
Lemma star_opt_swap :
star_opt (swap (Ref 0)) = App (App s_op (App k_op  (App s_op i_op ))) k_op .
Proof. split_all. Qed.
*)

Definition case_app case (P1 P2 M : Tree) :=
(star_opt (App (App (App (App Fop (Ref 0)) i_op)
                               (lift 1 (star_opt (star_opt (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)))).

Ltac occurs_true_tac M :=
rewrite (star_opt_occurs_true M) at 1;
[| rewrite ! occurs_app; replace (occurs 0 (Ref 0)) with true by split_all;
rewrite ? orb_true_r; auto | discriminate].

Ltac occurs_false_tac M :=
rewrite (star_opt_occurs_false M) at 1; [| split_all].

(* restore

Definition s_op :=
star_opt (star_opt (star_opt (App (App (Ref 2) (Ref 0))
                                  (App (Ref 1) (Ref 0))))).

Definition case_app_nf case (P1 P2 M: Tree) :=
(App
        (App s_op
           (App
              (App s_op
                 (App (App s_op Fop) (App k_op  i_op )))
              (App k_op
                 (App
                    (App s_op
                       (App (App s_op (App k_op  s_op))
                          (App
                             (App s_op
                                (case P1
                                   (case P2 (App k_op  (App k_op  M)))))
                             (App k_op
                                (App k_op
                                   (App k_op  (App k_op  i_op )))))))
                    (App k_op  (App k_op  (App k_op  i_op )))))))
        (App (App s_op (App k_op  (App s_op i_op ))) k_op )).

Lemma case_app_val :
forall case P1 P2 M, sf_red (case_app case P1 P2 M) (case_app_nf case P1 P2 M).
Proof.
intros; unfold case_app.
unfold star_opt at 3;  unfold occurs; fold occurs 0.
unfold lift; rewrite ! occurs_lift_rec_zero. simpl.
rewrite subst_rec_lift_rec; try omega.
rewrite ! occurs_lift_rec_zero. simpl.
unfold subst; rewrite subst_rec_lift_rec; try omega.
rewrite ! occurs_lift_rec_zero. simpl.
rewrite subst_rec_lift_rec; try omega.
rewrite ! lift_rec_null.
eapply2 preserves_app_sf_red.
eapply2 zero_red.
Qed.

*)

Lemma program_app: forall M N, program (App M N) -> program M /\ program N.
Proof.
unfold program; intros. inversion H.
simpl in *; max_out; inversion H0; split; split; auto.
Qed.

Fixpoint is_program M :=
match M with
| Ref _ => false
| Op _ => true
| App (Op _) M2 => is_program M2
| App (App (Op _) M1) M2 => is_program M1 && is_program M2
| _ => false
end.

Lemma program_is_program: forall M, program M <-> is_program M = true.
Proof.
induction M; intros; auto.
(* 3 *)
  split. unfold program. simpl. intro c; inversion c; discriminate.
discriminate.
(* 2 *)
split; intro; unfold program; split; auto.
(* 1 *)
gen_case IHM1 M1.
(* 3 *)
  split. unfold program. simpl. intro c; inversion c.
gen_case H0 (maxvar M2); discriminate.
intro; discriminate.
(* 2 *)
split. unfold program.  intro. inversion H.
eapply2 IHM2. inversion H0; simpl in H1.
assert(status (App (Op o) M2) = Passive).
eapply2 closed_implies_passive.
rewrite H7 in H6; discriminate.
split; auto.
intro.
assert(program M2) by eapply2 IHM2.
 split; auto. nf_out. inversion H0; auto.
case o; auto. simpl; inversion H0; auto.
(* 1 *)
gen_case IHM1 t.
(* 3 *)
  split. unfold program. simpl. intro c; inversion c.
gen_case H0 (maxvar t0); gen_case H0 (maxvar M2); discriminate.
intro; discriminate.
(* 2 *)
split. unfold program.  intro. inversion H.
assert(is_program t0 = true).
eapply2 IHM1.  split; auto. nf_out.
inversion H0.
assert(status (App (App (Op o) t0) M2) = Passive).
eapply2 closed_implies_passive.
rewrite H7 in H6; discriminate. inversion H4; auto. case o; auto.
simpl in *; max_out.
rewrite H2; simpl. eapply2 IHM2.
eapply2 (program_app (App (Op o) t0) M2).
intro.
apply eq_sym in H.
assert(true = is_program t0 /\ true = is_program M2) by eapply2 andb_true_eq.
inversion H0.
assert(program M2) by eapply2 IHM2.
assert(program (App (Op o) t0)) by eapply2 IHM1.
inversion H3; inversion H4. inversion H7.
split.
nf_out. case o; auto. case o; auto. simpl in *.
rewrite H6; rewrite H8; auto.
 split; auto. nf_out. case o; auto.
simpl in *. rewrite H6; rewrite H8; auto.
(* 1 *)
gen_case IHM1 t1.
(* 3 *)
  split. unfold program. simpl. intro c; inversion c.
gen_case H0 (maxvar t2); gen_case H0 (maxvar t0);  gen_case H0 (maxvar M2);  discriminate.
intro; discriminate.
(* 2 *)
split. unfold program.  intro. inversion H. inversion H0.
assert(status (App (App (App (Op o) t2) t0) M2) = Passive).
eapply2 closed_implies_passive.
rewrite H7 in H6; discriminate. inversion H6.
intro.  discriminate.
split; intro.
inversion H.  inversion H0.
assert(status (App (App (App (App t3 t4) t2) t0) M2) = Passive).
eapply2 closed_implies_passive.
rewrite H7 in H6; discriminate. inversion H6.
discriminate.
Qed.

Fixpoint case P M :=
(* case P M is applied to the argument and then the default function.
   The default function is either discared or swapped to the left.
   Indices in P are renumbered, with binding from left to right
*)
 match P with
  | Ref _ => star_opt (App k_op M)
  | Op _ => star_opt (App (App (App Fop (Ref 0)) (App k_op (lift 1 M)))
                            (App k_op (App k_op (swap (Ref 0)))))
  | App P1 P2 =>
if is_program P
then star_opt (App (App (App (App equal_comb (Ref 0)) P) (App k_op (lift 1 M))) (swap (Ref 0)))
else case_app case P1 P2 M
                end
.

Lemma case_leaf: forall M R, sf_red (App (App (case (Op Node)M) (Op Node)) R) M.
Proof.
intros; unfold case.
eapply transitive_red. eapply preserves_app_sf_red.
eapply2 star_opt_beta. auto.  unfold_op.
unfold subst; rewrite ! subst_rec_app. rewrite ! subst_rec_ref.
insert_Ref_out.
rewrite ! (subst_rec_closed Fop). 2: simpl; auto.
unfold lift;  rewrite subst_rec_lift_rec; try omega.
 rewrite ! lift_rec_null.
rewrite ! (subst_rec_closed (Op Node)). 2: simpl; auto.
eapply transitive_red. eapply preserves_app_sf_red.
eapply2 factor_leaf.  auto. eval_tac.
Qed.

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

Lemma pattern_size_ref: forall i, pattern_size (Ref i) = 1.
Proof. auto. Qed.

Lemma pattern_size_app: forall M N, pattern_size (App M N) = pattern_size M + pattern_size N.
Proof. auto. Qed.

Lemma pattern_size_op: forall o, pattern_size (Op o) = 0.
Proof. auto. Qed.

Lemma lift_rec_preserves_pattern_size: forall M n k, pattern_size (lift_rec M n k) = pattern_size M.
Proof. induction M; split_all. Qed.

Lemma pattern_size_closed: forall M, maxvar M = 0 -> pattern_size M = 0.
Proof. induction M; split_all.  noway. rewrite IHM1; max_out; rewrite IHM2; max_out. Qed.

(* restore ?
Lemma pattern_size_A_k : forall k, pattern_size (A_k k) = 0.
Proof. unfold A_k. intro. rewrite pattern_size_closed. auto. rewrite A_k_closed. auto. Qed.

Lemma pattern_size_omega_k : forall k, pattern_size (omega_k k) = 0.
Proof. unfold omega_k. intro. rewrite pattern_size_closed. auto.
rewrite ? maxvar_star_opt. unfold maxvar; fold maxvar.
rewrite?  maxvar_app_comb.   unfold maxvar; fold maxvar. rewrite A_k_closed.
rewrite?  maxvar_app_comb.   unfold maxvar; fold maxvar. auto.
Qed.
*)

Lemma pattern_size_lt_maxvar: forall P, maxvar P = 0 -> pattern_size P = 0.
Proof. induction P; split_all. omega.  max_out. Qed.

Lemma aux_lift_rec: forall M p n k,
lift_rec (lift_rec M (p + n) k) p 3 = lift_rec (lift_rec (lift_rec M (p + n) k) p 2) (p+2) 1.
Proof.
intros. rewrite (lift_rec_lift_rec (lift_rec M (p + n) k)); try omega. auto.
Qed.

Lemma lift_rec_preserves_case:
  forall P M n k, lift_rec (case P M) n k = case P (lift_rec M (pattern_size P +n) k).
Proof.
  induction P; intros.
  (* 3 *)
  unfold case, maxvar. rewrite lift_rec_preserves_star_opt. unfold_op.
  unfold lift_rec; fold lift_rec.  unfold pattern_size. auto.
  (* 2 *)
    unfold case, maxvar, pattern_size, swap, lift_rec; fold lift_rec.
  case o; unfold_op.
    rewrite lift_rec_preserves_star_opt.
unfold lift; rewrite ! lift_rec_app.
rewrite (lift_rec_closed Fop).
2: eapply2 Fop_closed.
unfold lift_rec; fold lift_rec. relocate_lt.
unfold plus; fold plus.
rewrite ! lift_lift_rec; try omega. auto.
    (* 1 *)
    unfold case; fold case.
assert(is_program (App P1 P2) = true \/ is_program (App P1 P2) <> true) by decide equality.
inversion H. rewrite H0.
(* 2 *)
assert(program (App P1 P2)) by eapply2 program_is_program.  inversion H1.
rewrite lift_rec_preserves_star_opt.
unfold swap; unfold_op. rewrite ! lift_rec_app.
rewrite lift_rec_closed.
2: eapply2 equal_comb_closed.
unfold lift_rec; fold lift_rec. relocate_lt.
rewrite 2? lift_rec_closed. 2: simpl in H3; max_out. 2: simpl in H3; max_out.
rewrite pattern_size_closed.
unfold lift; rewrite lift_lift_rec; try omega.
unfold plus; congruence.  auto.
(* 1 *)
assert(is_program (App P1 P2) = false).
eapply2 not_true_iff_false.
rewrite H1.
(* 1 *)
    unfold case_app, swap, lift. unfold_op.
rewrite lift_rec_preserves_star_opt.
rewrite ! lift_rec_app.
rewrite lift_rec_closed.
2: eapply2 Fop_closed.
  unfold lift_rec; fold lift_rec. relocate_lt.
rewrite ! lift_rec_preserves_star_opt.
rewrite ! lift_rec_app.
     rewrite ! IHP1. rewrite ! IHP2.
rewrite ! lift_rec_app.
rewrite lift_rec_closed. 2: simpl; auto.
rewrite ! (lift_rec_closed (Op Node)). 2: simpl; auto.
2: simpl; auto. 2: simpl; auto.
  unfold lift_rec at 5 7. relocate_lt.
    unfold lift_rec; fold lift_rec. relocate_lt.
unfold pattern_size; fold pattern_size.
unfold plus; fold plus.
f_equal. f_equal. f_equal. f_equal.
f_equal. f_equal. f_equal. f_equal.
f_equal. f_equal. f_equal. f_equal.
f_equal.

replace (pattern_size P1 + 0) with (pattern_size P1) by auto.
clear.
rewrite (lift_rec_lift_rec M); try omega.
replace((pattern_size P2 +
                                          (pattern_size P1 + S (S (S n)))))
with ((1+2) + (pattern_size P2 + pattern_size P1 + n)) by omega.
rewrite (lift_lift_rec M) at 1; try omega.
replace(pattern_size P2 + (pattern_size P1 + 2))
with (2+ (pattern_size P2 + pattern_size P1)) by omega.
rewrite (lift_lift_rec); try omega.
rewrite (lift_rec_lift_rec (lift_rec M _ _)); try omega.
f_equal.  f_equal. omega.
Qed.

Lemma aux2 : forall M N p k, subst_rec (lift_rec M p (1 + 2)) N
     (S (S (S k)) + p) =
   lift_rec (subst_rec M N (k + p))
     p (1 + 2).
Proof.
intros. unfold plus; fold plus. replace (S(S(S (k+ p)))) with (3+ (k+p)) by omega.
rewrite subst_rec_lift_rec1; try omega. auto.
Qed.

Lemma subst_rec_preserves_case:
  forall P M N k, subst_rec (case P M) N k = case P (subst_rec M N (k+ pattern_size P)).
Proof.
  induction P; intros.
  (* 3 *)
  unfold case, maxvar, pattern_size. rewrite subst_rec_preserves_star_opt.
  unfold_op; unfold subst_rec; fold subst_rec.  replace (k+1) with (S k) by omega; auto.
  (* 2 *)
  unfold case, maxvar, swap. case o; unfold_op.
 rewrite subst_rec_preserves_star_opt.
rewrite ! subst_rec_app.
rewrite subst_rec_closed.
 2: rewrite Fop_closed; omega.
rewrite ! (subst_rec_closed (Op Node)). 2: simpl; omega.
  unfold subst_rec; fold subst_rec.
insert_Ref_out.
unfold lift. rewrite (subst_rec_lift_rec1 M); try omega.
unfold pattern_size; fold pattern_size.
  replace (k+0) with k by omega. auto.
  (* 1 *)
  unfold case; fold case.
assert(is_program (App P1 P2) = true \/ is_program (App P1 P2) <> true) by decide equality.
inversion H. rewrite H0.
(* 2 *)
assert(program (App P1 P2)) by eapply2 program_is_program.  inversion H1.
rewrite subst_rec_preserves_star_opt.
unfold swap; unfold_op; rewrite ! subst_rec_app.
rewrite subst_rec_closed. 2: rewrite equal_comb_closed; omega.
unfold subst_rec; fold subst_rec. insert_Ref_out.
rewrite 2? subst_rec_closed. 2: simpl in H3; max_out. 2: simpl in H3; max_out.
rewrite pattern_size_closed. 2: auto.
unfold lift; rewrite subst_rec_lift_rec1; try omega.
replace (k+0) with k by omega; congruence.
(* 1 *)
assert(is_program (App P1 P2) = false).
eapply2 not_true_iff_false.
rewrite H1.
(* 1 *)
  unfold case_app.
rewrite subst_rec_preserves_star_opt.
rewrite ! subst_rec_app.
rewrite subst_rec_closed.
2: rewrite Fop_closed; omega.
unfold lift; rewrite subst_rec_lift_rec1. 2: omega.
  unfold subst_rec; fold subst_rec. insert_Ref_out.
rewrite ! subst_rec_preserves_star_opt.
rewrite ! lift_rec_preserves_star_opt.
rewrite ! subst_rec_app.
rewrite ! lift_rec_preserves_case.
rewrite ! (subst_rec_closed k_op). 2: simpl; omega.
unfold subst_rec; fold subst_rec.
insert_Ref_out.
rewrite ! (subst_rec_closed i_op). 2: unfold_op; simpl; omega.
2: unfold_op; simpl; omega.
  rewrite IHP1. rewrite IHP2.
  unfold subst_rec; fold subst_rec.
unfold pattern_size; fold pattern_size.
rewrite ! lift_rec_app.
rewrite ! lift_rec_preserves_case.
rewrite ! (lift_rec_closed k_op). 2: simpl; omega.  2: simpl; omega.
rewrite ! subst_rec_app.
rewrite ! (subst_rec_closed k_op). 2: simpl; omega.
rewrite ! lift_rec_app.
rewrite ! (lift_rec_closed k_op). 2: simpl; omega.
unfold swap, subst_rec; fold subst_rec.
unfold lift_rec; fold lift_rec. relocate_lt.
insert_Ref_out.
rewrite ! (subst_rec_closed i_op). 2: simpl; omega.
rewrite ! (subst_rec_closed k_op). 2: simpl; omega.
f_equal. f_equal. f_equal. f_equal.
f_equal. f_equal. f_equal. f_equal.
f_equal. f_equal. f_equal. f_equal.
f_equal.
rewrite (lift_rec_lift_rec); try omega.
replace (S (S k) + pattern_size P1 + pattern_size P2) with
(2 + (pattern_size P2 + pattern_size P1 + k)) by omega.
rewrite subst_rec_lift_rec1; try omega.
rewrite lift_rec_lift_rec; try omega.
replace  (k+ (pattern_size P1 + (pattern_size P2)))
    with (pattern_size P2 + pattern_size P1 + k)
      by omega.
auto.
Qed.

Inductive pattern_normal : nat -> Tree -> Prop :=
| pnf_normal : forall j M, normal M -> pattern_normal j M
(*  pattern_normal j (Ref n)
| pnFop : forall j o, pattern_normal j (Op o)
| pnf_active : forall j M1 M2, normal M1 -> normal j M2 ->
                              status (App M1 M2) = Active ->
                              pattern_normal j (App M1 M2)
*)
| pnf_compound : forall j M1 M2, pattern_normal j M1 -> pattern_normal j M2 ->
                              compound (App M1 M2) -> pattern_normal j (App M1 M2)
| pnf_active : forall j M1 M2, pattern_normal j M1 -> pattern_normal j M2 ->
                              status (App M1 M2) = Active -> pattern_normal j (App M1 M2)
| pnf_break : forall j M1 M2, pattern_normal j M1 -> pattern_normal j M2 ->
                              0 < maxvar M2 -> maxvar M2 <= j ->
                              pattern_normal j (App M1 M2)
(* actually, it is enough that one of the pattern variables occurs in M2 *)
.

(*
Lemma pattern_normal_1_occurs :
forall M, pattern_normal 1 M ->
normal M \/ exists M1 M2, M = App M1 M2 /\ occurt0 M2 = true.
Proof.
induction M; split_all; try discriminate.  inversion H; subst.  auto.
right; exists M1; exist M2. split; auto.
clear - H5 H6.
induction M2; split_all; simpl in *.
assert(n= 0) by omega. subst. auto. noway.
assert(0< maxvar M2_1 \/ 0< maxvar M2_2).

gen_case H5 (maxvar M2_1);  gen_case H5 (maxvar M2_2).
left; omega. inversion H.
rewrite IHM2_1; auto.
gen_case H6 (maxvar M2_1). gen_case H6 (maxvar M2_2).
gen_case H6 n.  gen_case H6 n0. noway.
rewrite IHM2_2; auto. apply orb_true_r.
gen_case H6 (maxvar M2_1). gen_case H6 (maxvar M2_2).
gen_case H6 n.  gen_case H6 n0. noway.
Qed.
*)

Lemma pattern_normal_closed:
forall M, maxvar M = 0 -> forall j, pattern_normal j M -> normal M.
Proof.
induction M; split_all. max_out. inversion H0; subst; auto.
eapply2 nf_compound.
assert(status (App M1 M2) = Passive).
eapply2 (closed_implies_passive).  simpl; rewrite H1; rewrite H2; auto.
rewrite H in H7; discriminate.
   noway.
Qed.

Lemma normal_star_opt_app:
forall M1 M2, occurs 0 (App M1 M2)  >0
-> normal (star_opt M1) -> normal (star_opt M2) ->
normal (star_opt (App M1 M2)).
Proof.
intros.  unfold star_opt; fold star_opt. simpl in H.
assert(occurs 0 M1 >0 \/ occurs 0 M2 >0) by omega.
inversion H2.
replace (occurs 0 M1) with (S (pred (occurs 0 M1))) by omega.
eapply2 nf_compound.
assert(occurs 0 M1 >0 \/ occurs 0 M1 = 0) by omega.
inversion H4.
(* 2 *)
replace (occurs 0 M1) with (S (pred (occurs 0 M1))) by omega.
eapply2 nf_compound.
(* 1 *)
replace (occurs 0 M2) with (S (pred (occurs 0 M2))) by omega.
rewrite H5.
assert(M2 = Ref 0 \/ M2 <> Ref 0) by repeat decide equality.
inversion H6. subst.
assert(star_opt M1 = App k_op (subst M1 (Op Node))).
rewrite star_opt_occurs_false. auto. auto.
rewrite H7 in *.
inversion H0; auto.
(* 1 *)
replace(match M2 with
    | Ref 0 => subst M1 (Op Node)
    | _ => App (App (Op Node) (App (Op Node) (star_opt M2))) (star_opt M1)
        end) with (App (App (Op Node) (App (Op Node) (star_opt M2))) (star_opt M1)).
unfold_op; eapply2 nf_compound.
gen_case H7 M2.
gen_case H7 n. congruence.
Qed.

(* delete
Lemma pattern_normal_subst_occurs_false:
forall M j, occurs 0 M = false -> pattern_normal j M  ->
pattern_normal (pred j) (subst M s_op).
Proof.
induction M; split_all.
gen2_case H H0 n; unfold subst, subst_rec; insert_Ref_out.
discriminate. eapply2 pnf_normal.
unfold subst, subst_rec; eapply2 pnf_normal.
rewrite orb_false_iff in H. inversion H.
inversion H0; subst.
eapply2 pnf_normal.
unfold subst. eapply2 occurs_false_subst_normal.
simpl; rewrite H1; rewrite H2; auto.
eapply2 pnf_compound.  fold subst_rec.
eapply2 occurs_false_subst_normal. fold subst_rec.
 assert(compound (subst_rec (App M1 M2) s_op 0)).
(eapply2 subst_rec_preserves_compounds).
simpl in H3. auto.
unfold subst, subst_rec; fold subst_rec.
apply pnf_break; fold subst_rec.
eapply2 IHM1. eapply2 IHM2.

assert(maxvar M2noway.

  inversion H1; subst; auto.
e

auto.

*)

Lemma occurs_false_subst_pattern_normal:
forall M j N, occurs 0 M = 0 -> pattern_normal j M -> pattern_normal (pred j) (subst_rec M N 0).
Proof.
induction M; split_all.
(* 3 *)
gen2_case H H0 n. discriminate.  insert_Ref_out. eapply2 pnf_normal.
(* 2 *)
eapply2 pnf_normal.
(* 1 *)
assert(occurs 0 M1 = 0 /\ occurs 0 M2 = 0) by omega.
inversion H1.
inversion H0.
(* 4 *)
 eapply2 pnf_normal.
assert(normal (subst_rec (App M1 M2) N 0)) by eapply2 occurs_false_subst_normal.
simpl in H7; auto.
(* 3 *)
eapply2 pnf_compound.
assert(compound (subst_rec (App M1 M2) N 0)) by eapply2 subst_rec_preserves_compounds.
simpl in H10; auto.
(* 2 *)
eapply2 pnf_active.
replace (App (subst_rec M1 N 0) (subst_rec M2 N 0)) with (subst_rec (App M1 M2) N 0) by auto.
rewrite occurs_false_subst_status.  auto. simpl; auto.
(* 1 *)
 subst.
eapply pnf_break. eapply2 IHM1. eapply2 IHM2.
(* 2 *)
eapply2 occurs_false_subst_rec_maxvar_gt0.
eapply2 occurs_false_subst_rec_maxvar_lt.
Qed.

Lemma pattern_normal_star_opt:
forall M j, pattern_normal j M -> pattern_normal (pred j) (star_opt M).
Proof.
induction M; intros.
(* 3 *)
eapply2 pnf_normal. eapply2 star_opt_normal.
(* 2 *)
eapply2 pnf_normal. eapply2 star_opt_normal.
(* 1 *)
 subst; inversion H; subst.
(* 4 *)
eapply2 pnf_normal. eapply2 star_opt_normal.
(* 3 *)
unfold star_opt; fold star_opt.
assert(occurs 0 M1 >0 \/ occurs 0 M1 = 0) by omega.
inversion H0.
(* 4 *)
replace (occurs 0 M1) with (S (pred (occurs 0 M1))) by omega.
eapply2 pnf_compound. eapply2 pnf_compound.  eapply2 pnf_normal.
eapply2 pnf_compound. eapply2 pnf_normal.
(* 3 *)
assert(pattern_normal  (pred j) (star_opt M2)) by eapply2 IHM2.
rewrite H1.
assert(pattern_normal (pred j) (subst_rec M1 (Op Node) 0)) .
eapply2 occurs_false_subst_pattern_normal.
assert(pattern_normal (pred j) (star_opt M1)) by eapply2 IHM1.
clear IHM1 IHM2 H H0 H1 .
(* 3 *)
unfold subst, subst_rec; fold subst_rec.
assert(pattern_normal (pred j) (App (App (Op Node) (App (Op Node) (star_opt M2))) (star_opt M1))).
eapply2 pnf_compound. eapply2 pnf_compound. eapply2 pnf_normal.
eapply2 pnf_compound. eapply2 pnf_normal.
assert(occurs 0 M2 = 0 ->
  pattern_normal (pred j) (App k_op (App (subst_rec M1 (Op Node) 0) (subst_rec M2 (Op Node) 0)))).
intro.
assert(pattern_normal (pred j) (subst_rec M2 (Op Node) 0)).
rewrite star_opt_occurs_false in H3.  2: auto.
inversion H3; subst; auto.
eapply2 pnf_normal.  inversion H1; auto.
eapply2 pnf_compound. unfold_op;  eapply2 pnf_normal.
2: unfold_op; auto.
eapply2 pnf_compound.
assert(compound (subst_rec (App M1 M2) (Op Node) 0)).
(eapply2 subst_rec_preserves_compounds).
simpl in H8.  auto.
(* 3 *)
gen3_case H H0 H7 M2. gen3_case H H0 H7 n.
gen3_case H H0 H7 (occurs 0 t + occurs 0 t0).
(* 2 *)
unfold star_opt; fold star_opt.
assert(occurs 0 M1 >0 \/ occurs 0 M1 = 0) by omega.
inversion H0.
(* 3 *)
replace (occurs 0 M1) with (S (pred (occurs 0 M1))) by omega.
eapply2 pnf_compound. eapply2 pnf_compound.  eapply2 pnf_normal.
 eapply2 pnf_compound.  eapply2 pnf_normal.
(* 2 *)
 rewrite H1.
 assert(pattern_normal  (pred j) (star_opt M2)) by eapply2 IHM2.
assert(pattern_normal (pred j) (subst_rec M1 (Op Node) 0)) .
eapply2 occurs_false_subst_pattern_normal.
assert(pattern_normal (pred j) (star_opt M1)) by eapply2 IHM1.
clear IHM1 IHM2 H H0 .
(* 2 *)
unfold subst, subst_rec; fold subst_rec.
assert(pattern_normal (pred j) (App (App (Op Node) (App (Op Node) (star_opt M2))) (star_opt M1))).
eapply2 pnf_compound. eapply2 pnf_compound. eapply2 pnf_normal. eapply2 pnf_compound. eapply2 pnf_normal.
assert(occurs 0 M2 = 0 ->
  pattern_normal (pred j) (App k_op (App (subst_rec M1 (Op Node) 0) (subst_rec M2 (Op Node) 0)))).
intro.
assert(pattern_normal (pred j) (subst_rec M2 (Op Node) 0)).
rewrite star_opt_occurs_false in H3.  2: auto.
inversion H3; subst; auto.
eapply2 pnf_normal.  inversion H8; auto.
eapply2 pnf_compound. unfold_op;  eapply2 pnf_normal.
2: unfold_op; auto.
eapply2 pnf_active.
replace (App (subst_rec M1 (Op Node) 0) (subst_rec M2 (Op Node) 0)) with
(subst_rec (App M1 M2) (Op Node) 0) by auto.
rewrite occurs_false_subst_status. auto.
simpl; omega.
(* 2 *)
gen3_case H H0 H7 M2. gen3_case H H0 H7 n.
gen3_case H H0 H7 (occurs 0 t + occurs 0 t0).
(* 1 *)
Set Keep Proof Equalities.
assert(M2 = Ref 0 \/ M2 <> Ref 0) by repeat decide equality.
inversion H0; subst.
assert(occurs 0 M1 >0 \/ occurs 0 M1 =0) by omega.
inversion H1; subst.
(* 3 *)
unfold star_opt; fold star_opt. replace (occurs 0 M1) with (S (pred (occurs 0 M1))) by omega.
eapply2 pnf_compound. eapply2 pnf_compound. eapply2 pnf_normal.
eapply2 pnf_compound. eapply2 pnf_normal.
unfold star_opt; fold star_opt. rewrite H4.
eapply2 occurs_false_subst_pattern_normal.
(* 1 *)
assert(occurs 0 M1 >0 \/ occurs 0 M1 =0) by omega.
inversion H4; subst.
(* 2 *)
unfold star_opt; fold star_opt. replace (occurs 0 M1) with (S (pred (occurs 0 M1))) by omega.
eapply2 pnf_compound. eapply2 pnf_compound. eapply2 pnf_normal.
eapply2 pnf_compound. eapply2 pnf_normal.
unfold star_opt; fold star_opt. rewrite H7.
(* 1 *)
assert(pattern_normal  (pred j) (star_opt M2)) by eapply2 IHM2.
assert(pattern_normal (pred j) (subst_rec M1 (Op Node) 0)) .
eapply2 occurs_false_subst_pattern_normal.
assert(pattern_normal (pred j) (star_opt M1)) by eapply2 IHM1.
(* 1 *)
unfold subst, subst_rec; fold subst_rec.
assert(pattern_normal (pred j) (App (App (Op Node) (App (Op Node) (star_opt M2))) (star_opt M1))).
eapply2 pnf_compound. eapply2 pnf_compound. eapply2 pnf_normal.  eapply2 pnf_compound. eapply2 pnf_normal.
assert(occurs 0 M2 = 0 ->
  pattern_normal (pred j) (App k_op (App (subst_rec M1 (Op Node) 0) (subst_rec M2 (Op Node) 0)))).
intro.
assert(pattern_normal (pred j) (subst_rec M2 (Op Node) 0)).
rewrite star_opt_occurs_false in H10.  2: auto.
eapply2 occurs_false_subst_pattern_normal. unfold_op.
eapply2 pnf_compound. eapply2 pnf_normal.
eapply2 pnf_break.
eapply2 occurs_false_subst_rec_maxvar_gt0.
eapply2 occurs_false_subst_rec_maxvar_lt.
(* 1 *)
gen3_case H11 H12 H1 M2. gen3_case H11 H12 H1 n.
gen3_case H11 H12 H1 (occurs 0 t + occurs 0 t0).
Qed.

Lemma pattern_normal_zero: forall M, pattern_normal 0 M -> normal M.
Proof.
induction M; split_all. inversion H; subst. auto.
eapply2 nf_compound.  eapply2 nf_active. noway.
Qed.

Lemma pattern_normal_gt:
forall j M, pattern_normal j M -> forall k, j <= k -> pattern_normal k M.
Proof.
intros j M pn; induction pn; split_all.
eapply2 pnf_normal. eapply2 pnf_compound. eapply2 pnf_active. eapply2 pnf_break.  omega.
Qed.

Lemma pattern_normal_app_comb: forall M N j, pattern_normal j M -> pattern_normal j N ->
pattern_normal j (app_comb M N).
Proof.
intros. replace (app_comb M N) with
(App (App (Op Node) (App (Op Node) i_op)) (App (App (Op Node) (App (Op Node) (App k_op N))) (App k_op M))) by auto.
unfold_op. eapply2 pnf_compound.  eapply2 pnf_compound. eapply2 pnf_normal.
unfold_op. eapply2 pnf_compound.  eapply2 pnf_normal.
eapply2 pnf_compound.  eapply2 pnf_compound.  eapply2 pnf_normal.
eapply2 pnf_normal.  eapply2 pnf_normal.
eapply2 pnf_compound.  eapply2 pnf_compound.  eapply2 pnf_normal.
eapply2 pnf_compound.  eapply2 pnf_normal.
eapply2 pnf_compound.  eapply2 pnf_normal.
eapply2 pnf_compound.  eapply2 pnf_normal.
Qed.

Lemma pattern_size_app_comb: forall M N, pattern_size (app_comb M N) = pattern_size N + pattern_size M.
Proof. intros. unfold app_comb. simpl. auto. Qed.

(* restore ?

Lemma case_normal:
forall (P M : Tree), normal M -> normal (case P M).
Proof.
  induction P; intros.
  (* 3 *)
  unfold case, maxvar.   eapply2 star_opt_normal. unfold_op; split_all.
  (* 2 *)
unfold case, swap; unfold_op; intros. case o; nf_out.
apply nf_active. nf_out. eapply2 nf_active; nf_out.
eapply2 nf_active; nf_out.
unfold lift; apply lift_rec_preserves_normal; auto.
nf_out. cbv; auto.
apply nf_active. nf_out.
repeat (apply nf_active; nf_out).
unfold lift; apply lift_rec_preserves_normal; auto.
nf_out. cbv; auto.
  (* 1 *)
  unfold case; fold case; unfold case_app_nf.
assert(is_program (App P1 P2) = true \/ is_program (App P1 P2) <> true) by decide equality.
inversion H0. rewrite H1.
(* 2 *)
rewrite star_opt_occurs_true. 2: cbv; auto. 2: unfold swap; discriminate.
rewrite star_opt_occurs_true. 2: cbv; auto. 2: unfold swap; discriminate.
rewrite star_opt_occurs_true. 2: cbv; auto. 2: unfold swap; discriminate.
rewrite star_opt_eta.
nf_out.
unfold subst; rewrite subst_rec_closed. eapply2 equal_comb_normal.
rewrite equal_comb_closed; omega.
assert(program (App P1 P2)) by eapply2 program_is_program. inversion H2; auto.
unfold lift; apply lift_rec_preserves_normal. auto.
unfold swap; unfold_op; nf_out.
eapply2 occurs_closed.
(* 1 *)
assert(is_program (App P1 P2) = false).
eapply2 not_true_iff_false.
rewrite H2.
(* 1 *)
  unfold case_app_nf, swap. unfold_op; nf_out.
inversion H; eapply2 IHP1;  eapply2 IHP2.
eapply2 nf_compound. eapply2 nf_compound.
Qed.

*)
 (*
Lemma case_pattern_normal:
forall (P M : Tree) j, pattern_normal j M ->
pattern_normal (j - (pattern_size P)) (case P M).
Proof.
  induction P; intros.
  (* 3 *)
  unfold pattern_size. unfold case.
replace (j-1) with (pred j) by omega.
eapply pattern_normal_star_opt; auto.
unfold_op. eapply2 pnf_compound. eapply2 pnf_normal.
(* 2 *)
unfold pattern_size, case; simpl. replace (j-0) with j by omega.
case o.
(* 3 *)
eapply2 pnf_compound. eapply2 pnf_compound. eapply2 pnf_normal.
eapply2 pnf_compound. eapply2 pnf_compound. eapply2 pnf_normal.
unfold subst, subst_rec; eapply2 pnf_normal.
eapply2 pnf_compound. eapply2 pnf_compound. eapply2 pnf_normal.
eapply2 pnf_compound. eapply2 pnf_compound. eapply2 pnf_normal.
eapply2 pnf_compound. eapply2 pnf_compound. eapply2 pnf_normal.
eapply2 pnf_compound. eapply2 pnf_compound. eapply2 pnf_normal.
eapply2 pnf_compound. eapply2 pnf_compound. eapply2 pnf_normal.
eapply2 pnf_normal. nf_out.
unfold subst, subst_rec; eapply2 pnf_normal. unfold_op. nf_out.
unfold_op; eapply2 pnf_compound. eapply2 pnf_normal.
unfold subst, subst_rec; eapply2 pnf_normal.
unfold_op; eapply2 pnf_compound. eapply2 pnf_normal.
unfold subst, subst_rec; eapply2 pnf_normal.
2:unfold_op; eapply2 pnf_compound.
2: eapply2 pnf_normal. 2: nf_out.
2: unfold subst, subst_rec; nf_out.
2:unfold subst, subst_rec; eapply2 pnf_normal.
2: unfold_op; eapply2 pnf_compound.
2: unfold subst, subst_rec; eapply2 pnf_normal.
2: unfold subst, subst_rec; eapply2 pnf_normal.
2: nf_out.
(* 3 *)
unfold lift. rewrite ! occurs_lift_rec_zero. gen_case H M. gen_case H n. relocate_lt.
unfold_op. eapply2 pnf_compound.  eapply2 pnf_normal.
eapply2 pnf_normal. unfold subst; nf_out.  insert_Ref_out; auto.
relocate_lt. eapply2 pnf_normal. unfold subst; nf_out.  insert_Ref_out; auto.
eapply2 pnf_normal. unfold subst; nf_out.
unfold_op; eapply2 pnf_compound. eapply2 pnf_normal.
unfold subst, subst_rec; fold subst_rec.
rewrite ! subst_rec_lift_rec; try omega.  rewrite ! lift_rec_null.
eapply2 pnf_compound. eapply2 pnf_normal.
(* 2 *)
unfold subst, subst_rec; fold subst_rec.
eapply2 pnf_compound. eapply2 pnf_compound. eapply2 pnf_normal.
eapply2 pnf_compound. eapply2 pnf_normal.
eapply2 pnf_compound. eapply2 pnf_compound. eapply2 pnf_normal.
eapply2 pnf_compound. eapply2 pnf_compound. eapply2 pnf_normal.
eapply2 pnf_compound. eapply2 pnf_compound. eapply2 pnf_normal.
eapply2 pnf_compound. eapply2 pnf_normal. unfold_op; unfold subst_rec; nf_out.
eapply2 pnf_normal. unfold_op; unfold subst_rec; nf_out.
eapply2 pnf_normal. unfold_op; unfold subst_rec; nf_out.
eapply2 pnf_normal. unfold_op; unfold subst_rec; nf_out.
2: eapply2 pnf_normal; unfold_op; unfold subst_rec; nf_out.
(* 2 *)
unfold lift. gen_case H M; unfold lift_rec; fold lift_rec.
gen_case H n. relocate_lt. unfold plus. insert_Ref_out.
eapply2 pnf_normal; nf_out.
eapply2 pnf_normal; nf_out.
relocate_lt. unfold plus. insert_Ref_out. nf_out.
eapply2 pnf_normal; nf_out.
(* 2 *)
rewrite ! occurs_lift_rec_zero. simpl.
rewrite ! subst_rec_lift_rec; try omega. rewrite ! lift_rec_null.
unfold_op; eapply2 pnf_compound. eapply2 pnf_normal.  eapply2 pnf_compound.
eapply2 pnf_normal.
(* 1 *)
unfold pattern_size; fold pattern_size.
unfold case; fold case.
assert(is_program (App P1 P2) = true \/ is_program (App P1 P2) <> true) by decide equality.
inversion H0. rewrite H1.
(* 2 *)
rewrite star_opt_occurs_true. 2: cbv; auto. 2: unfold swap; discriminate.
rewrite star_opt_occurs_true. 2: cbv; auto. 2: unfold swap; discriminate.
rewrite star_opt_occurs_true. 2: cbv; auto. 2: unfold swap; discriminate.
rewrite star_opt_eta.
eapply2 pnf_compound. eapply2 pnf_compound. eapply2 pnf_normal.
eapply2 pnf_compound. eapply2 pnf_compound. eapply2 pnf_normal.
eapply2 pnf_compound. eapply2 pnf_compound. eapply2 pnf_normal.
eapply2 pnf_normal. unfold subst; rewrite subst_rec_closed.
eapply2 equal_comb_normal. rewrite equal_comb_closed; omega.
eapply2 pnf_normal. eapply2 star_opt_normal.
assert(program (App P1 P2)) by eapply2 program_is_program.
inversion H2; auto.
unfold_op. rewrite star_opt_occurs_false.
unfold lift, subst_rec; fold subst_rec.
rewrite subst_rec_lift_rec; try omega. rewrite lift_rec_null.
eapply2 pnf_compound.
unfold_op; eapply2 pnf_normal.
eapply2 pnf_compound. eapply2 pnf_normal.
rewrite ! pattern_size_closed.
replace (j-(0+0)) with j by omega. auto.
assert(program (App P1 P2)) by eapply2 program_is_program.
inversion H2.  simpl in H4; max_out.
assert(program (App P1 P2)) by eapply2 program_is_program.
inversion H2.  simpl in H4; max_out.
unfold_op; auto.
unfold occurs; fold occurs 0.
unfold lift; rewrite occurs_lift_rec_zero.  auto.
eapply2 pnf_normal. unfold swap; unfold_op; nf_out.
eapply2 occurs_closed.
(* 1 *)
assert(is_program (App P1 P2) = false).
eapply2 not_true_iff_false.
rewrite H2.
(* 1 *)
  unfold case_app_nf, swap. unfold_op; nf_out.
eapply2 pnf_compound. eapply2 pnf_compound. eapply2 pnf_normal.
eapply2 pnf_compound. eapply2 pnf_normal.  nf_out.
eapply2 pnf_compound. eapply2 pnf_normal.
eapply2 pnf_compound. eapply2 pnf_compound. eapply2 pnf_normal.
eapply2 pnf_compound. eapply2 pnf_normal.
eapply2 pnf_compound. eapply2 pnf_compound. eapply2 pnf_normal.
2: eapply2 pnf_normal. 2: nf_out.
2: eapply2 pnf_normal. 2: nf_out.
2: unfold_op; auto. 2: eapply2 pnf_normal.  2: nf_out.
(* 1 *)
replace (j - (pattern_size P1 + pattern_size P2)) with (j - pattern_size P2 - pattern_size P1)
by omega.
eapply2 IHP1. eapply2 IHP2.
unfold_op;  eapply2 pnf_compound. eapply2 pnf_normal.
eapply2 pnf_compound. eapply2 pnf_normal.
Qed.

 *)

(* matching *)

Inductive matching : Tree -> Tree -> list Tree -> 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,
               (compound (App p1 p2) \/ status (App p1 p2) = Active) -> 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.
(* 2 *)
replace (lift k (App M1 M2)) with (App (lift k M1) (lift k M2)) by (unfold lift; auto).
replace(fix map (l : list Tree) : list Tree :=
            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 Tree) : list Tree :=
         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 max_pred: forall m n, pred (max m n) = max (pred m) (pred n).
Proof. double induction m n; intros; auto. case n; intros; 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 Tree)
  with (List.map (lift (length (nil: list Tree))) (nil: list Tree) ++ (nil: list Tree))
    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 program_matching2: forall M sigma, matching M M sigma -> maxvar M = 0 -> program M.
Proof.
  induction M; split_all. noway. unfold program; auto.
  inversion H; split_all; subst. unfold program; split; auto.  eapply2 nf_compound.
  eapply2 IHM1. max_out.  eapply2 IHM2. max_out.
Qed.

Lemma pattern_is_closed:
forall P, maxvar P = 0 -> forall M sigma, matching P M sigma -> M = P /\ sigma = nil.
Proof.
induction P; intros; inversion H; subst.
(* 2 *)
inversion H0; auto.
(* 1 *)
inversion H0; subst; simpl in *; max_out.
assert(M1 = P1 /\ sigma1 = nil). eapply2 IHP1 .
assert(M2 = P2 /\ sigma2 = nil). eapply2 IHP2 .
split_all; subst. inversion H2; inversion H7; subst; split; auto.
Qed.

Lemma maxvar_case_app :
forall P1 P2,
(forall M : Tree, maxvar (case P1 M) = maxvar M - pattern_size P1) ->
(forall M : Tree, maxvar (case P2 M) = maxvar M - pattern_size P2) ->
forall M, maxvar (case_app case P1 P2 M) = maxvar M - pattern_size (App P1 P2).
Proof.
intros. unfold case_app.
rewrite maxvar_star_opt.
unfold_op. unfold maxvar; fold maxvar.  unfold max; fold max.
unfold lift; rewrite ! lift_rec_preserves_star_opt.
unfold lift_rec; fold lift_rec.
rewrite lift_rec_lift_rec; try omega.
rewrite ! maxvar_star_opt.
relocate_lt.
rewrite ! lift_rec_preserves_case.
unfold lift_rec; fold lift_rec.
unfold maxvar; fold maxvar.
unfold max; fold max.
rewrite H; rewrite H0.
unfold maxvar; fold maxvar.
unfold max; fold max.
rewrite ! max_pred.
rewrite Fop_closed.  simpl. rewrite ! max_zero.
replace (pattern_size P2 + (pattern_size P1 + 0))
with (pattern_size P1 + pattern_size P2) by omega.
replace (maxvar (lift_rec M (pattern_size P1 + pattern_size P2) 3) -
             pattern_size P2 - pattern_size P1)
with (maxvar (lift_rec M (pattern_size P1 + pattern_size P2) 3) -
             (pattern_size P1 + pattern_size P2)) by omega.
clear. induction M; split_all.
case (pattern_size P1 + pattern_size P2); split_all.
(* 3 *)
unfold relocate. elim(test 0 n); split_all.  noway.
(* 2 *)
unfold relocate. elim(test (S n0) n); split_all.
gen_case a n0; try omega.
gen_case a n1; try omega.
gen_case a n2; try omega.
omega.
(* 1 *)
rewrite max_minus.
rewrite ! max_pred.
rewrite IHM1.  rewrite IHM2.
rewrite max_minus. auto.
Qed.

Lemma maxvar_lift: forall M k, pred (maxvar (lift (S k) M)) = maxvar (lift k M).
Proof.
induction M; split_all. relocate_lt. omega.
rewrite max_pred. unfold lift in *. auto.
Qed.

Lemma maxvar_case : forall P M, maxvar (case P M) = maxvar M - (pattern_size P).
Proof.
  induction P; intros; unfold case; fold case; unfold maxvar; fold maxvar.
  (* 3 *)
  rewrite maxvar_star_opt. split_all. omega.
  (* 2 *)
case o; unfold_op; unfold pattern_size.
  rewrite maxvar_star_opt. simpl.
replace (maxvar M - 0) with (maxvar M) by omega.
rewrite max_pred. simpl.
rewrite max_zero.
assert(pred (maxvar (lift 1 M)) = maxvar (lift 0 M)) by eapply2 maxvar_lift.
gen_case H (maxvar (lift 1 M)).
unfold lift in H; rewrite lift_rec_null in H; auto.
unfold lift in H; rewrite lift_rec_null in H; auto.
(* 1 *)
assert(is_program (App P1 P2) = true \/ is_program(App P1 P2) <> true)
by decide equality.
inversion H.
rewrite H0.
rewrite maxvar_star_opt.
rewrite ! maxvar_app.
rewrite equal_comb_closed. simpl.
assert(program (App P1 P2)) by eapply2 program_is_program.
inversion H1. simpl in H3. max_out. rewrite H4. rewrite H5. simpl.
rewrite max_pred.
assert(pred (maxvar (lift 1 M)) = maxvar (lift 0 M)) by eapply2 maxvar_lift.
replace (lift 0 M) with M in H3 by (unfold lift; rewrite lift_rec_null; auto).
(* 2 *)
gen_case H3 (maxvar (lift 1 M)).
rewrite <- H3.
omega.
rewrite ! H3. rewrite max_zero.
rewrite ! pattern_size_closed; auto.
omega.
(* 1 *)
assert(is_program (App P1 P2) = false) by
eapply2 not_true_iff_false.
rewrite H1.
(* 1 *)
unfold case_app.
rewrite maxvar_star_opt.
rewrite ! maxvar_app.
rewrite ! maxvar_ref.
rewrite Fop_closed.
replace (maxvar i_op) with 0 by (cbv; auto).
rewrite ! max_pred.
rewrite maxvar_lift.
unfold lift at 1; rewrite ! lift_rec_null.
rewrite ! maxvar_star_opt.
rewrite ! maxvar_app.
rewrite ! max_pred.
rewrite maxvar_lift.
simpl. rewrite ! maxvar_lift.
unfold lift; rewrite ! lift_rec_null.
rewrite ! max_zero.
rewrite IHP1. rewrite IHP2.
unfold_op; simpl. omega.
Qed.

Lemma program_matching3:
forall P M sigma, matching P M sigma -> maxvar P = 0 -> M = P /\ sigma = nil.
Proof.
  induction P; split_all. noway.
  inversion H; split_all; subst.
  inversion H; split_all; subst.
  simpl in H0; max_out.
  assert(M1 = P1 /\ sigma1 = nil) by eapply2 IHP1.
  assert(M2 = P2 /\ sigma2 = nil) by eapply2 IHP2.
  inversion H0; inversion H6; subst; split; cbv; auto.
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 *)
  inversion H; subst. unfold fold_left.  unfold case; unfold_op.  eapply2 star_opt_beta.
  (* 2 *)
  inversion H; subst. unfold fold_left.  unfold case; unfold_op. case o.
  eapply transitive_red. eapply2 star_opt_beta.
  unfold subst; rewrite ! subst_rec_app.
rewrite subst_rec_closed. 2: rewrite Fop_closed; omega.
unfold subst_rec; fold subst_rec. insert_Ref_out. unfold lift, lift_rec; fold lift_rec.
rewrite subst_rec_lift_rec; try omega. rewrite lift_rec_null.
eapply transitive_red. eapply2 factor_leaf.
  eval_tac.   (* 1 *)
  unfold case; fold case.
assert(is_program (App P1 P2) = true \/ is_program(App P1 P2) <> true)
by decide equality.
inversion H0.
rewrite H1.
eapply transitive_red.
eapply2 star_opt_beta.
unfold subst; rewrite ! subst_rec_app.
rewrite subst_rec_closed. 2: rewrite equal_comb_closed; omega.
unfold lift; rewrite subst_rec_lift_rec; try omega.
unfold subst_rec; fold subst_rec.
insert_Ref_out. unfold lift; rewrite ! lift_rec_null.
unfold swap; unfold_op. unfold subst, subst_rec; fold subst_rec. insert_Ref_out.
unfold lift; rewrite ! lift_rec_null.
assert(program (App P1 P2)) by eapply2 program_is_program.
inversion H2; subst. simpl in H4; max_out.
rewrite ! subst_rec_closed; try omega.
assert(N = App P1 P2 /\ sigma = nil).
eapply2 program_matching3. simpl; auto. rewrite H5; rewrite H6; auto.
inversion H4; subst.
eapply transitive_red. eapply preserves_app_sf_red.
eapply preserves_app_sf_red.
eapply2 equal_programs. auto. auto.
unfold_op; eval_tac.
(* 1 *)
assert(is_program (App P1 P2) = false) by
eapply2 not_true_iff_false.
rewrite H2.
(* 1 *)
  unfold case_app.
eapply transitive_red. eapply2 star_opt_beta.
unfold subst; rewrite ! subst_rec_app.
rewrite subst_rec_closed. 2: simpl; auto.
unfold subst_rec; fold subst_rec. insert_Ref_out. unfold lift; rewrite lift_rec_null.
rewrite subst_rec_lift_rec; try omega.
rewrite subst_rec_closed. 2: simpl; auto.
inversion H; subst. inversion H6; subst.
(* 2 *)
eapply transitive_red. eapply preserves_app_sf_red. eapply2 factor_stem.
unfold swap; simpl. insert_Ref_out. unfold lift; rewrite lift_rec_null. auto.
rewrite ! lift_rec_preserves_star_opt.
  eapply transitive_red. eapply preserves_app_sf_red. eapply2 star_opt_beta2. auto.
unfold subst; simpl. insert_Ref_out.
unfold lift; rewrite ! lift_rec_null.
rewrite ! subst_rec_lift_rec; try omega.
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. all: auto.
eapply transitive_red. eapply preserves_app_sf_red.
  eapply preserves_app_sf_red. eapply preserves_app_sf_red.
   eapply succ_red. eapply2 k_red. all: auto.
rewrite fold_subst_list. rewrite fold_subst_list. rewrite fold_subst_list.
eapply transitive_red. eapply list_subst_preserves_sf_red.
eapply preserves_app_sf_red. eapply preserves_app_sf_red.
eapply IHP2. eapply2 matching_lift.
unfold lift; simpl. auto. unfold lift; simpl. auto.
eapply transitive_red. eapply list_subst_preserves_sf_red.
unfold_op.  eapply transitive_red. eapply preserves_app_sf_red.
eapply succ_red. eapply2 k_red.  auto. auto. auto.
repeat rewrite list_subst_preserves_app. repeat rewrite list_subst_preserves_op.
eval_tac.   repeat eapply2 preserves_app_sf_red.
rewrite fold_left_app. auto.
(* 1 *)
eapply transitive_red. eapply preserves_app_sf_red. eapply2 factor_fork.
unfold swap; simpl. insert_Ref_out. unfold lift; rewrite lift_rec_null. auto.
rewrite ! lift_rec_preserves_star_opt.
  eapply transitive_red. eapply preserves_app_sf_red. eapply2 star_opt_beta2. auto.
unfold subst; simpl. insert_Ref_out.
unfold lift; rewrite ! lift_rec_null.
rewrite ! subst_rec_lift_rec; try omega.
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. all: auto.
eapply transitive_red. eapply preserves_app_sf_red.
  eapply preserves_app_sf_red. eapply preserves_app_sf_red.
   eapply succ_red. eapply2 k_red. all: auto.
rewrite fold_subst_list. rewrite fold_subst_list. rewrite fold_subst_list.
eapply transitive_red. eapply list_subst_preserves_sf_red.
eapply preserves_app_sf_red. eapply preserves_app_sf_red.
eapply IHP2. eapply2 matching_lift.
unfold lift; simpl. auto. unfold lift; simpl. auto.
eapply transitive_red. eapply list_subst_preserves_sf_red.
unfold_op.  eapply transitive_red. eapply preserves_app_sf_red.
eapply succ_red. eapply2 k_red.  auto. auto. auto.
repeat rewrite list_subst_preserves_app. repeat rewrite list_subst_preserves_op.
eval_tac.   repeat eapply2 preserves_app_sf_red.
rewrite fold_left_app. auto.

Qed.

Lemma case_normal:
forall P M, normal P -> normal M -> normal (case P M).
Proof.
induction P; intros; unfold case.
(* 3 *)
eapply2 star_opt_normal. unfold_op; auto.
(* 2 *)
rewrite star_opt_occurs_true.
unfold_op; eapply2 nf_compound.
eapply2 nf_compound.
eapply2 nf_compound.
eapply2 star_opt_normal.
unfold swap.
unfold_op; repeat eapply2 nf_compound.
rewrite star_opt_occurs_true.
unfold_op; eapply2 nf_compound.
eapply2 nf_compound.
eapply2 nf_compound.
eapply2 star_opt_normal.
repeat eapply2 nf_compound.
unfold lift. eapply2 lift_rec_preserves_normal.
(* 6 *)
unfold star_opt.
rewrite occurs_closed.
unfold subst. rewrite subst_rec_closed.
eapply2 Fop_normal.
rewrite Fop_closed; auto.
eapply2 Fop_closed.
(* 5 *)
unfold occurs; fold occurs. unfold eqnat. omega. congruence.
(* 3 *)
unfold swap, occurs; fold occurs. unfold eqnat. omega. congruence.
(* 1 *)
case (is_program (App P1 P2)).
rewrite star_opt_occurs_true.
unfold star_opt at 1.  unfold occurs. unfold swap. unfold_op. unfold plus, eqnat.
subst_tac. eapply2 nf_compound. repeat eapply2 nf_compound.
(* 4 *)
2: unfold swap; unfold_op; rewrite ! occurs_app.
2: replace (occurs 0 (Ref 0)) with 1 by auto. 2:omega.
2: unfold swap; congruence.
(* 2 *)
rewrite star_opt_occurs_true.
all: cycle 1.
rewrite ! occurs_app. unfold occurs at 2. unfold eqnat.
omega. congruence.
fold case.
all: cycle -1.
(* 2 *)
eapply2 nf_compound. eapply2 nf_compound. eapply2 nf_compound.
eapply2 star_opt_normal.
eapply2 nf_compound.
unfold lift; eapply2 lift_rec_preserves_normal.
rewrite star_opt_occurs_true.
2: rewrite ! occurs_app. 2: unfold occurs at 2; unfold eqnat; omega.
2: congruence.
apply nf_compound.
apply nf_compound. auto.
apply nf_compound.  auto.
eapply2 star_opt_normal.
auto. auto. 2: auto.
unfold star_opt, occurs. fold star_opt.
rewrite occurs_closed.  2: apply equal_comb_closed.
unfold subst; rewrite subst_rec_closed.
apply equal_comb_normal.
rewrite equal_comb_closed. auto.
(* 1 *)
unfold case_app.
rewrite star_opt_occurs_true.
2: unfold swap, occurs; unfold_op; unfold eqnat; omega.
2: unfold swap; congruence.
eapply2 nf_compound.
eapply2 nf_compound.
eapply2 nf_compound.
cbv; auto. repeat eapply2 nf_compound.
rewrite star_opt_occurs_true.
2: unfold occurs; unfold_op; unfold eqnat; omega.
2: case(star_opt
      (star_opt
         (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))));
  unfold lift, lift_rec; try congruence.
2: intro; case n; relocate_lt; simpl. 2: congruence.
2: intro; relocate_lt; simpl. 2: congruence.
(* 1 *)
eapply2 nf_compound.
eapply2 nf_compound.
eapply2 nf_compound.
all: cycle 1.
rewrite star_opt_occurs_true.
2: unfold swap, occurs; unfold_op; unfold eqnat; omega.
2: unfold_op; congruence.
eapply2 nf_compound.
rewrite star_opt_closed; repeat eapply2 nf_compound. all: unfold node; auto.
unfold_op; auto. rewrite star_opt_eta.
2: apply occurs_closed. 2: apply Fop_closed.
unfold subst; rewrite subst_rec_closed. apply Fop_normal. rewrite Fop_closed; auto.
(* 1 *)
rewrite star_opt_occurs_true.
2: unfold occurs; fold occurs. 2: unfold eqnat; omega. 2: discriminate.
rewrite (star_opt_closed (App k_op i_op)).
2: unfold_op; auto.
apply star_opt_normal.
unfold lift. apply lift_rec_preserves_normal.
unfold star_opt at 2. fold star_opt. unfold_op.
replace (occurs 0
        (App
           (App
              (lift_rec
                 (case P1
                    (case P2 (App (App (Op Node) (Op Node)) (App (App (Op Node) (Op Node)) M))))
                 0 2) (Ref 1))
           (App (App (Op Node) (Op Node))
              (App (App (Op Node) (Op Node))
                 (App (App (Op Node) (Op Node))
                    (App (App (Op Node) (App (Op Node) (Op Node))) (App (Op Node) (Op Node)))))))
        ) with 0.
all: cycle 1.
rewrite ! occurs_app.
rewrite ! occurs_op.
rewrite occurs_lift_rec_zero.
cbv; auto.
(* 1 *)
subst_tac.
rewrite star_opt_occurs_true.
2: unfold occurs, eqnat; omega.
2: discriminate.
(* 1 *)
eapply2 nf_compound. eapply2 nf_compound. eapply2 nf_compound.
2: apply star_opt_normal. 2: repeat eapply2 nf_compound.
rewrite star_opt_occurs_true.
2: unfold occurs, eqnat; omega.
2: discriminate.
(* 1 *)
repeat eapply2 nf_compound.
all: unfold node; auto.
unfold_op; auto.
rewrite star_opt_eta.
2: rewrite occurs_lift_rec_zero; auto.
subst_tac.
inversion H.
apply IHP1; auto. apply IHP1; auto.
Qed.