Set Implicit Arguments.

Require Import RelationClasses.

From sflib Require Import sflib.

From PromisingLib Require Import Basic.
From PromisingLib Require Import Loc.
From PromisingLib Require Import Language.
From PromisingLib Require Import Axioms.

From PromisingLib Require Import Event.

Require Import FoldN.
Require Import Knowledge.
Require Import Opt4.

Require Import ITreeLang.

Require Import WRforwarding.

Global Program Instance le_PreOrder: PreOrder le.
Next Obligation.
Proof.
  eapply PreOrder_Reflexive. Unshelve.
  set (ML:= MLattice.mk_mlattice
              eq_Equiv eq_leibniz
              meet meet_comm meet_assoc meet_idem
              le le_spec).
  apply (@MLattice.le_PreOrder ML).
Qed.
Next Obligation.
Proof.
  eapply PreOrder_Transitive. Unshelve.
  set (ML:= MLattice.mk_mlattice
              eq_Equiv eq_leibniz
              meet meet_comm meet_assoc meet_idem
              le le_spec).
  apply (@MLattice.le_PreOrder ML).
Qed.

Global Program Instance le_PartialOrder: PartialOrder eq le.
Next Obligation.
Proof.
  unfold relation_equivalence, relation_conjunction.
  unfold predicate_equivalence, predicate_intersection.
  unfold pointwise_lifting, pointwise_extension.
  i. split; i.
  - clarify. split; refl.
  - des. unfold flip in H0. eapply antisymmetry; eauto.
    Unshelve. auto. eapply partial_order_antisym.
    set (ML:= MLattice.mk_mlattice
                eq_Equiv eq_leibniz
                meet meet_comm meet_assoc meet_idem
                le le_spec).
    eapply (@MLattice.le_PartialOrder ML).
Qed.

Section ALGAUX.

  Lemma ord_inv1:
    forall o, (Ordering.le o Ordering.na) \/
         (Ordering.le Ordering.plain o && Ordering.le o Ordering.strong_relaxed)%bool \/
         (Ordering.le Ordering.acqrel o).
  Proof. i. destruct o; auto. Qed.

  Lemma WRfwd_read_ord1:
    forall ul o l t
      (ORD: Ordering.le o Ordering.na),
      WRfwd_read ul o l t = t.
  Proof. i. unfold WRfwd_read. des_ifs. Qed.

  Lemma WRfwd_read_ord1f:
    forall ul o mp
      (ORD: Ordering.le o Ordering.na),
      (fun p0: Loc.t => WRfwd_read ul o p0 (mp p0)) = fun p0 => mp p0.
  Proof. i. extensionality p0. apply WRfwd_read_ord1; auto. Qed.

  Lemma WRfwd_read_ord2:
    forall ul o l t
      (ORD: (Ordering.le Ordering.plain o && Ordering.le o Ordering.strong_relaxed)%bool),
      WRfwd_read ul o l t = (if (Loc.eqb ul l) then None else t).
  Proof. i. destruct o; ss; clarify. Qed.

  Lemma WRfwd_read_ord2f:
    forall ul o mp
      (ORD: (Ordering.le Ordering.plain o && Ordering.le o Ordering.strong_relaxed)%bool),
      (fun p0: Loc.t => WRfwd_read ul o p0 (mp p0)) = fun p0 => (if (Loc.eqb ul p0) then None else (mp p0)).
  Proof. i. extensionality p0. apply WRfwd_read_ord2; auto. Qed.

  Lemma WRfwd_read_ord3:
    forall ul o l t
      (ORD: Ordering.le Ordering.acqrel o),
      WRfwd_read ul o l t = (if (Loc.eqb ul l) then None else (Two_elim t)).
  Proof. i. destruct o; ss; clarify. Qed.

  Lemma WRfwd_read_ord3f:
    forall ul o mp
      (ORD: Ordering.le Ordering.acqrel o),
      (fun p0: Loc.t => WRfwd_read ul o p0 (mp p0)) = fun p0 => (if (Loc.eqb ul p0) then None else (Two_elim (mp p0))).
  Proof. i. extensionality p0. apply WRfwd_read_ord3; auto. Qed.

  Lemma ord_inv2:
    forall o, (Ordering.le o Ordering.na) \/
         (Ordering.le Ordering.plain o).
  Proof. i. destruct o; auto. Qed.

  Lemma WRfwd_write_ord1:
    forall ul o l t
      (ORD: Ordering.le o Ordering.na),
      WRfwd_write ul o l t = (if (Loc.eqb ul l) then None else t).
  Proof. i. unfold WRfwd_write. des_ifs. Qed.

  Lemma WRfwd_write_ord1f:
    forall ul o mp
      (ORD: Ordering.le o Ordering.na),
      (fun p0: Loc.t => WRfwd_write ul o p0 (mp p0)) = fun p0 => (if (Loc.eqb ul p0) then None else (mp p0)).
  Proof. i. extensionality p0. apply WRfwd_write_ord1; auto. Qed.

  Lemma WRfwd_write_ord2:
    forall ul o l t
      (ORD: Ordering.le Ordering.plain o),
      WRfwd_write ul o l t = (if (Loc.eqb ul l) then None else (Two_set_flag t)).
  Proof. i. unfold WRfwd_write. destruct o; ss; clarify. Qed.

  Lemma WRfwd_write_ord2f:
    forall ul o mp
      (ORD: Ordering.le Ordering.plain o),
      (fun p0: Loc.t => WRfwd_write ul o p0 (mp p0)) = fun p0 => (if (Loc.eqb ul p0) then None else (Two_set_flag (mp p0))).
  Proof. i. extensionality p0. apply WRfwd_write_ord2; auto. Qed.

  Lemma ord_inv2':
    forall o, (Ordering.le o Ordering.na) \/
         (Ordering.le Ordering.plain o).
  Proof. i. destruct o; auto. Qed.

  Lemma WRfwd_store_ord1:
    forall ul e o l t
      (ORD: Ordering.le o Ordering.na),
      WRfwd_store ul e o l t =
      (if (Loc.eqb ul l)
       then (match e with
             | Inst.expr_val c => Two_new c
             | _ => None
             end)
       else t).
  Proof. i. unfold WRfwd_store. des_ifs. Qed.

  Lemma WRfwd_store_ord1f:
    forall ul e o mp
      (ORD: Ordering.le o Ordering.na),
      (fun p0: Loc.t => WRfwd_store ul e o p0 (mp p0)) =
      fun p0 => (if (Loc.eqb ul p0)
              then (match e with
                    | Inst.expr_val c => Two_new c
                    | _ => None
                    end)
              else (mp p0)).
  Proof. i. extensionality p0. apply WRfwd_store_ord1; auto. Qed.

  Lemma WRfwd_store_ord2:
    forall ul e o l t
      (ORD: Ordering.le Ordering.plain o),
      WRfwd_store ul e o l t = WRfwd_write ul o l t.
  Proof. i. destruct o; ss; clarify. Qed.

  Lemma WRfwd_store_ord2f:
    forall ul e o mp
      (ORD: Ordering.le Ordering.plain o),
      (fun p0: Loc.t => WRfwd_store ul e o p0 (mp p0)) = fun p0 => WRfwd_write ul o p0 (mp p0).
  Proof. i. extensionality p0. apply WRfwd_store_ord2; auto. Qed.

  Lemma ord_inv3:
    forall o, (Ordering.le o Ordering.strong_relaxed) \/ (Ordering.le Ordering.acqrel o).
  Proof. i. destruct o; auto. Qed.

  Lemma WRfwd_fence_r_ord1:
    forall o l t
      (ORD: Ordering.le o Ordering.strong_relaxed),
      WRfwd_fence_r o l t = t.
  Proof. i. destruct o; ss; clarify. Qed.

  Lemma WRfwd_fence_r_ord1f:
    forall o mp
      (ORD: Ordering.le o Ordering.strong_relaxed),
      (fun p0: Loc.t => WRfwd_fence_r o p0 (mp p0)) = fun p0 => mp p0.
  Proof. i. extensionality p0. apply WRfwd_fence_r_ord1; auto. Qed.

  Lemma WRfwd_fence_r_ord2:
    forall o l t
      (ORD: (Ordering.le Ordering.acqrel o)),
      WRfwd_fence_r o l t = (Two_elim t).
  Proof. i. destruct o; ss; clarify. Qed.

  Lemma WRfwd_fence_r_ord2f:
    forall o mp
      (ORD: (Ordering.le Ordering.acqrel o)),
      (fun p0: Loc.t => WRfwd_fence_r o p0 (mp p0)) = fun p0 => (Two_elim (mp p0)).
  Proof. i. extensionality p0. apply WRfwd_fence_r_ord2; auto. Qed.

  Lemma ord_inv4:
    forall o, (Ordering.le o Ordering.na) \/
         (Ordering.le Ordering.plain o && Ordering.le o Ordering.acqrel)%bool \/
         (Ordering.le Ordering.seqcst o).
  Proof. i. destruct o; auto. Qed.

  Lemma WRfwd_fence_w_ord1:
    forall o l t
      (ORD: Ordering.le o Ordering.na),
      WRfwd_fence_w o l t = t.
  Proof. i. destruct o; ss; clarify. Qed.

  Lemma WRfwd_fence_w_ord1f:
    forall o mp
      (ORD: Ordering.le o Ordering.na),
      (fun p0: Loc.t => WRfwd_fence_w o p0 (mp p0)) = fun p0 => mp p0.
  Proof. i. extensionality p0. apply WRfwd_fence_w_ord1; auto. Qed.

  Lemma WRfwd_fence_w_ord2:
    forall o l t
      (ORD: (Ordering.le Ordering.plain o && Ordering.le o Ordering.acqrel)%bool),
      WRfwd_fence_w o l t = (Two_set_flag t).
  Proof. i. destruct o; ss; clarify. Qed.

  Lemma WRfwd_fence_w_ord2f:
    forall o mp
      (ORD: (Ordering.le Ordering.plain o && Ordering.le o Ordering.acqrel)%bool),
      (fun p0: Loc.t => WRfwd_fence_w o p0 (mp p0)) = fun p0 => (Two_set_flag (mp p0)).
  Proof. i. extensionality p0. apply WRfwd_fence_w_ord2; auto. Qed.

  Lemma WRfwd_fence_w_ord3:
    forall o l t
      (ORD: Ordering.le Ordering.seqcst o),
      WRfwd_fence_w o l t = Two_set_flag (Two_elim t).
  Proof. i. destruct o; ss; clarify. Qed.

  Lemma WRfwd_fence_w_ord3f:
    forall o mp
      (ORD: Ordering.le Ordering.seqcst o),
      (fun p0: Loc.t => WRfwd_fence_w o p0 (mp p0)) = fun p0 => Two_set_flag (Two_elim (mp p0)).
  Proof. i. extensionality p0. apply WRfwd_fence_w_ord3; auto. Qed.

  Lemma Two_elim_mon:
    forall k1 k2 (LE: le k1 k2), le (Two_elim k1) (Two_elim k2).
  Proof.
    i. unfold Two_elim. des_ifs; ss; clarify. des; clarify.
  Qed.

  Lemma Two_elim_le:
    forall k, le (Two_elim k) k.
  Proof.
    i. unfold Two_elim. des_ifs; ss; clarify. des; auto.
  Qed.

  Lemma Two_set_flag_mon:
    forall k1 k2 (LE: le k1 k2), le (Two_set_flag k1) (Two_set_flag k2).
  Proof.
    i. unfold Two_set_flag. des_ifs; ss; clarify. des; clarify; auto.
  Qed.

  Lemma Two_set_flag_le:
    forall k, le (Two_set_flag k) k.
  Proof.
    i. unfold Two_set_flag. des_ifs; ss; clarify. auto.
  Qed.

  Lemma WRfwd_read_kspec:
    forall l1 l2 o, knowledge_spec le bot (WRfwd_read l1 o l2).
  Proof.
    i. unfold knowledge_spec. split; red; i.
    - unfold WRfwd_read. unfold distl. des_ifs; ss; clarify.
      apply Two_elim_mon; auto.
    - unfold WRfwd_read. unfold distl. des_ifs; ss; clarify; auto.
      all: try (left; refl).
      left; apply Two_elim_le.
  Qed.

  Lemma WRfwd_write_kspec:
    forall l1 l2 o, knowledge_spec le bot (WRfwd_write l1 o l2).
  Proof.
    i. hexploit (ord_inv2 o). i. des.
    - unfold knowledge_spec. split; red; i.
      + rewrite ! WRfwd_write_ord1; auto. des_ifs.
      + rewrite ! WRfwd_write_ord1; auto. des_ifs. right; refl. left; refl.
    - unfold knowledge_spec. split; red; i.
      + rewrite ! WRfwd_write_ord2; auto. des_ifs. apply Two_set_flag_mon; auto.
      + rewrite ! WRfwd_write_ord2; auto. des_ifs. right; refl. left; apply Two_set_flag_le.
  Qed.

  Lemma WRfwd_store_kspec:
    forall l1 l2 o e, knowledge_spec le bot (WRfwd_store l1 e o l2).
  Proof.
    i. hexploit (ord_inv1 o). i; des.
    - unfold knowledge_spec. split; red; i.
      + rewrite ! WRfwd_store_ord1; auto. des_ifs. refl.
      + rewrite ! WRfwd_store_ord1; auto. des_ifs.
        all: try (right; refl). left; refl.
    - replace (WRfwd_store l1 e o l2) with (WRfwd_write l1 o l2).
      2:{ extensionality s. rewrite WRfwd_store_ord2; auto. destruct o; ss. }
      apply WRfwd_write_kspec.
    - replace (WRfwd_store l1 e o l2) with (WRfwd_write l1 o l2).
      2:{ extensionality s. rewrite WRfwd_store_ord2; auto. destruct o; ss. }
      apply WRfwd_write_kspec.
  Qed.

  Lemma WRfwd_fence_r_kspec:
    forall l o, knowledge_spec le bot (WRfwd_fence_r o l).
  Proof.
    i. hexploit (ord_inv3 o). i; des.
    - unfold knowledge_spec. split; red; i.
      + rewrite ! WRfwd_fence_r_ord1; auto.
      + rewrite ! WRfwd_fence_r_ord1; auto. left; refl.
    - unfold knowledge_spec. split; red; i.
      + rewrite ! WRfwd_fence_r_ord2; auto. apply Two_elim_mon; auto.
      + rewrite ! WRfwd_fence_r_ord2; auto. left; apply Two_elim_le.
  Qed.

  Lemma WRfwd_fence_w_kspec:
    forall l o, knowledge_spec le bot (WRfwd_fence_w o l).
  Proof.
    i. hexploit (ord_inv4 o). i; des.
    - unfold knowledge_spec. split; red; i.
      + rewrite ! WRfwd_fence_w_ord1; auto.
      + rewrite ! WRfwd_fence_w_ord1; auto. left; refl.
    - unfold knowledge_spec. split; red; i.
      + rewrite ! WRfwd_fence_w_ord2; auto. apply Two_set_flag_mon; auto.
      + rewrite ! WRfwd_fence_w_ord2; auto. left; apply Two_set_flag_le.
    - unfold knowledge_spec. split; red; i.
      + rewrite ! WRfwd_fence_w_ord3; auto. apply Two_set_flag_mon. apply Two_elim_mon; auto.
      + rewrite ! WRfwd_fence_w_ord3; auto. left. etrans. 2:apply Two_elim_le. apply Two_set_flag_le; auto.
  Qed.

  Lemma WRfwd_kspec:
    forall (i: Inst.t) (l: Loc.t), knowledge_spec le bot (WRfwd_inst i l).
  Proof.
    i. destruct i.
    1,2,7,8,9: unfold knowledge_spec; split; red; i; ss; clarify; auto.
    all: try (left; refl).
    all: unfold WRfwd_inst; ss.
    apply WRfwd_read_kspec.
    apply WRfwd_store_kspec.
    - eapply kspec_app; eauto. apply le_PreOrder. apply bot_spec. apply WRfwd_write_kspec. apply WRfwd_read_kspec.
    - eapply kspec_app; eauto. apply le_PreOrder. apply bot_spec. apply WRfwd_fence_w_kspec. apply WRfwd_fence_r_kspec.
  Qed.

  Lemma skip_d:
    forall (l: Loc.t) (k: Two), eq (WRfwd_inst Inst.skip l k) k.
  Proof.
    i. ss.
  Qed.

  Let inst_d := WRfwd_inst.

  Lemma inst_d_mon: forall (i: Inst.t) p d1 d2 (LE: le d1 d2), le (inst_d i p d1) (inst_d i p d2).
  Proof.
    i. hexploit WRfwd_kspec. i. unfold knowledge_spec in H. des. eapply MON; eauto.
  Qed.

End ALGAUX.

Section ALG.

  Definition WRfwd_do_opt (mp: Data Two Loc.t) (i: Inst.t) : Prop :=
    match i with
    | Inst.load _ l o =>
      match (mp l), o with
      | Some (_, _), Ordering.na => True
      | _, _ => False
      end
    | _ => False
    end
  .

  Lemma do_opt_not:
    forall i data, not (WRfwd_do_opt data i) -> WRfwd_opt_inst data i = i.
  Proof.
    i. destruct i; ss; clarify. des_ifs; ss; clarify.
  Qed.

  Lemma do_opt_mon:
    forall i d1 d2 (LE: forall p, le (d1 p) (d2 p)) (DO: WRfwd_do_opt d1 i),
      WRfwd_do_opt d2 i.
  Proof.
    i. destruct i; ss; clarify. des_ifs; ss; clarify.
    specialize LE with rhs. unfold le in LE.
    rewrite Heq0 in LE. rewrite Heq in LE. clarify.
  Qed.

  Definition WRfwd_opt4: Opt4.t :=
    Opt4.mk_opt4
      TwoML bot bot_spec N
      WRfwd_inst inst_d_mon skip_d
      WRfwd_opt_inst
      WRfwd_do_opt do_opt_not do_opt_mon.

  Definition block_d := Opt4.block_d WRfwd_opt4.

  Lemma analysis_correct: WRfwd_block = block_d.
  Proof. ss. Qed.

End ALG.

Section FIXPOINT.

  Lemma level_grounded: forall (t: Two), grounded eq le t N.
  Proof.
    i. econs. i. unfold lt in LT. des.
    destruct t, k'; ss; clarify; des_ifs; ss; clarify; des; clarify; ss.
    - clear.
      econs. i. unfold lt in LT. des.
      destruct k'; ss; clarify; des_ifs; ss; clarify; des; clarify; ss.
      clear LT LT0. econs; i. unfold lt in LT. des.
      destruct k'; ss; clarify; des_ifs; ss; clarify; des; clarify; ss.
    - destruct b; ss; clarify.
      clear LT. econs. i. unfold lt in LT. des.
      destruct k'; ss; clarify; des_ifs; ss; clarify; des; clarify; ss.
      clear LT LT0. econs; i. unfold lt in LT. des.
      destruct k'; ss; clarify; des_ifs; ss; clarify; des; clarify; ss.
    - clear.
      econs. i. unfold lt in LT. des.
      destruct k'; ss; clarify; des_ifs; ss; clarify; des; clarify; ss.
  Qed.

  Definition WRfwd_fix4: FixOpt4.t :=
    @FixOpt4.mk_fix4
      TwoML bot bot_spec N level_grounded
      (Loc.t) WRfwd_inst WRfwd_kspec skip_d.

  Lemma WRfwd_kspec2: forall blk p, knowledge_spec (MLattice.le TwoML) bot (WRfwd_block blk p).
  Proof.
    i. eapply (@update_block_is_knowledge WRfwd_fix4).
  Qed.

  Theorem block_d_fix: forall blk f (FUN: f = block_d blk) p,
      @n_fix Two (MLattice.eq TwoML) (MLattice.eq_Equiv TwoML) (f p) (S N).
  Proof.
    i. eapply (@update_block_fix WRfwd_fix4). eauto.
  Qed.

  Theorem block_d_dec: forall blk p d f (FUN: f = block_d blk p), (MLattice.le TwoML) (f (f d)) (f d).
  Proof.
    i. clarify. ss. rewrite <- analysis_correct.
    hexploit (knowledge_le_n eq_leibniz (@MLattice.le_PartialOrder TwoML) bot_spec 1 (WRfwd_kspec2 blk p)).
    i; ss. eauto.
  Qed.

End FIXPOINT.


Require Import Coq.Program.Tactics.
Require Import Coq.Logic.FunctionalExtensionality.
From mathcomp Require Import ssreflect ssrfun seq bigop eqtype choice fintype.

Set Warnings "-parsing". (* Some weird bug in ssrbool throws out parsing warnings*)
  From mathcomp Require Import ssrbool.
Set Warnings "parsing".

Set Warnings "-ambiguous-paths". (* Some weird bug in ssralg throws out coercion warnings*)
    From mathcomp Require Import ssralg.
Set Warnings "ambiguous-paths".

Require Import Algebras DirectSum Basis Submodule Quotient FreeModules.
Set Implicit Arguments.
Unset Strict Implicit.

Module projLmod.
  Section Def.
    Variable (R : ringType).
    Record mixin_of (M : lmodType R)
    := Mixin { partner : lmodType R; basis : lmodFinBasisType (pair_lmodType M partner); }.
    Record type := Pack { sort : _;  class_of : mixin_of sort; }.

    Definition Build (M : lmodType R) (partner : lmodType R)
     (basis : lmodFinBasisType (pair_lmodType M partner))
      := @Pack M (@Mixin M partner basis).
  End Def.

  Section FromFree.
    Variable (R : ringType) (F : fdFreeLmodType R).
    Definition from_free : type R
    := @Build R F (null_fdFreeLmod R) (pairBasis (fdFreeLmod.basis F) (fdFreeLmod.basis (null_fdFreeLmod R))).
  End FromFree.

  Module Exports.
    Notation projLmodType := type.
    Notation proj_partner := partner.
    Notation proj_basis := basis.
    Notation proj_from_free := from_free.
    Coercion sort : type >-> lmodType.
    Coercion class_of : type >-> mixin_of.
  End Exports.
End projLmod.
Export projLmod.Exports.

Notation null_projLmod := (fun R => proj_from_free (null_fdFreeLmod R)).

Module lmodProjPair.
  Section Def.
    Variable (R : ringType) (m1 m2 : projLmodType R).

    Notation typ m1 m2 := (sum_finType (lmodFinSet.sort (proj_basis m1)) (lmodFinSet.sort (proj_basis m2))).
    Definition pairBasis_set : lmodFinSetType
    (lmodDSPairType (lmodDSPairType m1 m2)
       (lmodDSPairType (proj_partner m1) (proj_partner m2))).
    Proof. Admitted. (*
      refine (@lmodFinSet.Build _
        (lmodDSPairType
          (lmodDSPairType m1 m2)
          (lmodDSPairType (proj_partner m1) (proj_partner m2))
        ) _
      (fun bAB => match bAB with
      |inl bA => match bA with
        |inl A1 => ((A1,0%R),(0%R,0%R))
        |inr A2 => ((_,_),(_,_))
        end
      |inr bB => match bB with
        |inl B1 => ((_,_),(_,_))
        |inr B2 => ((_,_),(_,_))
        end
      end)
       _ _).*)

    Definition pairBasis : lmodFinBasisType
    (lmodDSPairType (lmodDSPairType m1 m2)
       (lmodDSPairType (proj_partner m1) (proj_partner m2))).

       refine (lmodFinBasis.Build _ _).
       destruct m1, m2=>/=.
       rewrite/lmodDSPairType=>/=.
    Admitted.

    Definition type : projLmodType R :=
      projLmod.Build pairBasis.
  End Def.

  Section Results.
    Variable (R : ringType) (m1 m2 : projLmodType R).
    Lemma proj_part : proj_partner (type m1 m2) = pair_lmodType (proj_partner m1) (proj_partner m2).
    Proof. by rewrite/type=>/=. Qed.
  End Results.
End lmodProjPair.

Notation pair_lmodProj := lmodProjPair.type.

Module lmodProjSeq.
  Section Def.
  Variable (R : ringType).
    Fixpoint type (L : seq (projLmodType R)) : projLmodType R :=
      match L with
      |nil => null_projLmod R
      |a::l => pair_lmodProj a (type l)
      end.
  End Def.
End lmodProjSeq.

Notation seq_lmodProj := lmodProjSeq.type.

Module lmodProjFin.
  Section Def.
    Variable (R : ringType) (F : finType) (I : F -> (projLmodType R)).
    Definition type := seq_lmodProj (map I (enum F)).

    Lemma is_direct_sum
      : projLmod.sort type = \bigoplus (fun f : F => projLmod.sort (I f)).
    Proof.
      rewrite /type/dsLmod.DS.
      rewrite /seq_lmodProj.
      by induction (enum F)=>//=; rewrite IHl.
    Qed.
  End Def.
End lmodProjFin.

Close Scope ring_scope.


Require Import Lia.
Require Import RelationClasses.

From sflib Require Import sflib.

From PromisingLib Require Import Axioms.
From PromisingLib Require Import Basic.
From PromisingLib Require Import DataStructure.
From PromisingLib Require Import DenseOrder.
From PromisingLib Require Import Loc.

From PromisingLib Require Import Event.
Require Import Time.
Require Import View.
Require Import Cell.
Require Import Memory.

Set Implicit Arguments.

Module MemoryDomain.
  Definition t := Loc.t -> DOSet.t.

  Definition mem loc ts (dom:t) := DOSet.mem ts (dom loc).

  Lemma ext lhs rhs
        (EXT: forall loc ts, mem loc ts lhs = mem loc ts rhs):
    lhs = rhs.
  Proof.
    apply LocFun.ext. unfold LocFun.find. i.
    apply DOSet.eq_leibniz. ii.
    specialize (EXT i a). unfold mem in *. econs; i.
    - apply DOSet.mem_spec. erewrite <- EXT.
      apply DOSet.mem_spec. auto.
    - apply DOSet.mem_spec. erewrite EXT.
      apply DOSet.mem_spec. auto.
  Qed.

  Definition bot: t := fun _ => DOSet.empty.

  Lemma bot_spec loc ts: mem loc ts bot = false.
  Proof.
    unfold mem, bot. apply DOSet.Facts.empty_b.
  Qed.

  Definition le (lhs rhs:t): Prop :=
    forall loc ts, mem loc ts lhs -> mem loc ts rhs.

  Definition join (lhs rhs:t): t :=
    fun loc => DOSet.union (lhs loc) (rhs loc).

  Lemma join_comm lhs rhs: join lhs rhs = join rhs lhs.
  Proof.
    apply LocFun.ext. unfold LocFun.find, join. i.
    apply DOSet.eq_leibniz. ii.
    rewrite ? DOSet.union_spec. econs; i; des; auto.
  Qed.

  Lemma join_assoc a b c: join (join a b) c = join a (join b c).
  Proof.
    apply LocFun.ext. unfold LocFun.find, join. i.
    apply DOSet.eq_leibniz. ii.
    rewrite ? DOSet.union_spec. econs; i; des; auto.
  Qed.

  Lemma join_l lhs rhs: le lhs (join lhs rhs).
  Proof.
    unfold join. ii. unfold mem in *.
    rewrite DOSet.Facts.union_b, H. auto.
  Qed.

  Lemma join_r lhs rhs: le rhs (join lhs rhs).
  Proof. rewrite join_comm. apply join_l. Qed.

  Lemma join_spec lhs rhs o
        (LHS: le lhs o)
        (RHS: le rhs o):
    le (join lhs rhs) o.
  Proof.
    unfold join. ii.
    unfold mem in *. rewrite DOSet.Facts.union_b in *.
    apply Bool.orb_true_iff in H. des; eauto.
  Qed.

  Definition set (loc:Loc.t) (ts:Time.t) (dom:t) :=
    LocFun.add loc (DOSet.add ts (dom loc)) dom.

  Lemma set_o loc1 ts1 loc2 ts2 dom:
    mem loc1 ts1 (set loc2 ts2 dom) =
    if loc_ts_eq_dec (loc1, ts1) (loc2, ts2)
    then true
    else mem loc1 ts1 dom.
  Proof.
    unfold mem, set, LocFun.add, LocFun.find.
    repeat (try condtac; ss; des; subst; try congr).
    - rewrite DOSet.Facts.add_b.
      unfold DOSet.Facts.eqb. rewrite Time.eq_dec_eq. auto.
    - rewrite DOSet.Facts.add_b.
      unfold DOSet.Facts.eqb. rewrite Time.eq_dec_neq; auto.
  Qed.

  Lemma set_eq loc ts dom:
    mem loc ts (set loc ts dom) = true.
  Proof.
    rewrite set_o. condtac; ss. des; congr.
  Qed.

  Lemma set_inv loc1 ts1 loc2 ts2 dom
        (MEM: mem loc1 ts1 (set loc2 ts2 dom)):
    (loc1 = loc2 /\ ts1 = ts2) \/ mem loc1 ts1 dom.
  Proof.
    revert MEM. rewrite set_o. repeat condtac; ss; auto.
  Qed.

  Definition unset (loc:Loc.t) (ts:Time.t) (dom:t) :=
    LocFun.add loc (DOSet.remove ts (dom loc)) dom.

  Lemma unset_o loc1 ts1 loc2 ts2 dom:
    mem loc1 ts1 (unset loc2 ts2 dom) =
    if loc_ts_eq_dec (loc1, ts1) (loc2, ts2)
    then false
    else mem loc1 ts1 dom.
  Proof.
    unfold mem, unset, LocFun.add, LocFun.find.
    repeat (try condtac; ss; des; subst; try congr).
    - rewrite DOSet.Facts.remove_b.
      unfold DOSet.Facts.eqb. rewrite Time.eq_dec_eq.
      apply Bool.andb_false_iff. auto.
    - rewrite DOSet.Facts.remove_b.
      unfold DOSet.Facts.eqb. rewrite Time.eq_dec_neq; auto.
      apply Bool.andb_true_r.
  Qed.

  Lemma unset_eq loc ts dom:
    mem loc ts (unset loc ts dom) = false.
  Proof.
    rewrite unset_o. condtac; ss. des; congr.
  Qed.

  Lemma unset_inv loc1 ts1 loc2 ts2 dom
        (MEM: mem loc1 ts1 (unset loc2 ts2 dom)):
    ~ (loc1 = loc2 /\ ts1 = ts2) /\ mem loc1 ts1 dom.
  Proof.
    revert MEM. rewrite unset_o. condtac; ss. i.
    splits; auto. ii. des; auto.
  Qed.

  Lemma unset_set loc to inv
        (MEM: mem loc to inv = false):
    unset loc to (set loc to inv) = inv.
  Proof.
    apply ext. i.
    rewrite unset_o, set_o.  condtac; ss. des. subst. auto.
  Qed.

  Lemma unset_bot loc to:
    unset loc to bot = bot.
  Proof.
    apply ext. i. rewrite unset_o. condtac; ss.
  Qed.

  Inductive disjoint (lhs rhs:t): Prop :=
  | disjoint_intro
      (DISJOINT: forall loc ts
                   (LHS: mem loc ts lhs)
                   (RHS: mem loc ts rhs),
          False).

  Global Program Instance disjoint_Symmetric: Symmetric disjoint.
  Next Obligation.
    econs. ii. eapply H; eauto.
  Qed.

  Definition sound (dom: t) (promises: Memory.t): Prop :=
    forall loc ts (MEM: mem loc ts dom),
      exists from msg, Memory.get loc ts promises = Some (from, msg).
End MemoryDomain.


From RecordUpdate Require Import RecordSet.
From Perennial.Helpers Require Import Map.

From Perennial.goose_lang Require Import crash_modality.
From Perennial.base_logic Require Import lib.ghost_map.

From Goose.github_com.mit_pdos.perennial_examples Require Import alloc.
From Perennial.program_proof Require Import disk_prelude.
From Perennial.program_proof.examples Require Import alloc_addrset.

Class allocG Σ :=
  { alloc_used_preG :> ghost_mapG Σ u64 (); }.

(* state representation types (defined here since modules can't be in sections) *)
Module alloc.
  Record t :=
    mk { domain: gset u64;
         used: gset u64;
       }.
  Global Instance _eta : Settable _ := settable! mk <domain; used>.
  Global Instance _witness : Inhabited t := populate!.

  Definition wf σ := σ.(used) ⊆ σ.(domain).
  Definition free σ := σ.(domain) ∖ σ.(used).
End alloc.

Section goose.
Context `{!heapGS Σ}.
Context `{!allocG Σ}.

Let allocN := nroot.@"allocator".

Record alloc_names :=
  { alloc_used_name: gname;
  }.

Instance alloc_names_eta : Settable _ := settable! Build_alloc_names <alloc_used_name>.

Implicit Types (a: u64) (m: gmap u64 ()) (free: gset u64).

Context (P: alloc.t → iProp Σ).
Context (Ψ: u64 → iProp Σ).
Implicit Types (l:loc) (γ:alloc_names) (σ: alloc.t).

Definition allocator_durable σ : iProp Σ :=
  "%Hwf'" ∷ ⌜alloc.wf σ⌝ ∗
  "Hblocks" ∷ [∗ set] k ∈ alloc.free σ, Ψ k.

Definition allocator_linv γ (mref: loc) σ : iProp Σ :=
  "%Hwf" ∷ ⌜alloc.wf σ⌝ ∗
  "Hfreemap" ∷ is_addrset mref (alloc.free σ) ∗
  "Hdurable" ∷ allocator_durable σ ∗
  "Hallocated" ∷ ghost_map_auth γ.(alloc_used_name) 1
                   (gset_to_gmap () (alloc.used σ))
.

Definition is_allocator (l: loc) γ : iProp Σ :=
  ∃ (lref mref: loc),
    "#m" ∷ readonly (l ↦[Allocator :: "m"] #lref) ∗
    "#free" ∷ readonly (l ↦[Allocator :: "free"] #mref) ∗
    "#His_lock" ∷ is_lock allocN #lref
                          (∃ σ, "Hlockinv" ∷ allocator_linv γ mref σ ∗ "HP" ∷ P σ)
.

Definition alloc_used γ a : iProp Σ :=
  a ↪[γ.(alloc_used_name)] ().

Context {Hitemcrash: ∀ x, IntoCrash (Ψ x) (λ _, Ψ x)}.
Instance allocator_post_crash γ mref σ :
  IntoCrash (allocator_linv γ mref σ) (λ _, allocator_durable σ).
Proof.
  hnf; iNamed 1.
  by iFrame.
Qed.

Global Instance is_allocator_Persistent l γ :
  Persistent (is_allocator l γ).
Proof. apply _. Qed.

(* TODO: prove something useful for initializing from zero blocks *)

Theorem wp_newAllocator mref (start sz: u64) used :
  int.Z start + int.Z sz < 2^64 →
  {{{ is_addrset mref used ∗
      let σ0 := {| alloc.domain := rangeSet (int.Z start) (int.Z sz);
                   alloc.used := used |} in
      ⌜alloc.wf σ0⌝ ∗ allocator_durable σ0 ∗ ▷ P σ0 }}}
    New #start #sz #mref
  {{{ l γ, RET #l; is_allocator l γ }}}.
Proof using allocG0.
  iIntros (Hoverflow Φ) "(Hused&%Hwf&Hblocks&HP) HΦ".
  wp_call.
  wp_apply wp_freeRange; first by auto.
  iIntros (mref') "Hfree".
  wp_pures.
  wp_apply (wp_mapRemove with "[$Hfree $Hused]"); iIntros "(Hfree & Hused)".
  wp_apply wp_new_free_lock.
  iIntros (lk) "Hlock".
  rewrite -wp_fupd.
  wp_apply wp_allocStruct; auto.
  iIntros (l) "Hallocator".
  iDestruct (struct_fields_split with "Hallocator") as "(m&free&_)".
  iMod (readonly_alloc_1 with "m") as "#m".
  iMod (readonly_alloc_1 with "free") as "#free".
  iMod (ghost_map_alloc (gset_to_gmap () used)) as (γ2) "[Husedctx _]".
  set (γ:={| alloc_used_name := γ2 |}).
  iMod (alloc_lock allocN ⊤ _
                   (∃ σ, "Hlockinv" ∷ allocator_linv γ mref' σ ∗ "HP" ∷ P σ)%I
          with "[$Hlock] [-HΦ]") as "#Hlock".
  { iExists _; iFrame.
    rewrite /alloc.free /=.
    iFrame "% ∗". }
  iModIntro.
  iApply ("HΦ" $! _ γ).
  iExists _, _; iFrame "#".
Qed.

Lemma map_empty_difference `{Countable K} {V} (m: gmap K V) :
  ∅ ∖ m = ∅.
Proof.
  apply map_eq; intros.
  rewrite lookup_difference_None; eauto.
Qed.

Lemma set_empty_difference `{Countable K} (m: gset K) :
  ∅ ∖ m = ∅.
Proof.
  clear.
  set_solver.
Qed.

Theorem alloc_free_use σ new :
  alloc.free (set alloc.used (union new) σ) =
  alloc.free σ ∖ new.
Proof.
  clear.
  rewrite /alloc.free /=.
  set_solver.
Qed.

Theorem wp_Reserve (Q: option u64 → iProp Σ) l γ :
  {{{ is_allocator l γ ∗
     (∀ σ σ' ma,
          ⌜match ma with
           | Some a => a ∈ alloc.free σ ∧ σ' = set alloc.used ({[a]} ∪.) σ
           | None => σ' = σ
           end⌝ -∗
           ⌜alloc.wf σ⌝ -∗
          ▷ P σ ={⊤}=∗ ▷ P σ' ∗ Q ma)
  }}}
    Allocator__Reserve #l
  {{{ a (ok: bool), RET (#a, #ok);
      if ok then Q (Some a) ∗ Ψ a ∗ alloc_used γ a
      else Q None }}}.
Proof.
  clear.
  iIntros (Φ) "(Hinv&Hfupd) HΦ"; iNamed "Hinv".
  wp_call.
  wp_loadField.
  wp_apply (acquire_spec with "His_lock").
  iIntros "(His_locked & Hinner)"; iNamed "Hinner".
  iNamed "Hlockinv".
  wp_loadField.
  wp_apply (wp_findKey with "Hfreemap").
  iIntros (k ok) "[%Hk Hfreemap]".
  wp_pures.
  wp_loadField.
  iDestruct "Hfreemap" as (m') "[Hfreemap %Hdom]".
  wp_apply (wp_MapDelete with "Hfreemap"); iIntros "Hfreemap".
  iAssert (is_addrset mref (alloc.free σ ∖ {[k]})) with "[Hfreemap]" as "Hfreemap".
  { iExists _; iFrame.
    iPureIntro.
    rewrite /map_del.
    rewrite dom_delete_L.
    set_solver. }
  iMod ("Hfupd" $! _ (if ok then _ else _) (if ok then Some k else None) with "[] [%//] HP") as "[HP HQ]".
  { destruct ok; simpl; auto. }
  wp_loadField.
  destruct ok.

  - (* extract block *)
    iNamed "Hdurable".
    iDestruct (big_sepS_delete with "Hblocks") as "[Hbk Hblocks]"; eauto.

    iMod (ghost_map_insert k () with "Hallocated") as "[Hallocated His_used]".
    { apply lookup_gset_to_gmap_None.
      rewrite /alloc.free in Hk; set_solver. }

    wp_apply (release_spec with "[-HΦ HQ Hbk His_used $His_lock $His_locked]").
    { iExists _; iFrame.
      assert (alloc.wf (set alloc.used ({[k]} ∪.) σ)) as Hwf''.
      { rewrite /alloc.wf in Hwf |- *; set_solver. }
      iFrame "%".
      iSplitL "Hfreemap".
      - rewrite alloc_free_use; iFrame.
      - iSplitL "Hblocks".
        { rewrite alloc_free_use; iFrame. }
        simpl.
        rewrite -gset_to_gmap_union_singleton //. }
    wp_pures.
    iApply "HΦ"; by iFrame.
  - wp_apply (release_spec with "[-HΦ HQ $His_lock $His_locked]").
    { iExists _; iFrame "∗ %". iNext.
      iExactEq "Hfreemap"; rewrite /named.
      f_equal.
      set_solver. }
    wp_pures.
    iApply "HΦ"; by iFrame.
Qed.

Lemma gset_difference_difference `{Countable K} (A B C: gset K) :
  C ⊆ A →
  A ∖ (B ∖ C) = A ∖ B ∪ C.
Proof using.
  clear.
  intros.
  apply set_eq; intros k.
  rewrite !elem_of_difference.
  intuition.
  - destruct (decide (k ∈ C)); set_solver.
  - set_solver.
  - set_solver.
Qed.

Theorem alloc_free_free σ new :
  new ⊆ σ.(alloc.domain) →
  alloc.free (set alloc.used (λ used, used ∖ new) σ) =
  alloc.free σ ∪ new.
Proof.
  intros Hsub.
  rewrite /alloc.free /=.
  rewrite gset_difference_difference //.
Qed.

Lemma alloc_used_valid γ a used :
  ghost_map_auth γ.(alloc_used_name) 1 (gset_to_gmap () used) -∗
  alloc_used γ a -∗
  ⌜a ∈ used⌝.
Proof.
  rewrite /alloc_used.
  iIntros "Hctx Hused".
  iDestruct (ghost_map_lookup with "Hctx Hused") as %Hlookup.
  iPureIntro.
  apply lookup_gset_to_gmap_Some in Hlookup as [? _]; auto.
Qed.

Theorem wp_Free (Q: iProp Σ) l γ (a: u64) :
  {{{ is_allocator l γ ∗ Ψ a ∗ alloc_used γ a ∗
     (∀ σ σ',
          ⌜σ' = set alloc.used (λ used, used ∖ {[a]}) σ⌝ -∗
          ⌜alloc.wf σ⌝ -∗
          ▷ P σ ={⊤}=∗ ▷ P σ' ∗ Q)
  }}}
    Allocator__Free #l #a
  {{{ RET #(); Q }}}.
Proof.
  clear Hitemcrash.
  iIntros (Φ) "(Halloc&Hb&Hused&Hfupd) HΦ"; iNamed "Halloc".
  wp_call.
  wp_loadField.
  wp_apply (acquire_spec with "His_lock").
  iIntros "(Hlocked&Hinv)"; iNamed "Hinv".
  iNamed "Hlockinv".
  wp_loadField.
  iDestruct "Hfreemap" as (m) "[Hfreemap %Hdom]".
  wp_apply (wp_MapInsert _ _ _ _ () with "Hfreemap"); first by auto.
  iIntros "Hfreemap".
  iAssert (is_addrset mref (alloc.free σ ∪ {[a]})) with "[Hfreemap]" as "Hfreemap".
  { iExists _; iFrame.
    iPureIntro.
    rewrite /map_insert dom_insert_L.
    set_solver. }
  wp_loadField.
  iMod ("Hfupd" $! σ with "[] [%//] HP") as "[HP HQ]".
  { iPureIntro.
    eauto. }
  iDestruct (alloc_used_valid with "Hallocated Hused") as %Hused.
  assert (a ∉ alloc.free σ) by set_solver.
  assert (a ∈ σ.(alloc.domain)) by set_solver.
  assert (alloc.wf (set alloc.used (λ used : gset u64, used ∖ {[a]}) σ)) as Hwf''.
  { set_solver. }
  iMod (ghost_map_delete with "Hallocated Hused") as "Hallocated".
  wp_apply (release_spec with "[$His_lock $Hlocked Hb Hdurable Hfreemap Hallocated HP]").
  { iNamed "Hdurable".
    iExists _; iFrame "HP".
    iFrame "%".
    rewrite alloc_free_free; last first.
    { apply elem_of_subseteq_singleton; auto. }
    iFrame "Hfreemap".
    rewrite big_sepS_union; last first.
    { apply disjoint_singleton_r; auto. }
    rewrite big_opS_singleton.
    iFrame "Hb Hblocks". iNext.
    iExactEq "Hallocated".
    rewrite /named.
    f_equal.
    simpl.
    rewrite -gset_to_gmap_difference_singleton //.
  }
  iApply ("HΦ" with "[$]").
Qed.

End goose.


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

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

(**********************************************************************)
(*                      Delayed_reduction.v                           *)
(*                                                                    *)
(* adapted from Terms.v for Lambda Calculus                           *)
(*                                                                    *)
(*                          Barry Jay                                 *)
(*                                                                    *)
(**********************************************************************)

Require Import Omega Test Delayed_Terms Delayed_Tactics.

Fixpoint swap j t :=
(* swap j and S j *)
match t with
| Unit  => Unit
| Pair s t1 => Pair (swap j s) (swap j t1)
| Ref i s =>
match compare i j with
        (* i<j *) | inleft (left _) => Ref i (swap j s)
        (* i=j *) | inleft _ =>  Ref (S i) (swap j s)
        (* i>j *) | _ =>
                    match compare (S j) i with
                      (* S j < i  *) | inleft (left _) =>  Ref i (swap j s)
                      (* S j = i  *) | _ => Ref j (swap j s)
                                                end
end
| Abs t1 => Abs (swap (S j) t1)
| App t1 t2 => App (swap j t1) (swap j t2)
end.

Lemma aux1: swap 0 (Ref 0 Unit) = Ref 1 Unit.
Proof. split_all. Qed.

Lemma aux2: swap 1 (Ref 0 Unit) = Ref 0 Unit.
Proof. split_all. Qed.

Lemma aux3: swap 0 (Ref 1 Unit) = Ref 0 Unit.
Proof. split_all. Qed.

Lemma aux4: swap 1 (Ref 1 Unit) = Ref 2 Unit.
Proof. split_all. Qed.

Lemma aux5: swap 0 (Ref 2 Unit) = Ref 2 Unit.
Proof. split_all. Qed.

Lemma aux6: swap 1 (Ref 2 Unit) = Ref 1 Unit.
Proof. split_all. Qed.

Lemma lift_rec_preserves_swap:
forall M j k, S j < k -> lift_rec (swap j M) k = swap j (lift_rec M k).
Proof.
induction M; split_all.
(* 4 *)
rewrite IHM1; split_all. rewrite IHM2; split_all.
(* 3 *)
unfold relocate; split_all.
elim(test k n); split_all.
elim(compare n j); split_all. elim a0; split_all; try noway.
elim(compare (S j) n); split_all; try noway.
elim a0; split_all; try noway.
elim(compare (S n) j); split_all; try noway.
elim a2; split_all; try noway.
unfold relocate; split_all.
elim(test k n); split_all.
elim(compare (S j) (S n)); split_all. elim a3; split_all; try noway.
rewrite IHM; auto.
noway.
elim(compare (S j) (S n)); split_all. elim a2; split_all; try noway.
rewrite IHM; auto.
noway.
elim(compare n j); split_all; try noway.
elim a; split_all; try noway.
unfold relocate; split_all.
elim(test k n); split_all.
noway.
rewrite IHM; auto.
subst.
unfold relocate; split_all.
elim(test k (S j)); split_all.
noway.
rewrite IHM; auto.
elim(compare (S j) n); split_all. elim a; split_all; try noway.
unfold relocate; split_all.
elim(test k n); split_all.
noway.
rewrite IHM; auto.
subst.
unfold relocate; split_all.
elim(test k j); split_all.
noway.
rewrite IHM; auto.
noway.
(* 2 *)
rewrite IHM; auto. omega.
(* 1 *)
rewrite IHM1; split_all. rewrite IHM2; split_all.
Qed.

Lemma lift_rec_preserves_swap2:
forall M j k, k<= j -> lift_rec (swap j M) k = swap (S j) (lift_rec M k).
Proof.
induction M; split_all.
(* 4 *)
rewrite IHM1; split_all; try omega. rewrite IHM2; split_all; try omega.
(* 3 *)
unfold relocate.
elim(test k n); split_all; try noway.
elim(compare n j); split_all; try noway. elim a0; split_all; try noway.
unfold relocate.
elim(test k n); split_all; try noway.
elim(compare (S n) (S j)); split_all; try noway.
elim a3; split_all; try noway.
rewrite IHM; auto.
elim(compare (S n) (S j)); split_all; try noway.
elim a1; split_all; try noway.
unfold relocate. elim(test k (S n)); split_all; try noway.
rewrite IHM; auto.
elim(compare (S j) n); split_all; try noway.
elim a0; split_all; try noway.
elim(compare (S n) (S j)); split_all; try noway.
elim a2; split_all; try noway.
elim(compare (S (S j)) (S n)); split_all; try noway.
elim a2; split_all; try noway.
unfold relocate. elim(test k n); split_all; try noway.
rewrite IHM; auto.
subst. elim(compare (S (S j)) (S j)); split_all; try noway.
elim a1; split_all; try noway.
elim(compare (S (S j)) (S (S j))); split_all; try noway.
elim a1; split_all; try noway.
unfold relocate. elim(test k j); split_all; try noway.
rewrite IHM; split_all.
elim(compare n j); split_all; try noway. elim a; split_all; try noway.
unfold relocate.
elim(test k n); split_all; try noway.
elim(compare n (S j)); split_all; try noway.
elim a1; split_all; try noway.
rewrite IHM; auto.
(* 2 *)
rewrite IHM; auto. omega.
(* 1 *)
rewrite IHM1; split_all; try omega. rewrite IHM2; split_all; try omega.
Qed.

Lemma swap_swap :
forall M j k, S k < j -> swap j (swap k M) = swap k (swap j M).
Proof.
induction M; split_all.
(* 4 *)
rewrite IHM1; split_all. rewrite IHM2; split_all.
(* 3 *)
elim(compare n k); split_all. elim a; split_all; try noway.
elim(compare n j); split_all; try noway.
elim a1; split_all; try noway.
elim(compare n k); split_all; try noway.
elim a3; split_all; try noway.
rewrite IHM; auto.
subst. elim(compare (S k) j); split_all. elim a0; split_all; try noway.
elim(compare k j); split_all; try noway.
elim a2; split_all; try noway.
elim(compare k k); split_all; try noway.
elim a4; split_all; try noway.
rewrite IHM; auto.
elim(compare (S j) (S k)); split_all. elim a0; split_all; try noway.
elim(compare k j); split_all; try noway.
elim(compare (S k) n); split_all; try noway. elim a; split_all; try noway.
elim(compare n j); split_all; try noway.
elim a1; split_all; try noway.
elim(compare n k); split_all; try noway.
elim a3; split_all; try noway.
elim(compare (S k) n); split_all. elim a3; split_all; try noway.
rewrite IHM; auto.
noway.
subst. elim(compare (S j) k); split_all; try noway.
elim a2; split_all; try noway.
elim(compare (S k) (S j)); split_all; try noway.
elim a2; split_all; try noway.
rewrite IHM; auto.
elim(compare (S j) n); split_all. elim a1; split_all; try noway.
elim(compare n k); split_all; try noway. elim a3; split_all; try noway.
elim(compare (S k) n); split_all; try noway. elim a3; split_all; try noway.
rewrite IHM; auto.
elim(compare j k); split_all. elim a2; split_all; try noway.
subst. elim(compare (S k) j); split_all; try noway. elim a2; split_all; try noway.
rewrite IHM; auto.
elim(compare j k); split_all; try noway.
subst. elim(compare k j); split_all; try noway. elim a0; split_all; try noway.
elim(compare (S k) j); split_all; try noway. elim a2; split_all; try noway.
elim(compare (S k) k); split_all; try noway. elim a4; split_all; try noway.
elim(compare (S k) (S k)); split_all; try noway. elim a4; split_all; try noway.
rewrite IHM; auto.
(* 2 *)
rewrite IHM; auto. omega.
(* 1 *)
rewrite IHM1; split_all. rewrite IHM2; split_all.
Qed.

(* Parallel lift reduction *)

Definition termred := lambda -> lambda -> Prop.

Inductive tuple_red1: termred :=
  | un_tuple_red : tuple_red1 Unit Unit
  | pair_tuple_red : forall M M' ,
      tuple_red1 M M' ->
      forall N N', tuple_red1 N N' -> tuple_red1 (Pair M N) (Pair M' N')
  | ref_tuple_red : forall i M M', tuple_red1 M M' -> tuple_red1 (Ref i M) (Ref i M')
  | abs_tuple_red :
      forall M M', tuple_red1 M M' -> tuple_red1 (Abs M) (Abs M')
  | app_tuple_red :
      forall M M' ,
      tuple_red1 M M' ->
      forall N N', tuple_red1 N N' -> tuple_red1 (App M N) (App M' N')
  | ref_app_red : forall i M M' N N', tuple_red1 M M' -> tuple_red1 N N' ->
                                  tuple_red1 (App (Ref i M) N) (Ref i (Pair M' N'))
  | beta_id_red : forall N N',  tuple_red1 N N' -> tuple_red1 (App (Abs (Ref 0 Unit)) N) N'
  | beta_const_red : forall i N, tuple_red1 (App (Abs (Ref (S i) Unit)) N) (Ref i Unit)
  | beta_pair_red : forall i M M' N N' P P',
                      tuple_red1 M M' -> tuple_red1 N N' -> tuple_red1 P P' ->
                      tuple_red1 (App (Abs (Ref i (Pair P M))) N)
                                 (App (App (Abs (Ref i P')) N') (App (Abs M') N'))
  | beta_abs_red : forall M M' N N',
                     tuple_red1 M M' -> tuple_red1 N N' ->
                     tuple_red1 (App (Abs (Abs M)) N)
                               (Abs (App (Abs  (swap 0 M')) (lift N')))
.

Hint Constructors tuple_red1.

Definition tuple_red := multi_step tuple_red1.

Lemma refl_tuple_red1: reflective tuple_red1.
Proof. red. induction M; split_all. Qed.

Hint Resolve refl_tuple_red1.

Lemma preserves_unit_tuple_red:
forall red M N, multi_step red M N -> red = tuple_red1 -> M = Unit -> N = Unit.
Proof. intros red M N r; induction r; split_all; subst. inversion H; subst. auto. Qed.

Lemma preserves_pair_tuple_red:
forall M M' N N', tuple_red M M' -> tuple_red N N' -> tuple_red (Pair M N) (Pair M' N').
Proof.
intros. apply transitive_red with (Pair M' N).
eapply2 preserves_pairl_multi_step. red; split_all.
eapply2 preserves_pairr_multi_step. red; split_all.
Qed.

Lemma preserves_ref_tuple_red:
forall red M M', multi_step red M M' -> red = tuple_red1 ->
forall i, tuple_red (Ref i M) (Ref i M').
Proof.
intros red M M' r; induction r; split_all; subst. eapply2 zero_red.
eapply succ_red. eapply ref_tuple_red.  eexact H. eapply2 IHr.
Qed.

Lemma preserves_appl_tuple_red:
forall red M M' N, multi_step red M M' -> red = tuple_red1 -> tuple_red (App M N) (App M' N).
Proof.
intros red M M' N r; induction r; split_all; subst. eapply2 zero_red.
apply succ_red with (App N0 N).  auto. eapply2 IHr.
Qed.

Lemma preserves_appr_tuple_red:
forall red M N N', multi_step red N N' -> red = tuple_red1 -> tuple_red (App M N) (App M N').
Proof.
intros red M N N' r; induction r; split_all; subst. eapply2 zero_red.
apply succ_red with (App M N).  auto. eapply2 IHr.
Qed.

Lemma preserves_app_tuple_red:
forall M M' N N', tuple_red M M' -> tuple_red N N' -> tuple_red (App M N) (App M' N').
Proof.
intros. apply transitive_red with (App M' N).
eapply2 preserves_appl_tuple_red.
eapply2 preserves_appr_tuple_red.
Qed.

Lemma preserves_abs_tuple_red:
forall red M M', multi_step red M M' -> red = tuple_red1 -> tuple_red (Abs M) (Abs M').
Proof.
intros red M M' r; induction r; split_all; subst. eapply2 zero_red.
apply succ_red with (Abs N).  auto. eapply2 IHr.
Qed.

Lemma preserves_unit2_tuple_red:
forall red P1 P2, multi_step red P1 P2 -> red = tuple_red1 ->
P1 = Unit -> P2 = Unit.
Proof.
intros red P1 P2 r; induction r; split_all; subst.
inversion H; subst. eapply2 IHr.
Qed.

Lemma preserves_pair2_tuple_red:
forall red P1 P2, multi_step red P1 P2 -> red = tuple_red1 ->
forall M1 N1, P1 = Pair M1 N1 ->
exists M2 N2, P2 = Pair M2 N2 /\ tuple_red M1 M2 /\ tuple_red N1 N2.
Proof.
intros red P1 P2 r; induction r; split_all; subst.
exist M1; exist N1; eapply2 zero_red.
inversion H; subst.
assert(exists M2 N2 : lambda,
          P = Pair M2 N2 /\ tuple_red M' M2 /\ tuple_red N' N2). eapply2 IHr.
split_all; subst. exist x; exist x0; eapply2 succ_red.
Qed.

Lemma preserves_ref2_tuple_red:
forall red P1 P2, multi_step red P1 P2 -> red = tuple_red1 ->
forall i s1, P1 = Ref i s1 ->
exists s2, P2 = Ref i s2 /\ tuple_red s1 s2.
Proof.
intros red P1 P2 r; induction r; split_all; subst.
exist s1; eapply2 zero_red.
inversion H; subst.
assert( exists s2 : lambda, P = Ref i s2 /\ tuple_red M' s2).  eapply2 IHr.
split_all; subst. exist x; eapply2 succ_red.
Qed.

Lemma preserves_abs2_tuple_red:
forall red P1 P2, multi_step red P1 P2 -> red = tuple_red1 ->
forall t1, P1 = Abs t1 ->
exists t2, P2 = Abs t2 /\ tuple_red t1 t2.
Proof.
intros red P1 P2 r; induction r; split_all; subst.
exist t1; eapply2 zero_red.
inversion H; subst.
assert( exists t2 : lambda, P = Abs t2 /\ tuple_red M' t2).  eapply2 IHr.
split_all; subst. exist x; eapply2 succ_red.
Qed.

Lemma lift_rec_preserves_tuple_red1:
forall M N, tuple_red1 M N -> forall k, tuple_red1 (lift_rec M k) (lift_rec N k).
Proof.
intros M N r; induction r; split_all.
(* 2 *)
rewrite relocate_succ. auto.
unfold lift. rewrite lift_lift_rec.
rewrite lift_rec_preserves_swap.
eapply2 beta_abs_red.
omega. omega.
Qed.

Lemma swap_preserves_tuple_red1:
forall M N, tuple_red1 M N -> forall j, tuple_red1 (swap j M) (swap j N).
Proof.
intros M N r; induction r; split_all.
(* 5 *)
elim(compare i j); split_all. elim a; split_all.
elim(compare (S j) i); split_all; try noway. elim a; split_all; try noway.
(* 4 *)
elim(compare i j); split_all. elim a; split_all.
elim(compare (S j) i); split_all; try noway. elim a; split_all; try noway.
(* 3 *)
elim(compare i j); split_all. elim a; split_all.
elim(compare (S i) (S j)); split_all; try noway. elim a1; split_all; try noway.
subst; elim(compare (S j) (S j)); split_all; try noway. elim a0; split_all; try noway.
elim(compare (S i) (S j)); split_all; try noway. elim a; split_all; try noway.
elim(compare (S (S j)) (S i)); split_all; try noway. elim a; split_all; try noway.
elim(compare (S j) i); split_all; try noway. elim a1; split_all; try noway.
elim(compare (S j) i); split_all; try noway. elim a0; split_all; try noway.
(* 2 *)
elim(compare i (S j)); split_all. elim a; split_all.
elim(compare (S (S j)) i); split_all; try noway. elim a; split_all; try noway.
(* 1 *)
rewrite swap_swap; try omega.
cut(swap (S j) (lift N') = lift (swap j N')).
intro c; rewrite c; auto.
unfold lift.
cut(forall j k, k<= j -> swap (S j) (lift_rec N' k) = lift_rec (swap j N') k).
split_all. eapply2 H. omega.
(* 1 *)
clear. induction N'; split_all.
(* 4 *)
rewrite IHN'1; split_all; rewrite IHN'2; split_all.
(* 3 *)
unfold relocate. elim(test k n); split_all.
elim(compare (S n) (S j)); split_all; try noway.
elim a0; split_all; try noway.
elim(compare n j); split_all; try noway.
elim a2; split_all; try noway.
unfold relocate; try noway.
elim(test k n); split_all; try noway.
rewrite IHN'; split_all.
elim(compare n j); split_all; try noway.
elim a1; split_all; try noway.
unfold relocate; try noway.
elim(test k (S n)); split_all; try noway.
rewrite IHN'; split_all.
elim(compare n j); split_all; try noway.
elim a0; split_all; try noway.
elim(compare (S j) n); split_all; try noway.
elim a0; split_all; try noway.
unfold relocate. elim(test k n); split_all.
elim(compare (S (S j)) (S n)); split_all; try noway.
elim a3; split_all; try noway.
rewrite IHN'; split_all.
elim(compare (S (S j)) (S n)); split_all; try noway.
elim(compare (S (S j)) (S n)); split_all; try noway.
elim a1; split_all; try noway.
unfold relocate. elim(test k j); split_all; try noway.
rewrite IHN'; split_all.
elim(compare n j); split_all; try noway.
elim a; split_all; try noway.
elim(compare n (S j)); split_all; try noway.
elim a1; split_all; try noway.
rewrite IHN'; split_all.
unfold relocate. elim(test k n); split_all; try noway.
(* 2 *)
rewrite IHN'; split_all. omega.
(* 1 *)
rewrite IHN'1; split_all. rewrite IHN'2; split_all.
Qed.

Lemma diamond_tuple_red1 : diamond tuple_red1 tuple_red1.
Proof.
red. induction M; split_all.
(* 5 *)
inversion H0; inversion H; subst; eauto; try discriminate.
(* 4 *)
inversion H0; inversion H; subst; eauto; try discriminate.
elim(IHM1 M' M'0); split_all.
elim(IHM2 N' N'0); split_all.  exist (Pair x x0).
(* 3 *)
inversion H0; inversion H; subst; eauto; try discriminate.
elim(IHM M' M'0); split_all. eauto.
(* 2 *)
inversion H; subst.    inversion H0; subst; eauto; try discriminate.
elim(IHM M'0 M'); split_all; eauto.
(* 1 *)
inversion H; subst;   inversion H0; subst; eauto; try discriminate.
(* 14 *)
elim(IHM1 M' M'0); split_all; eauto.
elim(IHM2 N' N'0); split_all; eauto.
(* 13 *)
inversion H3; subst; eauto.
elim(IHM1 (Ref i M'0) (Ref i M'1)); split_all.
elim(IHM2 N' N'0); split_all.
inversion H2; inversion H6; subst.
inversion H15; subst.
exist(Ref i (Pair M' x0)).
(* 12 *)
inversion H3; subst; eauto. inversion H2; subst; eauto. inversion H8; subst; eauto.
elim(IHM2 N' P); split_all. eauto.
(* 11 *)
inversion H3; subst; eauto. inversion H2; subst; eauto. inversion H7; subst; eauto.
(* 10 *)
inversion H3; subst; eauto. inversion H2; subst; eauto. inversion H10; subst; eauto.
elim(IHM1 (Abs (Ref i (Pair P' M'0)))(Abs (Ref i (Pair M'1 N'1)))); split_all.
elim(IHM2 N' N'0); split_all.
inversion H7; inversion H11; subst.
inversion H15; inversion H18; subst.
inversion H20; inversion H24; subst.
invsub.
exist(App (App (Abs (Ref i M')) x0) (App (Abs N'2) x0)).
(* 9 *)
inversion H3; subst; eauto. inversion H2; subst; eauto.
elim(IHM1 (Abs (Abs M')) (Abs (Abs M'0))); split_all.
inversion H8; inversion H9; subst.
inversion H10; inversion H13; subst; invsub.
elim(IHM2 N' N'0); split_all.
exist(Abs (App (Abs (swap 0 M'3)) (lift x))).
eapply2 abs_tuple_red. eapply2 app_tuple_red. eapply2 abs_tuple_red.
eapply2 swap_preserves_tuple_red1.
unfold lift. eapply2 lift_rec_preserves_tuple_red1.
(* 8 *)
inversion H4; subst.
elim(IHM1 (Ref i M') (Ref i M'1)); split_all.
inversion H2; inversion H6; subst. invsub.
elim(IHM2 N' N'0); split_all.
exist(Ref i (Pair M'0 x)).
(* 7 *)
elim(IHM1 (Ref i M') (Ref i M'0)); split_all.
inversion H2; inversion H4; subst. invsub.
elim(IHM2 N' N'0); split_all.
exist(Ref i (Pair M'1 x)).
(* 6 *)
inversion H3; subst; eauto. inversion H2; subst; eauto. inversion H8; subst; eauto.
elim(IHM2 N N'); split_all.
exist x.
(* 5 *)
inversion H3; subst; eauto. inversion H2; subst; eauto. inversion H7; subst; eauto.
(* 4 *)
inversion H5; subst; eauto. inversion H2; subst; eauto. inversion H10; subst; eauto.
elim(IHM1  (Abs (Ref i (Pair P' M'))) (Abs (Ref i (Pair M'1 N'1)))); split_all.
inversion H7; inversion H11; subst.
inversion H13; inversion H16; subst.
inversion H18; inversion H22; subst.
invsub.
elim(IHM2 N' N'0); split_all.
exist( (App (App (Abs (Ref i M'0)) x) (App (Abs N'2) x))).
(* 3 *)
elim(IHM1  (Abs (Ref i (Pair P' M'))) (Abs (Ref i (Pair P'0 M'0)))); split_all.
inversion H2; inversion H5; subst.
inversion H7; inversion H13; subst.
inversion H15; inversion H19; subst.
invsub.
elim(IHM2 N' N'0); split_all.
exist( (App (App (Abs (Ref i M'1)) x) (App (Abs N'1) x))).
(* 2 *)
inversion H4; subst; eauto. inversion H2; subst; eauto.
elim(IHM1 (Abs (Abs M')) (Abs (Abs M'0))); split_all.
inversion H8; inversion H9; subst.
inversion H10; inversion H13; subst.
invsub.
elim(IHM2 N' N'0); split_all.
exist( (Abs (App (Abs (swap 0 M'3)) (lift x))) ).
eapply2 abs_tuple_red. eapply2 app_tuple_red. eapply2 abs_tuple_red.
eapply2 swap_preserves_tuple_red1.
unfold lift.  eapply2 lift_rec_preserves_tuple_red1.
(* 1 *)
elim(IHM1 (Abs (Abs M')) (Abs (Abs M'0))); split_all.
inversion H2; inversion H6; subst.
inversion H8; inversion H11; subst.
invsub.
elim(IHM2 N' N'0); split_all.
exist( (Abs (App (Abs (swap 0 M'3)) (lift x))) ).
eapply2 abs_tuple_red. eapply2 app_tuple_red. eapply2 abs_tuple_red.
eapply2 swap_preserves_tuple_red1.
unfold lift; eapply2 lift_rec_preserves_tuple_red1.
eapply2 abs_tuple_red. eapply2 app_tuple_red. eapply2 abs_tuple_red.
eapply2 swap_preserves_tuple_red1.
unfold lift; eapply2 lift_rec_preserves_tuple_red1.
Qed.

(* Confluence *)

Definition confluence (A : Set) (R : A -> A -> Prop) :=
  forall x y : A,
  R x y -> forall z : A, R x z -> exists u : A, R y u /\ R z u.

Theorem tuple_parallel_confluence: confluence lambda tuple_red.
Proof. red. eapply2 diamond0_tiling. eapply2 diamond_iff_diamond0. eapply2 diamond_tuple_red1. Qed.

(* sequential reduction *)

Inductive seq_red1 : lambda -> lambda -> Prop :=
  | pairl_seq_red :  forall M M' N, seq_red1 M M' -> seq_red1 (Pair M N) (Pair M' N)
  | pairr_seq_red :  forall M N N', seq_red1 N N' -> seq_red1 (Pair M N) (Pair M N')
  | ref_seq_red : forall i M M' ,  seq_red1 M M' -> seq_red1 (Ref i M) (Ref i M')
  | abs_seq_red :  forall M M', seq_red1 M M' -> seq_red1 (Abs M) (Abs M')
  | appl_seq_red :  forall M M' N, seq_red1 M M' -> seq_red1 (App M N) (App M' N)
  | appr_seq_red :  forall M N N', seq_red1 N N' -> seq_red1 (App M N) (App M N')
  | ref_app_seq_red : forall i M N, seq_red1 (App (Ref i M) N) (Ref i (Pair M N))
  | beta_id_seq_red : forall N, seq_red1 (App (Abs (Ref 0 Unit)) N) N
  | beta_const_seq_red : forall i N, seq_red1 (App (Abs (Ref (S i) Unit)) N) (Ref i Unit)
  | beta_pair_seq_red : forall i M N P,
                      seq_red1 (App (Abs (Ref i (Pair P M))) N)
                                 (App (App (Abs (Ref i P)) N) (App (Abs M) N))
  | beta_abs_seq_red : forall M N, seq_red1 (App (Abs (Abs M)) N)
                               (Abs (App (Abs (swap 0 M)) (lift N)))
.

Definition seq_red := multi_step seq_red1.

Hint Constructors seq_red1 .

Lemma reflective_seq_red: reflective seq_red.
Proof. red; red; reflect. Qed.
Hint Resolve reflective_seq_red.

Lemma preserves_pairl_seq_red: preserves_pairl seq_red.
Proof. eapply2 preserves_pairl_multi_step. red; split_all.  Qed.
Hint Resolve preserves_pairl_seq_red.

Lemma preserves_pairr_seq_red: preserves_pairr seq_red.
Proof. eapply2 preserves_pairr_multi_step. red; split_all.  Qed.
Hint Resolve preserves_pairr_seq_red.

Lemma preserves_pair_seq_red: preserves_pair seq_red.
Proof.
red; split_all.
apply transitive_red with (Pair M' N); split_all.
eapply2 preserves_pairl_seq_red.
eapply2 preserves_pairr_seq_red.
Qed.
Hint Resolve preserves_pair_seq_red.

Lemma preserves_apl_seq_red: preserves_apl seq_red.
Proof. eapply2 preserves_apl_multi_step. red; split_all.  Qed.
Hint Resolve preserves_apl_seq_red.

Lemma preserves_apr_seq_red: preserves_apr seq_red.
Proof. eapply2 preserves_apr_multi_step. red; split_all.  Qed.
Hint Resolve preserves_apr_seq_red.

Lemma preserves_app_seq_red: preserves_app seq_red.
Proof.
red; split_all.
apply transitive_red with (App M' N); split_all.
eapply2 preserves_apl_seq_red.
eapply2 preserves_apr_seq_red.
Qed.
Hint Resolve preserves_app_seq_red.

Lemma preserves_abs_seq_red: preserves_abs seq_red.
Proof. eapply2 preserves_abs_multi_step. red; split_all.  Qed.

Hint Resolve preserves_app_seq_red preserves_abs_seq_red.

Lemma preserves_ref_seq_red: preserves_ref seq_red.
Proof. eapply2 preserves_ref_multi_step. red; split_all.  Qed.

Hint Resolve preserves_ref_seq_red.

Lemma seq_red1_to_tuple_red1 : implies_red seq_red1 tuple_red1.
Proof.  red. intros M N B; induction B; split_all; try (red; one_step; fail). Qed.

Lemma seq_red_to_tuple_red: implies_red seq_red tuple_red.
Proof.
  eapply2 implies_red_multi_step. red; split_all; one_step; eapply2 seq_red1_to_tuple_red1.
Qed.

Lemma to_seq_red_multi_step: forall red, implies_red red seq_red -> implies_red (multi_step red) seq_red.
Proof.
red.  intros red B M N R; induction R; split_all.
red; split_all.
assert(seq_red M N) by eapply2 B.
apply transitive_red with N; auto.
eapply2 IHR.
Qed.

Hint Resolve preserves_app_seq_red preserves_abs_seq_red.

Lemma lift_rec_preserves_seq_red1:
forall M N, seq_red1 M N -> forall n, seq_red1 (lift_rec M n) (lift_rec N n).
Proof.
intros M N r; induction r; split_all.
rewrite relocate_succ. auto.
unfold lift; rewrite lift_lift_rec.
rewrite lift_rec_preserves_swap. eapply2 beta_abs_seq_red. omega. omega.
Qed.

Lemma lift_rec_preserves_seq_red:
forall red M N, multi_step red M N -> red = seq_red1 ->
forall n, seq_red (lift_rec M n) (lift_rec N n).
Proof.
intros red M N r; induction r; split_all; subst.
eapply succ_red. eapply lift_rec_preserves_seq_red1. eexact H. eapply2 IHr.
Qed.

Lemma swap_preserves_seq_red1:
forall M N, seq_red1 M N -> forall j, seq_red1 (swap j M) (swap j N).
Proof.
intros M N r; induction r; split_all.
(* 5 *)
elim(compare i j); split_all. elim a; split_all.
elim(compare (S j) i); split_all; try noway. elim a; split_all; try noway.
(* 4 *)
elim(compare i j); split_all. elim a; split_all.
elim(compare (S j) i); split_all; try noway. elim a; split_all; try noway.
(* 3 *)
elim(compare i j); split_all. elim a; split_all.
elim(compare (S i) (S j)); split_all; try noway. elim a1; split_all; try noway.
subst; elim(compare (S j) (S j)); split_all; try noway. elim a0; split_all; try noway.
elim(compare (S i) (S j)); split_all; try noway. elim a; split_all; try noway.
elim(compare (S (S j)) (S i)); split_all; try noway. elim a; split_all; try noway.
elim(compare (S j) i); split_all; try noway. elim a1; split_all; try noway.
elim(compare (S j) i); split_all; try noway. elim a0; split_all; try noway.
(* 2 *)
elim(compare i (S j)); split_all. elim a; split_all.
elim(compare (S (S j)) i); split_all; try noway. elim a; split_all; try noway.
(* 1 *)
rewrite swap_swap; try omega.
cut(swap (S j) (lift N) = lift (swap j N)).
intro c; rewrite c; auto.
unfold lift.
cut(forall j k, k<= j -> swap (S j) (lift_rec N k) = lift_rec (swap j N) k).
split_all. eapply2 H. omega.
(* 1 *)
clear. induction N; split_all.
(* 4 *)
rewrite IHN1; split_all; rewrite IHN2; split_all.
(* 3 *)
unfold relocate. elim(test k n); split_all.
elim(compare (S n) (S j)); split_all; try noway.
elim a0; split_all; try noway.
elim(compare n j); split_all; try noway.
elim a2; split_all; try noway.
unfold relocate; try noway.
elim(test k n); split_all; try noway.
rewrite IHN; split_all.
elim(compare n j); split_all; try noway.
elim a1; split_all; try noway.
unfold relocate; try noway.
elim(test k (S n)); split_all; try noway.
rewrite IHN; split_all.
elim(compare n j); split_all; try noway.
elim a0; split_all; try noway.
elim(compare (S j) n); split_all; try noway.
elim a0; split_all; try noway.
unfold relocate. elim(test k n); split_all.
elim(compare (S (S j)) (S n)); split_all; try noway.
elim a3; split_all; try noway.
rewrite IHN; split_all.
elim(compare (S (S j)) (S n)); split_all; try noway.
elim(compare (S (S j)) (S n)); split_all; try noway.
elim a1; split_all; try noway.
unfold relocate. elim(test k j); split_all; try noway.
rewrite IHN; split_all.
elim(compare n j); split_all; try noway.
elim a; split_all; try noway.
elim(compare n (S j)); split_all; try noway.
elim a1; split_all; try noway.
rewrite IHN; split_all.
unfold relocate. elim(test k n); split_all; try noway.
(* 2 *)
rewrite IHN; split_all. omega.
(* 1 *)
rewrite IHN1; split_all. rewrite IHN2; split_all.
Qed.

Lemma swap_preserves_seq_red:
forall red M N, multi_step red M N -> red = seq_red1 ->
forall j, seq_red (swap j M) (swap j N).
Proof.
intros red M N r; induction r; split_all; subst. eapply succ_red.
eapply2 swap_preserves_seq_red1. eapply2 IHr.
Qed.

Lemma tuple_red1_to_seq_red: implies_red tuple_red1 seq_red .
Proof.
  red.  intros M N OR; induction OR; split_all; eapply2 succ_red;
        try eapply2 preserves_ref_seq_red;
        try eapply2 preserves_pair_seq_red;
        try eapply2 preserves_abs_seq_red;
        try eapply2 preserves_app_seq_red;
        try eapply2 preserves_aps_seq_red.
eapply2 preserves_abs_seq_red.
eapply2 swap_preserves_seq_red.
unfold lift. eapply2 lift_rec_preserves_seq_red.
Qed.

Hint Resolve tuple_red1_to_seq_red.

Lemma tuple_red_to_seq_red: implies_red tuple_red seq_red.
Proof. eapply2 to_seq_red_multi_step. Qed.

Lemma diamond_seq_red: diamond seq_red seq_red.
Proof.
red; split_all.
assert(tuple_red M N) by eapply2 seq_red_to_tuple_red.
assert(tuple_red M P) by eapply2 seq_red_to_tuple_red.
elim(tuple_parallel_confluence M N H1 P); split_all.
exist x; eapply2 tuple_red_to_seq_red.
Qed.

Theorem tuple_confluence: confluence lambda seq_red.
Proof. red. split_all. eapply2 diamond_seq_red. Qed.