Load LFindLoad.
Load LFindLoad.
From adtind Require Import goal33.

From lfind Require Import LFind.
Lemma lfind_state  (x:natural) (y:natural) (z:natural) (IHx:@eq natural (mult (plus x y) z) (plus (mult x z) (mult y z))):@eq natural (plus (mult x z) (plus z (mult y z)))
  (plus (plus (mult x z) z) (mult y z)).
Admitted.
From QuickChick Require Import QuickChick.
QCInclude "/home/yousef/lemmafinder/benchmark/_lfind_clam_lf_goal33_distrib_100_plus_assoc/".
QCInclude ".".
Extract Constant defNumTests => "50".
Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Open Scope string_scope.

Parameter print : natural -> string -> natural.
Extract Constant print => "Extract.print".
Definition collect_data  (x:natural) (y:natural) (z:natural) :=
 let lfind_var := "x:" ++ "(" ++ show x ++ ")"++ "|" ++"y:" ++ "(" ++ show y ++ ")"++ "|" ++"z:" ++ "(" ++ show z ++ ")"
 in let lfind_v := print x lfind_var
 in lfind_state lfind_v  y z.
QuickChick collect_data.
Success.


Require Import Coq.Logic.FunctionalExtensionality.
Require Import Coq.Logic.Classical_Prop.
Require Import Coq.Logic.Classical_Pred_Type.
Require Import Logic.lib.Bijection.
Require Import Logic.lib.Countable.
Require Import Logic.GeneralLogic.Base.
Require Import Logic.GeneralLogic.KripkeModel.
Require Import Logic.GeneralLogic.ProofTheory.BasicSequentCalculus.
Require Import Logic.GeneralLogic.Complete.Lindenbaum.
Require Import Logic.GeneralLogic.Complete.ContextProperty.
Require Import Logic.GeneralLogic.Complete.ContextProperty_Kripke.

Local Open Scope logic_base.
Local Open Scope kripke_model.
Import KripkeModelFamilyNotation.
Import KripkeModelNotation_Intuitionistic.

Section Completeness.

Context {L: Language}
        {Gamma: Derivable L}
        {bSC: BasicSequentCalculus L Gamma}
        {MD: Model}
        {kMD: KripkeModel MD}
        {M: Kmodel}
        {R: Relation (Kworlds M)}
        {SM: Semantics L MD}
        {kMC: Kmodel -> Prop}.

Context (cP: context -> Prop)
        (rel: bijection (Kworlds M) (sig cP)).

Hypothesis LIN_CD: forall x: expr, Lindenbaum_constructable (cannot_derive x) cP.
Hypothesis TRUTH: forall x: expr, forall m Phi, rel m Phi -> (KRIPKE: M, m |= x <-> proj1_sig Phi x).
Hypothesis CANON: kMC M.

Lemma general_completeness: strongly_complete Gamma SM (KripkeModelClass _ kMC).
Proof.
  intros.
  assert (forall Phi x, ~ Phi |-- x -> ~ consequence (KripkeModelClass _ kMC) Phi x).
  2: {
    hnf; intros.
    apply Classical_Prop.NNPP; intro; revert H0.
    apply H; auto.
  }

  intros.
  destruct (LIN_CD x _ H) as [Psi [? ?]].
  destruct (su_bij _ _ rel Psi) as [n HH].
  specialize (fun x => TRUTH x _ _ HH); clear HH.
  assert ((forall x, Phi x -> KRIPKE: M, n |= x) /\ ~ KRIPKE: M, n |= x).
  2: {
    intro.
    specialize (H3 (KRIPKE: M, n) ltac:(constructor; apply CANON)).
    tauto.
  }

  split.
  + intros.
    rewrite TRUTH.
    apply H0; auto.
  + rewrite TRUTH.
    intro; apply H1; clear H1.
    apply derivable_assum; auto.
Qed.

End Completeness.


From cgraphs.locks.lambdalockpp Require Export langdef.

(* The definition of the set of barrier references in an expression. *)
Fixpoint expr_refs e :=
  match e with
  | Val v => val_refs v
  | Var x => ∅
  | Fun x e => expr_refs e
  | App e1 e2 => expr_refs e1 ∪ expr_refs e2
  | Unit => ∅
  | Pair e1 e2 => expr_refs e1 ∪ expr_refs e2
  | LetPair e1 e2 => expr_refs e1 ∪ expr_refs e2
  | Sum i e => expr_refs e
  | MatchSum n e es => expr_refs e ∪ fin_union n (expr_refs ∘ es)
  | ForkBarrier e => expr_refs e
  | NewLock i e => expr_refs e
  | DropLock i e => expr_refs e
  | ForkLock e1 e2 => expr_refs e1 ∪ expr_refs e2
  | Acquire i e => expr_refs e
  | Release i e1 e2 => expr_refs e1 ∪ expr_refs e2
  | Wait i e => expr_refs e
  | NewGroup => ∅
  | DropGroup e => expr_refs e
  end
with val_refs v :=
  match v with
  | FunV x e => expr_refs e
  | UnitV => ∅
  | PairV v1 v2 => val_refs v1 ∪ val_refs v2
  | SumV i v => val_refs v
  | BarrierV i => {[ i ]}
  | LockGV i ls => {[ i ]}
  end.

Definition gmap_union `{Countable K} {V} `{Countable R} (f : V -> gset R) (xs : gmap K V) : gset R :=
  map_fold (λ k a s, s ∪ f a) ∅ xs.

Definition obj_refs x :=
  match x with
  | Thread e => expr_refs e
  | Barrier => ∅
  | LockG refcnt xs => gmap_union (from_option val_refs ∅ ∘ snd) xs
  end.

Inductive expr_head_waiting : expr -> nat -> Prop :=
  | Barrier_waiting j v :
    expr_head_waiting (App (Val $ BarrierV j) (Val v)) j
  | ForkLock_waiting j v ls :
    expr_head_waiting (ForkLock (Val $ LockGV j ls) (Val v)) j
  | Acquire_waiting j ls i :
    expr_head_waiting (Acquire i (Val $ LockGV j ls)) j
  | Release_waiting j v ls i :
    expr_head_waiting (Release i (Val $ LockGV j ls) (Val v)) j
  | Wait_waiting j ls i :
    expr_head_waiting (Wait i (Val $ LockGV j ls)) j
  | NewLock_waiting j ls i :
    expr_head_waiting (NewLock i (Val $ LockGV j ls)) j
  | DropLock_waiting j ls i :
    expr_head_waiting (DropLock i (Val $ LockGV j ls)) j
  | DropGroup_waiting j ls :
    expr_head_waiting (DropGroup (Val $ LockGV j ls)) j.

(* Paper definition 2 *)
Definition expr_waiting e j :=
  ∃ k e', ctx k ∧ e = k e' ∧ expr_head_waiting e' j.

Definition waiting (ρ : cfg) (i j : nat) :=
  (∃ e, ρ !! i = Some (Thread e) ∧ expr_waiting e j) ∨
  (∃ y, ρ !! j = Some y ∧ i ∈ obj_refs y ∧ ∀ e, y = Thread e -> ¬ expr_waiting e i).

(* These definitions are not explicitly given in the paper, but we factor them out in Coq *)
Definition can_step (ρ : cfg) (i : nat) := ∃ ρ', step i ρ ρ'.
Definition inactive (ρ : cfg) (i : nat) := ρ !! i = None.

(* Paper definition 3 *)
Record deadlock (ρ : cfg) (s : nat -> Prop) := {
  dl_nostep i : s i -> ¬ can_step ρ i;
  dl_waiting i j : waiting ρ i j -> s i -> s j;
}.

(* Paper definition 4 *)
Definition deadlock_free (ρ : cfg) :=
  ∀ s, deadlock ρ s -> ∀ i, s i -> inactive ρ i.

(* Paper definition 5 *)
Inductive reachable (ρ : cfg) : nat -> Prop :=
  | Can_step_reachable i :
      can_step ρ i -> reachable ρ i
  | Waiting_reachable i j :
      waiting ρ i j -> reachable ρ j -> reachable ρ i.

(* Paper definition 6 *)
Definition fully_reachable (ρ : cfg) :=
  ∀ i, inactive ρ i ∨ reachable ρ i.

(* Paper definition 8 *)
Definition global_progress (ρ : cfg) :=
  (∀ i, inactive ρ i) ∨ (∃ i, can_step ρ i).

(* Paper definition 9 *)
Definition type_safety (ρ : cfg) :=
  ∀ i, inactive ρ i ∨ can_step ρ i ∨ ∃ j, waiting ρ i j.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall A B Aprime Bprime M : Universe, ((wd_ A B /\ (wd_ Aprime Bprime /\ (wd_ B Bprime /\ (wd_ A Bprime /\ (wd_ M B /\ (wd_ M Bprime /\ (col_ A B Bprime /\ (col_ M A Aprime /\ (col_ M B Bprime /\ col_ A Aprime Bprime))))))))) -> col_ B Aprime Bprime)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import MirrorCore.Lambda.ExprCore.

Require Import ExtLib.Core.RelDec.

Require Import Charge.SetoidRewrite.AutoSetoidRewrite.
Require Import Charge.SetoidRewrite.Base.
Require Import Charge.ModularFunc.ILogicFunc.
Require Import Charge.ModularFunc.BILogicFunc.

Section BILSetoidRewrite.
  Context {typ func : Type} {HIL : ILogicFunc typ func} {HBIL : BILogicFunc typ func}.
  Context {RelDec_func : RelDec (@eq (expr typ func))}.

  Let Rbase := expr typ func.

  Definition bil_respects (e : Rbase) (_ : list (RG Rbase))
	   (rg : RG Rbase) : m (expr typ func) :=
	   match bilogicS (typ := typ) (func := expr typ func) e with
		 | Some (bilf_star l) =>
		 	 rg_bind (unifyRG (@rel_dec (expr typ func) _ _) rg
			         (RGrespects (RGinj (fEntails l))
			         (RGrespects (RGinj (fEntails l))
			         (RGinj (fEntails l)))))
				 (fun _ => rg_ret (fStar l))
		 | Some (bilf_wand l) =>
			 rg_bind (unifyRG (@rel_dec (expr typ func) _ _) rg
			                  (RGrespects (RGflip (RGinj (fEntails l)))
			                  (RGrespects (RGinj (fEntails l))
			                  (RGinj (fEntails l)))))
				 (fun _ => rg_ret (fWand l))
		 | Some (bilf_emp l) => rg_bind (unifyRG (@rel_dec (expr typ func) _ _) rg (RGinj (fEntails l)))
			 	(fun _ => rg_ret (fEmp l))
		 | _ => rg_fail
	 end.

End BILSetoidRewrite.


Require Import Coq.Setoids.Setoid.

Require Import Coq.Lists.List.
Import ListNotations.
Require Import Tactics.
Require Import Sequence.
Require Import Syntax.
Require Import Subst.
Require Import SimpSub.
Require Import Promote.
Require Import Hygiene.
Require Import Rules.
Require Import DerivedRules.
Require Defs.
Require Import Obligations.
Require Import Morphism.
Require Import DefsEquiv.
Require Import Equivalence.
Require Import Equivalences.
Require Import Dots.

Require Import Relation.
Require Import Dynamic.
Require Import ValidationUtil.

Lemma substitution_valid : substitution_obligation.
Proof.
prepare.
intros G1 G2 a b m ext1 ext0 n Hb Hm Hn.
simpsubin Hb.
simpsubin Hm.
eapply tr_substitution; eauto.
Qed.

Lemma substitutionSimple_valid : substitutionSimple_obligation.
Proof.
prepare.
intros G1 G2 a b m ext0 n Hm Hn.
simpsubin Hm.
eapply tr_substitution_simple; eauto.
Qed.

Lemma generalize_valid : generalize_obligation.
Proof.
prepare.
intros G a b m ext0 n Hm Hn.
cut (tr G (substj (dot m id) (deq n n b))).
  {
  intro H.
  simpsubin H.
  exact H.
  }
eapply tr_generalize; eauto.
Qed.

Lemma def_lett :
  forall m n,
    equiv (app (app Defs.lett m) (lam n)) (app (lam n) m).
Proof.
intros a m.
unfold Defs.lett.
eapply equiv_trans.
  {
  apply steps_equiv.
  eapply star_step.
    {
    apply step_app1.
    apply step_app2.
    }
  simpsub.
  eapply star_step.
    {
    apply step_app2.
    }
  simpsub.
  apply star_refl.
  }
apply equiv_refl.
Qed.

Lemma assert_valid : assert_obligation.
Proof.
prepare.
intros G a b m n Hm Hn.
rewrite -> def_lett.
eapply tr_pi_elim'; eauto.
  {
  apply tr_pi_intro; eauto.
  eapply tr_inhabitation_formation; eauto.
  }

  {
  simpsub.
  auto.
  }
Qed.

Lemma assert'_valid : assert'_obligation.
Proof.
prepare.
intros G a b m n Hm Hn.
cut (tr G (substj (dot m id) (deq n n (subst sh1 b)))).
  {
  intro H.
  simpsubin H.
  exact H.
  }
eapply tr_generalize; eauto.
Qed.

Lemma inhabitant_valid : inhabitant_obligation.
Proof.
prepare.
intros G a m ext0 H.
auto.
Qed.

Lemma eeqtpSymm_valid : eeqtpSymm_obligation.
Proof.
prepare.
intros G a b m H.
rewrite -> def_eeqtp in H |- *.
apply tr_prod_intro.
  {
  apply (tr_subtype_eta2 _#3 (ppi2 m) (ppi2 m)).
  eapply tr_prod_elim2; eauto.
  }

  {
  apply (tr_subtype_eta2 _#3 (ppi1 m) (ppi1 m)).
  eapply tr_prod_elim1; eauto.
  }
Qed.

Lemma weakenEqtpEeqtp_valid : weakenEqtpEeqtp_obligation.
Proof.
prepare.
intros G a b ext0 H.
rewrite -> def_eeqtp.
apply tr_prod_intro.
  {
  apply tr_subtype_intro.
    {
    eapply tr_eqtype_formation_left; eauto.
    }

    {
    eapply tr_eqtype_formation_right; eauto.
    }
  apply (tr_eqtype_convert _ _ _ (subst sh1 a)).
    {
    apply (weakening _ [_] []).
      {
      cbn [length unlift].
      simpsub.
      auto.
      }

      {
      cbn [length unlift].
      simpsub.
      auto.
      }
    cbn [length unlift].
    simpsub.
    cbn [List.app].
    auto.
    }

    {
    eapply hypothesis; eauto using index_0.
    }
  }

  {
  apply tr_subtype_intro.
    {
    eapply tr_eqtype_formation_right; eauto.
    }

    {
    eapply tr_eqtype_formation_left; eauto.
    }
  apply (tr_eqtype_convert _ _ _ (subst sh1 b)).
    {
    apply tr_eqtype_symmetry.
    apply (weakening _ [_] []).
      {
      cbn [length unlift].
      simpsub.
      auto.
      }

      {
      cbn [length unlift].
      simpsub.
      auto.
      }
    cbn [length unlift].
    simpsub.
    cbn [List.app].
    auto.
    }

    {
    eapply hypothesis; eauto using index_0.
    }
  }
Qed.

Lemma letForm_valid : letForm_obligation.
Proof.
prepare.
intros G a b m n ext1 ext0 Hm Hn.
unfold Defs.lett.
rewrite -> equiv_beta.
simpsub.
rewrite -> equiv_beta.
simpsub.
eapply tr_pi_elim'; eauto.
  {
  apply tr_pi_intro.
    {
    eapply tr_inhabitation_formation; eauto.
    }
  exact Hn.
  }

  {
  simpsub.
  auto.
  }
Qed.


From Coq Require Import Lia NArith.NArith Program.Basics.
From Equations Require Export Equations.

Obligation Tactic := idtac.

Section Context.

Import N.

Local Open Scope N_scope.

Context (f : N -> N) (mono : forall (a b : N) (l : a < b), f a < f b).

Equations f_bogus (n : N) : positive :=
  f_bogus n :=
    let m := f (succ n) - f n in
    match m with
    | N0 => _
    | Npos p => p
    end.
Next Obligation. intros n m. apply xH. Qed.

Equations f_inspect_fail (n : N) : positive :=
  f_inspect_fail n :=
    let m := f (succ n) - f n in
    match exist _ m (eq_refl m) with
    | exist _ N0 e => _
    | exist _ (Npos p) e => p
    end.
Next Obligation. intros n m _ _. Abort.

Equations f_inspect (n : N) : positive :=
  f_inspect n :=
    let m := f (succ n) - f n in
    match exist _ m (eq_refl m) with
    | exist _ N0 e => @const _ (m = N0) _ e
    | exist _ (Npos p) e => @const _ (m = Npos p) p e
    end.
Next Obligation. Abort.
Next Obligation of f_inspect_obligations.
 intros n m _ _ e. pose proof mono n (succ n) as l. lia. Qed.

End Context.


From Tweetnacl Require Import Libs.Export.
From Tweetnacl Require Import ListsOp.Export.
From Tweetnacl Require Import Low.Reduce_by_P.
From Tweetnacl Require Import Low.Car25519.
From Tweetnacl Require Import Low.Car25519_bounds.
From Tweetnacl Require Import Low.Get_abcdef.
From Tweetnacl Require Import Low.Pack.
From Tweetnacl Require Import Mid.Pack25519.
Require Import ssreflect.
(*
sv pack25519(u8 *o,const gf n)
{
  int i,j,b;
  gf m,t;
  FOR(i,16) t[i]=n[i];
  car25519(t);
  car25519(t);
  car25519(t);
  FOR(j,2) {
    m[0]=t[0]-0xffed;

    for(i=1;i<15;i++) {
      m[i]=t[i]-0xffff-((m[i-1]>>16)&1);
      m[i-1]&=0xffff;
    }

    m[15]=t[15]-0x7fff-((m[14]>>16)&1);
    b=(m[15]>>16)&1;
    m[14]&=0xffff;
    sel25519(t,m,1-b);
  }
  FOR(i,16) {
    o[2*i]=t[i]&0xff;
    o[2*i+1]=t[i]>>8;
  }
}
*)

Open Scope Z.

Definition Pack25519 l :=
  let l1 := car25519 l in
  let l2 := car25519 l1 in
  let l3 := car25519 l2 in
  let l4 := get_t (subst_select select_m_t 2 (0::0::0::0::0::0::0::0::0::0::0::0::0::0::0::0::nil) l3) in
  pack_for 8 l4.

Lemma Pack25519_mod_25519 : forall (l:list Z),
  Zlength l = 16 ->
  Forall (fun x => -2^62 < x < 2^62) l ->
  ZofList 8 (Pack25519 l) = ZPack25519 (ZofList 16 l).
Proof.
  intros l Hl Hb.
  rewrite /Pack25519 /ZPack25519.
  rewrite pack_for_correct.
  2: omega.
  change (2*8) with 16.
  rewrite subst_select_mod_P.
  repeat rewrite -car25519_ToFF_25519 ; repeat rewrite car25519_Zlength ; try reflexivity ; assumption.
  reflexivity.
  repeat rewrite car25519_Zlength ; try reflexivity ; assumption.
  apply car25519_bound ; assumption.
Qed.

Lemma Pack25519_bound : forall (l:list Z),
  Zlength l = 16 ->
  Forall (fun x => -2^62 < x < 2^62) l ->
  Forall (fun x => 0 <= x < 2^8) (Pack25519 l).
Proof.
  intros l Hl Hb.
  rewrite /Pack25519.
  apply unpack_for_bounded.
  apply get_t_subst_select_bound.
  omega.
  reflexivity.
  repeat rewrite car25519_Zlength ; try reflexivity ; assumption.
  apply car25519_bound ; assumption.
Qed.

Lemma Pack25519_Zlength : forall (l:list Z),
  Zlength l = 16 ->
  Zlength (Pack25519 l) = 32.
Proof.
  move => l Hl.
  rewrite /Pack25519.
  apply Pack.pack_for_Zlength_32_16.
  apply Reduce_by_P.get_t_subst_select_Zlength => //=.
  do 3 apply car25519_Zlength => //.
Qed.

Close Scope Z.


From Coq.ssr Require Export ssreflect.
From stdpp Require Import base vector.
From aneris_examples.crdt.gcounter_convergence Require Import vc.
From trace_program_logic.traces Require Import infinite_trace trace trace_properties.
From aneris.prelude Require Import list.

Import InfListNotations.

Notation crdt_state n := (vec (vector_clock n) n).

Section crdt_model.

  Inductive CrdtNext {n} : crdt_state n → () -> crdt_state n → Prop :=
  | IncrStep st i : CrdtNext st tt (vinsert i (vc_incr i (st !!! i)) st)
  | ApplyStep st vc i j :
      vc_le vc (st !!! j) →
      CrdtNext st tt (vinsert i (vc_merge (st !!! i) vc) st).

  Definition initial_crdt_state (n : nat) : crdt_state n :=
    vreplicate n (vreplicate n 0).

  Definition valid_crdt_state {n :nat} (st : crdt_state n) : Prop :=
    ∀ i j, (st !!! j) !!! i ≤ (st !!! i) !!! i.

  Definition crtd_state_has_converged_to
             {n : nat} (vc : vector_clock n) (st : crdt_state n) : Prop := ∀ i, st !!! i = vc.

  Definition diagonal_of_crdt_state {n} (st : crdt_state n) (vc : vector_clock n) : Prop :=
    ∀ i, (st !!! i) !!! i = vc !!! i.

  Definition crdt_states_have_same_diagonal {n : nat} (s1 s2 : crdt_state n) : Prop :=
    (∀ i, (s1 !!! i) !!! i = (s2 !!! i) !!! i).

  (* Properties *)

  Lemma valid_initial_crdt_state n : valid_crdt_state (initial_crdt_state n).
  Proof. intros i j; rewrite /initial_crdt_state !vlookup_replicate; done. Qed.

  Lemma CrdtNext_preserves_validity n (s1 s2 : crdt_state n) :
    valid_crdt_state s1 → CrdtNext s1 tt s2 → valid_crdt_state s2.
  Proof.
    intros Hv1 Hss.
    inversion Hss as [? i|? vc i j Hle]; simplify_eq.
    - intros k l.
      destruct (decide (k = i)) as [->|].
      + rewrite !vlookup_insert.
        destruct (decide (l = i)) as [->|].
        * rewrite !vlookup_insert; done.
        * rewrite (vlookup_insert_ne i l) //; auto.
      + destruct (decide (l = i)) as [->|].
        * rewrite !vlookup_insert.
          rewrite !vlookup_insert_ne; auto.
        * rewrite !vlookup_insert_ne; auto.
    - intros k l.
      destruct (decide (k = i)) as [->|].
      + rewrite !vlookup_insert.
        destruct (decide (l = i)) as [->|].
        * rewrite !vlookup_insert; done.
        * rewrite (vlookup_insert_ne i l); last by auto.
          rewrite /vc_merge vlookup_zip_with.
          etrans; last apply Max.le_max_l; auto.
      + destruct (decide (l = i)) as [->|].
        * rewrite !vlookup_insert.
          rewrite !vlookup_insert_ne; last by auto.
          rewrite /vc_merge vlookup_zip_with.
          apply Max.max_lub; first done.
          etrans; first by apply Hle.
          done.
        * rewrite !vlookup_insert_ne; auto.
  Qed.

  Lemma crdt_state_has_converged_to_preserved n (vc : vector_clock n) (s1 s2 : crdt_state n) :
    crdt_states_have_same_diagonal s1 s2 →
    CrdtNext s1 tt s2 →
    crtd_state_has_converged_to vc s1 →
    crtd_state_has_converged_to vc s2.
  Proof.
    intros Hdiag Hstep Hhc.
    inversion Hstep as [? i|? vc' i j Hle]; simplify_eq.
    - exfalso.
      specialize (Hdiag i).
      revert Hdiag.
      rewrite !vlookup_insert; lia.
    - intros k.
      rewrite (Hhc i).
      rewrite (Hhc j) in Hle.
      rewrite [vc_merge _ _]comm_L vc_merge_vc_le //.
      destruct (decide (k = i)) as [->|].
      + rewrite vlookup_insert; done.
      + rewrite vlookup_insert_ne; auto.
  Qed.

  Lemma diagonal_of_crdt_state_agree n (s1 s2 : crdt_state n) (vc : vector_clock n) :
    diagonal_of_crdt_state s1 vc →
    diagonal_of_crdt_state s2 vc →
    crdt_states_have_same_diagonal s1 s2.
  Proof. intros Hs1 Hs2 i; rewrite (Hs1 i) (Hs2 i) //. Qed.

  Lemma crtd_state_has_converged_to_has_diagonal n (vc : vector_clock n) (s : crdt_state n) :
    crtd_state_has_converged_to vc s → diagonal_of_crdt_state s vc.
  Proof. intros Hsvc i; rewrite (Hsvc i) //. Qed.

  Lemma crdt_next_vc_le n (s1 s2 : crdt_state n) :
    CrdtNext s1 tt s2 → ∀ i, vc_le (s1 !!! i) (s2 !!! i).
  Proof.
    inversion 1; intros k l; simplify_eq.
    - destruct (decide (i = k)) as [->|].
      + rewrite vlookup_insert.
        destruct (decide (l = k)) as [->|].
        * rewrite vlookup_insert; eauto.
        * rewrite vlookup_insert_ne; auto.
      + rewrite vlookup_insert_ne; auto.
    - destruct (decide (i = k)) as [->|].
      + rewrite vlookup_insert.
        apply vc_merge_le1.
      + rewrite vlookup_insert_ne //.
  Qed.

  Lemma crdt_next_bounded n (s1 s2 : crdt_state n) :
    CrdtNext s1 tt s2 → ∀ i, vc_le (s2 !!! i) (vmap S (max_vc s1)).
  Proof.
    inversion 1 as [|???? Hle]; intros k l; simplify_eq.
    - rewrite vlookup_map.
      destruct (decide (i = k)) as [->|].
      + rewrite vlookup_insert.
        destruct (decide (l = k)) as [->|].
        * rewrite vlookup_insert.
          eapply le_n_S.
          apply max_vc_le.
        * rewrite vlookup_insert_ne; last by auto.
          etrans; first apply max_vc_le; lia.
      + rewrite vlookup_insert_ne; last done.
        etrans; first apply max_vc_le; lia.
    - destruct (decide (i = k)) as [->|].
      + rewrite vlookup_insert.
        apply vc_merge_lub.
        * etrans; first apply max_vc_le.
          intros ?; rewrite vlookup_map; lia.
        * etrans; first apply Hle.
          etrans; first apply max_vc_le.
          intros ?; rewrite vlookup_map; lia.
      + rewrite vlookup_insert_ne //.
        etrans; first apply max_vc_le.
        rewrite vlookup_map; lia.
  Qed.

  Fixpoint all_crdt_states_smaller m {n} (v : vector_clock n) : list (vec (vector_clock n) m) :=
    match m with
    | O => [[#]]
    | S m' =>
      flatten
        ((λ vcs, (λ vc, vc ::: vcs) <$> all_vecs_smaller v) <$> (all_crdt_states_smaller m' v))
    end.

  Lemma elem_of_all_crdt_states_smaller m n (v : vector_clock n) vcs:
    vcs ∈ all_crdt_states_smaller m v ↔ ∀ i, vc_le (vcs !!! i) v.
  Proof.
    revert vcs.
    induction m as [|m IHm]; simpl; intros vcs.
    { split.
      - intros ? i; inversion i.
      - intros _.
        apply (Vector.case0 (λ v', v' ∈ [[# ]])).
        apply elem_of_list_singleton; done. }
    rewrite elem_of_flatten.
    setoid_rewrite elem_of_list_fmap.
    split.
    - intros (l'' & Hvcs & vc & -> & Hvc) i.
      inv_all_vec_fin; simpl in *.
      + apply elem_of_list_fmap in Hvcs as (vc' & Heq & Hvc').
        simplify_eq.
        apply elem_of_all_vecs_smaller; done.
      + apply elem_of_list_fmap in Hvcs as (vc' & Heq & Hvc').
        simplify_eq.
        apply IHm; done.
    - intros Hle.
      inv_all_vec_fin.
      eexists _; split; last first.
      + eexists _; split; first reflexivity.
        apply IHm.
        intros i.
        apply (Hle (Fin.FS i)).
      + apply elem_of_list_fmap.
        eexists _; split; first done.
        apply elem_of_all_vecs_smaller.
        apply (Hle 0%fin).
  Qed.

End crdt_model.

Section crdt_model_prop.
  Context {n : nat}.

  Notation crdt_state := (crdt_state n).
  Notation vector_clock := (vector_clock n).

  Notation crdt_fintr := (finite_trace crdt_state ()).
  Notation crdt_inftr := (inflist (() * crdt_state)).
  Notation eventually := (@eventually crdt_state).
  Notation always := (@always crdt_state).

  Definition model_trace_makes_steps (f : crdt_fintr) (inftr : crdt_inftr) : Prop :=
    always (λ f' _, trace_steps CrdtNext f') f inftr.

  Definition valid_model_trace (f :crdt_fintr) (inftr : crdt_inftr) : Prop :=
    always (λ f' _, trace_forall (@valid_crdt_state n) f' ∧
                    trace_steps (λ st _ st', st = st' ∨ CrdtNext st tt st') f') f inftr.

  Lemma model_trace_makes_steps_valid_model_trace f inftr :
    model_trace_makes_steps f inftr → valid_crdt_state (trace_first f) →
    valid_model_trace f inftr.
  Proof.
    intros Hsteps Hvl.
    assert (always (λ f' _, valid_crdt_state (trace_first f')) f inftr) as Hvl'.
    { apply always_take_drop; intros k; rewrite trace_append_list_first; done. }
    assert (always (λ f' _, valid_crdt_state (trace_first f') ∧ trace_steps CrdtNext f') f inftr)
      as Hand.
    { by apply always_and. }
    clear Hsteps Hvl Hvl'.
    revert Hand; apply always_mono.
    clear f inftr. intros f _ [Hvi Hsteps].
    induction Hsteps as [|?? [] ? <- ? _ IH]; first by split; constructor; eauto.
    destruct IH as [IH1 IH2]; first done.
    split; last by econstructor; eauto.
    constructor; first by apply IH1.
    eapply CrdtNext_preserves_validity; last by auto.
    apply trace_forall_last; done.
  Qed.

  Definition stability_point_is_reached
             (vc : vector_clock) (f :crdt_fintr) (inftr : crdt_inftr) : Prop :=
   always (λ f' _, diagonal_of_crdt_state (trace_last f') vc) f inftr.

  Definition has_converged_to
             (vc : vector_clock) (f : crdt_fintr) (inftr : crdt_inftr) : Prop :=
    crtd_state_has_converged_to vc (trace_last f).

  Definition convergence_point_is_reached
             (vc : vector_clock) (f : crdt_fintr) (inftr : crdt_inftr) : Prop :=
    always (has_converged_to vc) f inftr.

  Lemma valid_trace_remains_converged_after_stability vc f inftr :
    valid_model_trace f inftr →
    stability_point_is_reached vc f inftr →
    has_converged_to vc f inftr →
    convergence_point_is_reached vc f inftr.
  Proof.
    revert f inftr; cofix IH; intros f inftr Hvl Hstb Hhc.
    constructor; first done.
    intros [] a ? ->.
    apply IH; [by apply always_unroll|by apply always_unroll|].
    rewrite /has_converged_to.
    assert (diagonal_of_crdt_state (trace_last (f :tr[()]: a)) vc).
    { by apply always_unroll, always_holds in Hstb. }
    destruct (decide (trace_last f = a)) as [<-|]; first done.
    eapply (crdt_state_has_converged_to_preserved _ _ (trace_last f)).
    - eapply diagonal_of_crdt_state_agree; last done.
      apply crtd_state_has_converged_to_has_diagonal; done.
    - apply always_unroll, always_holds in Hvl as [? [? (?&<-&[|])]%trace_steps_step_inv]; done.
    - done.
  Qed.

  Definition will_be_merged_ij (i j : fin n) (f : crdt_fintr) (inftr : crdt_inftr) : Prop :=
    eventually (λ f' _, vc_le ((trace_last f) !!! i) ((trace_last f') !!! j)) f inftr.

  Definition fair_model_trace_ij (i j : fin n) (f : crdt_fintr) (inftr : crdt_inftr) : Prop :=
    always (λ f' inftr', will_be_merged_ij i j f' inftr') f inftr.

  Definition fair_model_trace (f : crdt_fintr) (inftr : crdt_inftr) : Prop :=
    ∀ i j, fair_model_trace_ij i j f inftr.

  Definition has_caught_up_with_for_ij
             (i j : fin n) (vc : vector_clock) (f : crdt_fintr) (inftr : crdt_inftr) : Prop :=
    ((trace_last f) !!! j) !!! i = vc !!! i.

  Definition has_caught_up_with_for_ij_strong
             (i j : fin n) (vc : vector_clock) (f : crdt_fintr) (inftr : crdt_inftr) : Prop :=
    always (has_caught_up_with_for_ij i j vc) f inftr.

  Lemma all_caught_up_crdt_state_has_converged_to vc f inftr :
    valid_model_trace f inftr →
    stability_point_is_reached vc f inftr →
    (∀ i j, has_caught_up_with_for_ij_strong i j vc f inftr) →
    convergence_point_is_reached vc f inftr.
  Proof.
    intros Hvl Hstb Hacu.
    eapply valid_trace_remains_converged_after_stability; [done|done|].
    intros i; apply vec_eq; intros j.
    specialize (Hacu j i); apply always_holds in Hacu.
    apply Hacu.
  Qed.

  Lemma has_caught_up_with_for_ij_iff_strong i j vc f inftr :
    valid_model_trace f inftr →
    stability_point_is_reached vc f inftr →
    has_caught_up_with_for_ij i j vc f inftr ↔
    has_caught_up_with_for_ij_strong i j vc f inftr.
  Proof.
    intros Hvl Hstab.
    split; last first.
    { intros ?%always_holds; done. }
    revert f inftr Hvl Hstab.
    cofix IH; intros f inftr Hvl Hstab Hhcu.
    constructor; first done.
    intros [] a ? ->.
    apply always_unroll in Hstab.
    apply always_unroll in Hvl.
    apply IH; [done|done|].
    apply always_holds in Hstab.
    apply always_holds in Hvl as [Hvl Hsteps].
    apply Nat.le_antisymm; simpl.
    - apply trace_forall_extend_inv in Hvl as [Hvl1 Hvl2].
      etrans; first apply (Hvl2 i j).
      rewrite /= in Hstab; rewrite Hstab //.
    - apply trace_steps_step_inv in Hsteps as [Hsteps1 (b & <- & [<-|Hb2])].
      + rewrite Hhcu; done.
      + etrans; last by apply crdt_next_vc_le.
        rewrite Hhcu; done.
  Qed.

  Lemma has_reached_stability_point_fair_model_eventually_catches_up_for_ij
        (i j : fin n) (vc : vector_clock) (f : crdt_fintr) (inftr : crdt_inftr) :
    valid_model_trace f inftr →
    fair_model_trace_ij i j f inftr →
    stability_point_is_reached vc f inftr →
    eventually (has_caught_up_with_for_ij_strong i j vc) f inftr.
  Proof.
    intros Hvl Hfr Hstab.
    apply always_holds in Hfr.
    assert (diagonal_of_crdt_state (trace_last f) vc) as Hdiagf.
    { apply always_holds in Hstab; done. }
    pose proof (conj Hvl Hstab) as Hvlstb; apply always_and in Hvlstb.
    eapply eventually_and_always in Hvlstb; last apply Hfr.
    revert Hvlstb; apply eventually_mono.
    simpl; clear -Hdiagf.
    intros f' inftr' [Hle Hvl].
    apply has_caught_up_with_for_ij_iff_strong.
    { eapply always_mono; last by apply Hvl. simpl; tauto. }
    { eapply always_mono; last by apply Hvl. simpl; tauto. }
    apply always_holds in Hvl as [[Hvl Hsteps] Hstab].
    rewrite /has_caught_up_with_for_ij.
    rewrite -(Hstab i).
    apply Nat.le_antisymm.
    - apply trace_forall_last in Hvl. apply Hvl.
    - etrans; last apply Hle.
      rewrite (Hstab i) (Hdiagf i); done.
  Qed.

  Lemma has_reached_stability_point_fair_model_eventually_catches_up
        (vc : vector_clock) (f : crdt_fintr) (inftr : crdt_inftr) :
    valid_model_trace f inftr →
    (∀ i j, fair_model_trace_ij i j f inftr) →
    stability_point_is_reached vc f inftr →
    eventually
      (λ f' inftr',
       valid_model_trace f' inftr' ∧
       (∀ i j, fair_model_trace_ij i j f' inftr') ∧
       stability_point_is_reached vc f' inftr' ∧
       (∀ i j, has_caught_up_with_for_ij_strong i j vc f' inftr')) f inftr.
  Proof .
    intros Hvl Hfr Hstab.
    cut
      (eventually
         (λ (f' : crdt_fintr) (inftr' : crdt_inftr),
          (always (λ f'' inftr'', (trace_forall valid_crdt_state f'' ∧
                                   trace_steps (λ st _ st', st = st' ∨ CrdtNext st tt st') f'') ∧
                                  (∀ i j, will_be_merged_ij i j f'' inftr'') ∧
                                  (diagonal_of_crdt_state (trace_last f'') vc)) f' inftr') ∧
          (always (λ f'' inftr'', ∀ i j, has_caught_up_with_for_ij i j vc f'' inftr'') f' inftr')) f
         inftr).
    { apply eventually_mono.
      simpl; clear.
      intros f' inftr' [Hal1 Hal2].
      split_and!.
      - eapply always_mono; last by apply Hal1.
        simpl; tauto.
      - intros i j; eapply always_mono; last by apply Hal1.
        simpl; by firstorder.
      - eapply always_mono; last by apply Hal1.
        simpl; tauto.
      - intros i j; eapply always_mono; last by apply Hal2.
        simpl; by firstorder. }
    apply eventually_always_combine.
    { apply holds_eventually.
      apply always_and; split; first by auto.
      apply always_and; split; last by auto.
      rewrite -always_forall; intros i.
      rewrite -always_forall; intros j.
      apply Hfr. }
    cut (eventually
           (λ f' inftr', ∀ ij, has_caught_up_with_for_ij_strong ij.1 ij.2 vc f' inftr') f inftr).
    { apply eventually_mono.
      clear. intros f inftr Hij.
      rewrite -always_forall; intros i.
      rewrite -always_forall; intros j.
      apply (Hij (i, j)). }
    apply eventually_forall_combine.
    intros [i j]; simpl.
    apply has_reached_stability_point_fair_model_eventually_catches_up_for_ij; auto.
  Qed.

  Theorem eventually_consistent (vc : vector_clock) (f : crdt_fintr) (inftr : crdt_inftr) :
    eventually valid_model_trace f inftr →
    eventually fair_model_trace f inftr →
    eventually (stability_point_is_reached vc) f inftr →
    eventually (convergence_point_is_reached vc) f inftr.
  Proof.
    intros Hvl Hfm Hstab.
    assert (eventually
              (λ f' inftr',
               valid_model_trace f' inftr' ∧
               (∀ i j, fair_model_trace_ij i j f' inftr') ∧
               stability_point_is_reached vc f' inftr') f inftr) as
    Hev.
    { eapply eventually_mono; last first.
      - apply eventually_always_combine; first apply Hstab.
        eapply (eventually_mono (λ f' inftr', always _ f' inftr' ∧ always _ f' inftr'));
          first by intros ? ?; apply always_and.
        apply eventually_always_combine; [apply Hvl|].
        eapply eventually_mono; last by apply Hfm.
        rewrite /fair_model_trace.
        intros ? ?; do 2 setoid_rewrite always_forall; eauto.
      - simpl; clear.
        intros f' inftr' [Hstab Hal].
        split.
        { eapply always_mono;last by apply Hal. simpl; tauto. }
        split; last done.
        setoid_rewrite always_forall; rewrite always_forall.
        eapply always_mono; last by apply Hal.
        simpl; tauto. }
    clear -Hev.
    assert (eventually
              (λ f' inftr',
               valid_model_trace f' inftr' ∧
               (∀ i j, fair_model_trace_ij i j f' inftr') ∧
               stability_point_is_reached vc f' inftr' ∧
               (∀ i j, has_caught_up_with_for_ij_strong i j vc f' inftr')) f inftr) as Hev'.
    { apply eventually_idemp.
      eapply eventually_mono; last by apply Hev.
      clear; simpl.
      intros f inftr (Hvl & Hfr & Hstab).
      apply has_reached_stability_point_fair_model_eventually_catches_up; auto. }
    clear Hev.
    eapply eventually_mono; last by apply Hev'.
    simpl; clear.
    intros f inftr (Hvl & Hfr & Hstab & Hcu).
    apply all_caught_up_crdt_state_has_converged_to; auto.
  Qed.

End crdt_model_prop.


Require Import String.

(* A more basic CEK machine, leaving out the heap,
   pairs, and most arithmetic operations compared to the main lambda *)

Inductive value : Set := Lam (body : exp)
  | Neutral : string -> list (value * env) -> value
  | Num : nat -> value
  | Inc : value
with exp : Set := App (f x : exp) | Var (ix : nat) | Val (v : value)
with env : Set := Env : list (value * env) -> env.

Coercion Val : value >-> exp.

Inductive cont : Set :=
    Top
  | Arg (e' : exp) (scope : env) (k : cont)
  | Fun (v' : value) (scope : env) (k : cont)
  .

Fixpoint get (ix : nat) {A} (l : list A) : option A :=
  match ix, l with
    | _, nil => None
    | O, cons v _ => Some v
    | S ix', cons _ l' => get ix' l'
  end.

Definition extend (x : value * env) (p : env) : env :=
  match p with
    | Env l => Env (x :: l)
  end.
Inductive cfg : Set := Cfg : exp -> env -> cont -> cfg.

Definition apply (f : value) (p' : env) (v : value) (p : env) : option (exp * env) :=
  match f with
    | Lam e => Some (e, extend (v,p) p')
    | Neutral head args => Some (Val (Neutral head (app args ((v,p)::nil))), p')
    | Num n => None
    | Inc => match v with
      | Num n => Some (Val (Num (S n)), p')
      | _ => None
      end
  end.

Definition step' (c : cfg) : option cfg :=
  match c with
    | Cfg (Var i) (Env p) k =>
      match get i p with
        | Some (v,p') => Some (Cfg v p' k)
        | None => None
      end
    | Cfg (App e0 e1) p k => Some (Cfg e0 p (Arg e1 p k))
    | Cfg (Val v) p (Arg e p' k) => Some (Cfg e p' (Fun v p k))
    | Cfg (Val v) p (Fun f p' k) =>
      match apply f p' v p with
      | Some (e,p'') => Some (Cfg e p'' k)
      | None => None
      end
    | Cfg (Val v) _ Top => None
    end.
Functional Scheme step'_ind := Induction for step' Sort Prop.

Inductive step : cfg -> cfg -> Prop :=
  | lookup : forall i p v p' k,
      get i p = Some (v, p') -> step (Cfg (Var i) (Env p) k) (Cfg v p' k)
  | function : forall e0 e1 p k,
      step (Cfg (App e0 e1) p k) (Cfg e0 p (Arg e1 p k))
  | argrgument : forall v p e p' k,
      step (Cfg (Val v) p (Arg e p' k)) (Cfg e p' (Fun v p k))
  | call : forall v p f p' e p'' k,
       apply f p' v p = Some (e,p'') ->
       step (Cfg (Val v) p (Fun f p' k)) (Cfg e p'' k)
  .

Lemma stepdefs :
  forall st st', step st st' <-> step' st = Some st'.
split.
destruct 1;simpl;try rewrite H;reflexivity.
functional induction (step' st);
(discriminate 1 || injection 1;clear H;intro;subst);
constructor(assumption).
Qed.

(*
  | apply_lam : forall v p e p' k,
      step (Cfg (Val v) p (Fun (Lam e) p' k)) (Cfg e (extend (v,p) p') k)
  | apply_n : forall v p head args p' k,
      step (Cfg (Val v) p (Fun (Neutral head args) p' k))
           (Cfg (Neutral head (app args ((v,p)::nil))) p' k)
  .
 *)

Inductive goes {A} (rel : A -> A -> Prop) (cfg : A) : Prop :=
  | Step : forall cfg', rel cfg cfg' -> goes rel cfg' -> goes rel cfg
  | Done : goes rel cfg.

Definition init (e : exp) : cfg := Cfg e (Env nil) Top.

Definition church (n : nat) : exp :=
  let body := fix body n : exp := match n with
    | O => Var 0
    | S n' => App (Var 1) (body n')
    end
  in Lam (Lam (body n)).

Definition church_plus :=
  Lam (Lam (Lam (Lam (App (App (Var 3) (Var 1)) (App (App (Var 2) (Var 1)) (Var 0)))))).

Goal (goes step (init
     (App (App (App (App church_plus (church 2)) (church 3)) Inc)
       (Num 0)))).
cbv [init].
Ltac tick := eapply Step;[solve[constructor(reflexivity)]|];instantiate;cbv[extend app].
repeat tick.
apply Done.
Qed.


Require Export Iron.Language.SystemF2Cap.Step.Frame.

(********************************************************************)
(* Region identifier is not mentioned some FPriv frame. *)
Fixpoint NoPrivF (p : nat) (f : frame) {struct f} :=
 match f with
 | FLet t x               => True
 | FPriv None      p1 ts  => ~(p = p1)
 | FPriv (Some p1) p2 ts  => ~(p = p1) /\ ~(p = p2)
 end.

Definition NoPrivFs (p : nat) (fs : stack)
 := Forall (NoPrivF p) fs.

Lemma noprivFs_head
 :  forall p fs f
 ,  NoPrivFs p (fs :> f)
 -> NoPrivF  p f.
Proof.
 intros. inverts H. eauto.
Qed.
Hint Resolve noprivFs_head.

Lemma noprivFs_tail
 :  forall p fs f
 ,  NoPrivFs p (fs :> f)
 -> NoPrivFs p fs.
Proof.
 intros. inverts H. eauto.
Qed.
Hint Resolve noprivFs_tail.

(********************************************************************)
(* Region identifier is not mentioned in the given stack frame. *)
Fixpoint FreshF (p : nat) (ff : frame) {struct ff} :=
 match ff with
 | FLet  t x              => FreshT p t /\ FreshX p x
 | FPriv None      p2 ts  => ~(p = p2)
 | FPriv (Some p1) p2 ts  => ~(p = p1)  /\ ~(p = p2)
 end.

(* Region identifier is not mentioned in the given stack.  *)
Definition FreshFs (p : nat) (fs : stack)
 := Forall (FreshF p) fs.
Hint Unfold FreshFs.

Lemma freshFs_head
 :  forall p f fs
 ,  FreshFs p (fs :> f)
 -> FreshFs p fs.
Proof. intros. inverts H. eauto. Qed.
Hint Resolve freshFs_head.

Lemma freshFs_tail
 :  forall p f fs
 ,  FreshFs p (fs :> f)
 -> FreshF  p f.
Proof. intros. inverts H. eauto. Qed.
Hint Resolve freshFs_tail.

Lemma freshFs_cons
 :  forall p f fs
 ,  FreshFs p fs -> FreshF p f
 -> FreshFs p (fs :> f).
Proof. snorm. Qed.
Hint Resolve freshFs_cons.

Lemma freshF_noprivF
 : forall p f
 , FreshF p f -> NoPrivF p f.
Proof.
 intros.
 destruct f.
 - snorm.
 - destruct o; snorm.
Qed.
Hint Resolve freshF_noprivF.

Lemma freshFs_noprivFs
 : forall  p fs
 , FreshFs p fs -> NoPrivFs p fs.
Proof.
 intros.
 induction fs.
 - unfold NoPrivFs. eauto.
 - unfold NoPrivFs. inverts H. firstorder.
Qed.
Hint Resolve freshFs_noprivFs.

(*********************************************************************)
(* Region identifier is not mentioned in the types of the free variables
   of the given stack frame. *)
Fixpoint   FreshFreeF (p : nat) (te : tyenv) (f : frame) {struct f} :=
 match f with
 | FLet t x     => FreshFreeX p (te :> t) x
 | FPriv _ _ _  => True
 end.

(* Region identifier is not mentioned in the types of the free variables
   of the given stack. *)
Definition FreshFreeFs (p : nat) (te : tyenv) (fs : stack)
 := Forall (FreshFreeF p te) fs.
Hint Unfold FreshFreeFs.

Lemma freshFreeF_nil
 :  forall p f
 ,  FreshF p f
 -> FreshFreeF p nil f.
Proof.
 intros.
 destruct f; snorm.
Qed.
Hint Resolve freshFreeF_nil.

Lemma freshFreeFs_nil
 :  forall p fs
 ,  FreshFs p fs
 -> FreshFreeFs p nil fs.
Proof.
 intros.
 induction fs; eauto.
 inverts H. rip.
Qed.
Hint Resolve freshFreeFs_nil.

Lemma freshFreeFs_tail
 :  forall p te fs f
 ,  FreshFreeFs p te (fs :> f)
 -> FreshFreeFs p te fs.
Proof.
 intros.
 inverts H. auto.
Qed.
Hint Resolve freshFreeFs_tail.

(********************************************************************)
(* Region identifier is not mentioned in the types of the locations
   used in the given stack frame. *)
Fixpoint  FreshSuppF   (p : nat) (se : stenv) (f : frame) {struct f} :=
 match f with
 | FLet  t x      => FreshSuppX p se x
 | FPriv _ _ _    => True
 end.

(* Region identifier is not mentioned in the types of the locations
   used in the given stack. *)
Definition FreshSuppFs p2 se fs
 := Forall (FreshSuppF p2 se) fs.
Hint Unfold FreshSuppFs.

Lemma freshSuppFs_tail
 :  forall p te fs f
 ,  FreshSuppFs p te (fs :> f)
 -> FreshSuppFs p te fs.
Proof.
 intros.
 inverts H. auto.
Qed.
Hint Resolve freshSuppFs_tail.

Lemma freshSuppFs_head
 :  forall p te fs f
 ,  FreshSuppFs p te (fs :> f)
 -> FreshSuppF  p te f.
Proof.
 intros.
 inverts H. auto.
Qed.
Hint Resolve freshSuppFs_head.

Lemma freshSuppF_mergeTE
 :  forall p1 p2 p3 te f
 ,  FreshSuppF p1 te f
 -> FreshSuppF p2 te f
 -> FreshSuppF p2 (mergeTE p3 p1 te) f.
Proof.
 intros.
 destruct f.
 - snorm.
   eapply freshSuppX_mergeTE; auto.
 - eauto.
Qed.

Lemma freshSuppFs_mergeTE
 :  forall p1 p2 p3 te fs
 ,  FreshSuppFs p1 te fs
 -> FreshSuppFs p2 te fs
 -> FreshSuppFs p2 (mergeTE p3 p1 te) fs.
Proof.
 intros.
 unfold FreshSuppFs in *.
 induction fs; auto.
 inverts H.
 inverts H0. rip.
 eapply Forall_cons; auto.
 eapply freshSuppF_mergeTE; auto.
Qed.


(*---------------------------------------------------------------------------
    This file axiomatises the inference rules of an intuitionistic logic and
    offers some parametric instances to make it straightforward to create a new
    logic that satisfies those axioms. The purpose is to factor out what the
    assertion logic and specification logic of a separation logic framework
    have in common.
  ---------------------------------------------------------------------------*)
Require Import Setoid Morphisms RelationClasses Program.Basics Omega.

Set Implicit Arguments.
Unset Strict Implicit.
Set Maximal Implicit Insertion.

(* The natural numbers in descending order. *)
Global Instance ge_Pre: PreOrder ge.
Proof. repeat constructor. hnf. eauto with arith. Qed.

(* These tactics are meant to relieve the user from remembering morphism names.
   In most cases they will apply the most general morphism for the arity
   requested. *)
(* TODO: move this somewhere more general. *)
Ltac postcancel := unfold Basics.flip; trivial.
Ltac cancel1 :=
  apply (proper_prf (Proper := _: Proper (_ ==> _) _));
  postcancel.
Ltac cancel2 :=
  apply (proper_prf (Proper := _: Proper (_ ==> _ ==> _) _));
  postcancel.
Ltac cancel3 :=
  apply (proper_prf (Proper := _: Proper (_ ==> _ ==> _ ==> _) _));
  postcancel.

Class Inhabited A := { cinhabited : inhabited A}.

Instance inhabitedNat: Inhabited nat. Proof. split; split; apply 0. Qed.
Instance inhabitedBool: Inhabited bool. Proof. split; split; apply true. Qed.

Definition Frm := Type.

(* Logical connectives *)
Class ILogicOps (A : Frm) := {
  lentails: relation A;
  ltrue: A;
  lfalse: A;
  limpl: A -> A -> A;
  land: A -> A -> A;
  lor: A -> A -> A;
  lforall: forall {T}, (T -> A) -> A;
  lexists: forall {T}, (T -> A) -> A
}.

(* These notations have to sit strictly between level 80 (precendence of /\)
   and level 70 (precedence of =). *)
Infix "|--"  := lentails (at level 80, no associativity).
Infix "//\\"   := land (at level 75, right associativity).
Infix "\\//"   := lor (at level 76, right associativity).
Infix "-->>"   := limpl (at level 77, right associativity).
Notation "'Forall' x : T , p" :=
  (lforall (fun x : T => p)) (at level 78, x ident, right associativity).
Notation "'Forall' x , p" :=
  (lforall (fun x => p)) (at level 78, x ident, right associativity, only parsing).
Notation "'Exists' x : T , p" :=
  (lexists (fun x : T => p)) (at level 78, x ident, right associativity).
Notation "'Exists' x , p" :=
  (lexists (fun x => p)) (at level 78, x ident, right associativity, only parsing).

Section ILogicEquiv.
  Context {A : Frm} `{IL: ILogicOps A}.

  Definition lequiv P Q := P |-- Q /\ Q |-- P.
End ILogicEquiv.

Infix "-|-"  := lequiv (at level 85, no associativity).

(* Axioms of an intuitionistic logic, presented in a sequent calculus style
   with singleton contexts on the left of the turnstile. This form is
   particularly suited for the undisciplined context manipulation that tends to
   happen in separation logic.

   Every connective has a number of L-rules and a number of R-rules describing
   what can be done to prove a goal that has the connective as the head symbol
   of the left, respectively right, side of a turnstile. The notable exception
   to this pattern is implication, which is required to be the right adjoint of
   conjunction. This makes singleton contexts work. *)
Class ILogic Frm {ILOps: ILogicOps Frm} := {
  lentailsPre:> PreOrder lentails;
  ltrueR: forall C, C |-- ltrue;
  lfalseL: forall C, lfalse |-- C;
  lforallL: forall T x (P: T -> Frm) C, P x |-- C -> lforall P |-- C;
  lforallR: forall T (P: T -> Frm) C, (forall x, C |-- P x) -> C |-- lforall P;
  lexistsL: forall T (P: T -> Frm) C, (forall x, P x |-- C) -> lexists P |-- C;
  lexistsR: forall T x (P: T -> Frm) C, C |-- P x -> C |-- lexists P;
  landL1: forall P Q C, P |-- C  ->  P //\\ Q |-- C;
  landL2: forall P Q C, Q |-- C  ->  P //\\ Q |-- C;
  lorR1:  forall P Q C, C |-- P  ->  C |-- P \\// Q;
  lorR2:  forall P Q C, C |-- Q  ->  C |-- P \\// Q;
  landR:  forall P Q C, C |-- P  ->  C |-- Q  ->  C |-- P //\\ Q;
  lorL:   forall P Q C, P |-- C  ->  Q |-- C  ->  P \\// Q |-- C;
  landAdj: forall P Q C, C |-- (P -->> Q) -> C //\\ P |-- Q;
  limplAdj: forall P Q C, C //\\ P |-- Q -> C |-- (P -->> Q)
}.
Implicit Arguments ILogic [[ILOps]].
Implicit Arguments lforallL [[ILOps] [Frm] [ILogic] [T] [P] [C]].
Implicit Arguments lexistsR [[ILOps] [Frm] [ILogic] [T] [P] [C]].

Notation "|--  P" := (ltrue |-- P) (at level 85, no associativity).
Hint Extern 0 (?x |-- ?x) => reflexivity.
Hint Extern 0 (_ |-- ltrue) => apply ltrueR.
Hint Extern 0 (lfalse |-- _) => apply lfalseL.
Hint Extern 0 (?P |-- ?Q) => (is_evar P; reflexivity) || (is_evar Q; reflexivity).

Section ILogicEquiv2.
  Context {A : Frm} `{IL: ILogic A}.

  Global Instance lequivEquivalence : Equivalence lequiv.
  Proof.
    unfold lequiv. constructor; red.
    + split; reflexivity.
    + intuition.
    + intros P Q R [HPQ HQP] [HQR HRQ];
      split; etransitivity; eassumption.
  Qed.

End ILogicEquiv2.

(* Most of the connectives in ILogicOps are redundant. They can be derived from
   lexists, lforall and limpl, and the choice of limpl is unique up to lequiv
   since it is an adjoint. *)

Section ILogicEquivOps.
  Context {A : Frm} `{IL: ILogic A}.

  Lemma land_is_forall P Q :
    P //\\ Q -|- Forall b : bool, if b then P else Q.
  Proof.
    split.
    - apply lforallR; intro x; destruct x.
      + apply landL1; reflexivity.
      + apply landL2; reflexivity.
    - apply landR.
      + apply lforallL with true; reflexivity.
      + apply lforallL with false; reflexivity.
  Qed.

  Lemma lor_is_exists P Q:
    P \\// Q -|- Exists b : bool, if b then P else Q.
  Proof.
    split.
    - apply lorL.
      + apply lexistsR with true; reflexivity.
      + apply lexistsR with false; reflexivity.
    - apply lexistsL; intro x; destruct x.
      + apply lorR1; reflexivity.
      + apply lorR2; reflexivity.
  Qed.

  Lemma ltrue_is_forall:
    ltrue -|- Forall x: Empty_set, Empty_set_rect _ x.
  Proof.
    split; [apply lforallR|]; intuition.
  Qed.

  Lemma lfalse_is_exists:
    lfalse -|- Exists x: Empty_set, Empty_set_rect _ x.
  Proof. split; [|apply lexistsL]; intuition. Qed.

End ILogicEquivOps.

Section ILogicMorphisms.
  Context {A : Frm} `{IL: ILogic A}.

  Global Instance lequiv_lentails : subrelation lequiv lentails.
  Proof. firstorder. Qed.
  Global Instance lequiv_inverse_lentails: subrelation lequiv (inverse lentails).
  Proof. firstorder. Qed.

  Global Instance lforall_lentails_m T:
    Proper (pointwise_relation T lentails ++> lentails) lforall.
  Proof.
    intros P P' HP. apply lforallR; intro x;  apply lforallL with x.
    rewrite HP; reflexivity.
  Qed.

  Global Instance lforall_lequiv_m T:
    Proper (pointwise_relation T lequiv ++> lequiv) lforall.
  Proof.
    intros P P' HP; split; apply lforall_lentails_m; intro x; apply HP.
  Qed.

  Global Instance lexists_lentails_m T:
    Proper (pointwise_relation T lentails ++> lentails) lexists.
  Proof.
    intros P P' HP. apply lexistsL; intro x; apply lexistsR with x.
    rewrite HP; reflexivity.
  Qed.

  Global Instance lexists_lequiv_m T:
    Proper (pointwise_relation T lequiv ++> lequiv) lexists.
  Proof.
    intros P P' HP; split; apply lexists_lentails_m; intro x; apply HP.
  Qed.

  Global Instance : Proper (lequiv ==> lequiv ==> iff) lequiv.
  Proof.
    intros P P' HP Q Q' HQ; split; intros H.
    + rewrite <- HP; rewrite <- HQ; assumption.
    + rewrite HP; rewrite HQ; assumption.
  Qed.

  Global Instance lequiv_lentails_m : Proper (lequiv ==> lequiv ==> iff) lentails.
  Proof.
    cbv; intuition; (etransitivity; [etransitivity|]); eassumption.
  Qed.

  Global Instance lentails_lentails_m: Proper (lentails --> lentails ++> impl) lentails.
  Proof.
    intuition.
  Qed.

  Global Instance land_lentails_m:
    Proper (lentails ++> lentails ++> lentails) land.
  Proof.
    intros P P' HP Q Q' HQ.
    apply landR; [apply landL1 | apply landL2]; assumption.
  Qed.

  Global Instance land_lequiv_m:
    Proper (lequiv ==> lequiv ==> lequiv) land.
  Proof.
    intros P P' HP Q Q' HQ.
    split; apply land_lentails_m; (apply HP || apply HQ).
  Qed.

  Global Instance lor_lentails_m:
    Proper (lentails ++> lentails ++> lentails) lor.
  Proof.
    intros P P' HP Q Q' HQ.
    apply lorL; [apply lorR1 | apply lorR2]; assumption.
  Qed.

  Global Instance lor_lequiv_m:
    Proper (lequiv ==> lequiv ==> lequiv) lor.
  Proof.
    intros P P' HP Q Q' HQ.
    split; apply lor_lentails_m; (apply HP || apply HQ).
  Qed.

  Global Instance limpl_lentails_m:
    Proper (lentails --> lentails ++> lentails) limpl.
  Proof.
    intros P P' HP Q Q' HQ; red in HP.
    apply limplAdj; rewrite <- HQ, HP; apply landAdj; reflexivity.
  Qed.

  Global Instance limpl_lequiv_m:
    Proper (lequiv ==> lequiv ==> lequiv) limpl.
  Proof.
    intros P P' HP Q Q' HQ.
    split; apply limpl_lentails_m; (apply HP || apply HQ).
  Qed.

End ILogicMorphisms.

Hint Extern 0 (?x -|- ?x) => reflexivity.
Hint Extern 0 (?P -|- ?Q) => (is_evar P; reflexivity) || (is_evar Q; reflexivity).

(* TODO: also add lforwardR. *)
Lemma lforwardL {Frm} `{IL: ILogic Frm} {Q R}:
    Q |-- R -> forall P G,
    P |-- Q ->
    (P |-- R -> G) ->
    G.
Proof. intros HQR ** HPQ HG. apply HG. etransitivity; eassumption. Qed.

Tactic Notation "lforwardL" hyp(H) :=
  eapply (lforwardL H); clear H; [|intros H].

Section ILogicFacts.
  Context {A : Frm} `{IL: ILogic A}.

  (* Experiments with proof search. *)
  Ltac landR :=
    repeat match goal with
    | |- _ |-- _ //\\ _ => apply landR
    end.

  Ltac landL :=
    repeat match goal with
    | |- ?L1 //\\ ?L2 |-- ?R =>
        match L1 with
        | context [R] => apply landL1
        | _ =>
          match L2 with
          | context [R] => apply landL2
          end
        end
    end.

  Lemma landC P Q: P //\\ Q -|- Q //\\ P.
  Proof. split; landR; landL; reflexivity. Qed.

  Lemma landA P Q R: (P //\\ Q) //\\ R -|- P //\\ (Q //\\ R).
  Proof. split; landR; landL; reflexivity. Qed.

  Lemma lorC P Q : P \\// Q -|- Q \\// P.
  Proof.
    split; apply lorL; [apply lorR2 | apply lorR1 | apply lorR2 | apply lorR1]; reflexivity.
  Qed.

  Lemma lorA P Q R : (P \\// Q) \\// R -|- P \\// (Q \\// R).
  Proof.
  	split; apply lorL; try apply lorL; [
  	   apply lorR1 |
       apply lorR2; apply lorR1 |
       apply lorR2; apply lorR2 |
       apply lorR1; apply lorR1 |
       apply lorR1; apply lorR2 |
       apply lorR2
     ]; reflexivity.
   Qed.

  (* Special case of limplAdj/landAdj when there is just ltrue on the lhs *)
  Lemma limplValid P Q:
    |-- P -->> Q <->
    P |-- Q.
  Proof.
    split; intro H.
    - etransitivity; [eapply landR; [apply ltrueR|reflexivity]|].
      apply landAdj; assumption.
    - apply limplAdj. apply landL2; assumption.
  Qed.

  (* Left-rule for limpl. This breaks the discipline of the ILogic presentation
     since the implication is not strictly the top symbol of the left-hand side,
     but it remains a convenient rule. *)
  Lemma limplL P Q CL CR (HP: CL |-- P) (HR: Q //\\ CL |-- CR) :
    (P -->> Q) //\\ CL |-- CR.
  Proof.
    rewrite <-HR, <-HP. apply landR; [apply landAdj |apply landL2]; reflexivity.
  Qed.

  Lemma limplAdj2 P Q R : P -->> Q -->> R -|- P //\\ Q -->> R.
  Proof.
  	split.
  	+ apply limplAdj. do 2 (apply limplL; [landL; reflexivity|]).
  	  landL. reflexivity.
    + do 2 apply limplAdj; rewrite landA.
      apply limplL; [reflexivity | landL; reflexivity].
  Qed.

  Lemma landexistsDL {T} (f : T -> A) (P : A) :
    (Exists a, f a) //\\ P |-- Exists a, (f a //\\ P).
  Proof.
    apply landAdj; apply lexistsL; intro a;
    apply limplAdj; apply lexistsR with a; reflexivity.
  Qed.

  Lemma landexistsDR {T} (f : T -> A) (P : A) :
     Exists a, (f a //\\ P) |-- (Exists a, f a) //\\ P.
  Proof.
    apply lexistsL; intro a; apply landR.
    - apply landL1; apply lexistsR with a; reflexivity.
    - apply landL2; reflexivity.
  Qed.

  Lemma landexistsD {T} (f : T -> A) (P : A) :
    (Exists a, f a) //\\ P -|- Exists a, (f a //\\ P).
  Proof.
    split; [apply landexistsDL | apply landexistsDR].
  Qed.

  Lemma lorexistsDL {T} (f : T -> A) (P : A) {H : Inhabited T} :
    (Exists a, f a) \\// P |-- Exists a, (f a \\// P).
  Proof.
  	apply lorL.
	+ apply lexistsL; intro x; apply lexistsR with x; apply lorR1; reflexivity.
	+ destruct H as [[x]]; apply lexistsR with x; apply lorR2; reflexivity.
  Qed.

  Lemma lorexistsDR {T} (f : T -> A) (P : A) :
     Exists a, (f a \\// P) |-- (Exists a, f a) \\// P.
  Proof.
  	apply lexistsL; intro x; apply lorL.
  	+ apply lorR1; apply lexistsR with x; reflexivity.
  	+ apply lorR2; reflexivity.
  Qed.

  Lemma lorexistsD {T} (f : T -> A) (P : A) {H : Inhabited T} :
    (Exists a, f a) \\// P -|- Exists a, (f a \\// P).
  Proof.
    split; [apply lorexistsDL; apply H| apply lorexistsDR].
  Qed.

  Lemma landforallDL {T} (f : T -> A) (P : A) :
    (Forall a, f a) //\\ P |-- Forall a, (f a //\\ P).
  Proof.
    apply lforallR; intro a; apply landR.
    + apply landL1; apply lforallL with a; reflexivity.
    + apply landL2; reflexivity.
  Qed.

  Lemma landforallDR {T} {H: Inhabited T} (f : T -> A) (P : A) :
    Forall a, (f a //\\ P) |-- (Forall a, f a) //\\ P.
  Proof.
    apply landR.
    + apply lforallR; intro a; apply lforallL with a; apply landL1; reflexivity.
    + destruct H as [[a]]. apply lforallL with a; apply landL2; reflexivity.
  Qed.

  Lemma landforallD {T} (f : T -> A) (P : A) {H : Inhabited T} :
    (Forall a, f a) //\\ P -|- Forall a, (f a //\\ P).
  Proof.
  	split; [apply landforallDL | apply landforallDR].
  Qed.

  Lemma lorforallDL {T} (f : T -> A) (P : A) :
    (Forall a, f a) \\// P |-- Forall a, (f a \\// P).
  Proof.
  	apply lforallR; intro a; apply lorL.
  	+ apply lforallL with a; apply lorR1; reflexivity.
  	+ apply lorR2; reflexivity.
  Qed.

  Lemma limplTrue P : ltrue -->> P -|- P.
  Proof.
    split.
    + transitivity ((ltrue -->> P) //\\ ltrue).
      apply landR; [reflexivity | apply ltrueR].
      apply limplL; [apply ltrueR| apply landL1; reflexivity].
    + apply limplAdj; apply landL1; reflexivity.
  Qed.

  Lemma limplexistsE {T : Type} (P : T -> A) (Q : A) :
    (Exists x, P x) -->> Q -|- Forall x, (P x -->> Q).
  Proof.
    split.
	+ apply lforallR; intro x. apply limplAdj; apply limplL.
	  * apply lexistsR with x; reflexivity.
	  * apply landL1; reflexivity.
	+ apply limplAdj. rewrite landC, landexistsDL.
	  apply lexistsL; intro x. rewrite landC, landforallDL.
	  apply lforallL with x. apply limplL.
	  * reflexivity.
	  * apply landL1. reflexivity.
  Qed.

  Lemma limplforallER {T : Type} (P : T -> A) (Q : A) :
    Exists x, (P x -->> Q) |-- (Forall x, P x) -->> Q.
  Proof.
  	apply lexistsL; intro x. apply limplAdj. apply limplL.
  	+ apply lforallL with x. reflexivity.
  	+ apply landL1. reflexivity.
  Qed.

  (* The following two lemmas have an explicit forall to help unification *)

  Lemma lforallR2 {T : Type} (P : A) (Q : T -> A) (H : P |-- lforall Q) :
  	forall x, P |-- Q x.
  Proof.
    intro x; rewrite H. apply lforallL with x; reflexivity.
  Qed.

  Lemma lexistsL2 {T : Type} (P : T -> A) (Q : A) (H : lexists P |-- Q) :
  	forall x, P x |-- Q.
  Proof.
    intro x; rewrite <- H. apply lexistsR with x; reflexivity.
  Qed.

  Lemma landtrueL : forall a, ltrue //\\ a -|- a.
  Proof.
    intros. split. eapply landL2. reflexivity. apply landR; eauto.
  Qed.

  Lemma landtrueR : forall a, a //\\ ltrue -|- a.
  Proof.
    intros. split. eapply landL1. reflexivity. apply landR; eauto.
  Qed.

  Lemma curry : forall a b c, (a //\\ b) -->> c -|- a -->> (b -->> c).
  Proof.
    clear - IL.
    intros.
    split.
    { eapply limplAdj.
      eapply limplAdj.
      rewrite landA.
      eapply landAdj.
      reflexivity. }
    { eapply limplAdj.
      rewrite <- landA.
      eapply landAdj.
      eapply landAdj. reflexivity. }
  Qed.

End ILogicFacts.

(* Prop is an intuitionistic logic *)
Global Instance ILogicOps_Prop : ILogicOps Prop := {|
  lentails P Q := P -> Q;
  ltrue        := True;
  lfalse       := False;
  limpl    P Q := P -> Q;
  land     P Q := P /\ Q;
  lor      P Q := P \/ Q;
  lforall  T F := forall x:T, F x;
  lexists  T F := exists x:T, F x
|}.

Global Instance ILogic_Prop : ILogic Prop.
Proof.
  split; cbv; firstorder.
Qed.

(* Make the setoid system realize that these are the same things (in the
   direction that seems useful. *)
Instance: subrelation lentails Basics.impl.
Proof. reflexivity. Qed.

Instance: subrelation lequiv iff.
Proof. reflexivity. Qed.


(* Dynamic.v- Attempting to nail down some of the dynamic elements of CHS *)

Load Vect.

Definition tud : forall (m : nat) (u : Vect statterm m), HetVect m u -> Set
    :=  fun (m : nat) (u : Vect statterm m) (h : HetVect m u) =>
        {n : nat & {v : Vect statterm n & {h' : HetVect n v | h' isSubHetVectof h}}}.

Definition con : forall n : nat, Vect statterm n -> Set
    :=  fun (n : nat) (v : Vect statterm n) => forall h : HetVect n v, prop * (tud n v h).

Definition kon : forall m : nat, Vect statterm m -> Set
    :=  fun (m : nat) (u : Vect statterm m) => forall (n : nat) (v : Vect statterm n), con n v -> con (m + n) (u ++ v).

(* Given any HetVect h, returns an empty tud stack [hnil_bot is defined in Vect.v] *)
Definition empty_tud : forall {n : nat} {v : Vect statterm n} (h : HetVect n v), tud n v h
    :=  fun (n : nat) (v : Vect statterm n) (h : HetVect n v) =>
        existT  (fun i : nat => {l : Vect statterm i & {h' : HetVect i l | h' isSubHetVectof h}})
                0
                (existT (fun l : Vect statterm 0 => {h' : HetVect 0 l | h' isSubHetVectof h})
                        []
                        (exist (fun h' : HetVect 0 [] => h' isSubHetVectof h) hnil (hnil_bot h))).

(*  For the moment, the returned TUD stack is just that generated from k;
    need to figure out how to combine it with the TUD stack from c *)
(* Types didn't seem to work out in an obvious way *)
Definition cc : forall {m : nat} {u : Vect statterm m}, kon m u -> kon m u
    :=  fun (m : nat) (u : Vect statterm m) (k : kon m u) (n : nat) (v : Vect statterm n) (c : con n v) (h : HetVect (m+n) (u ++ v)) =>
        let (h1,h2) := (hsplit_at h) in
        let (p,t)   := (c h2) in
        let (q,t')  := (k n v c h) in
        (p and q,t').

(* new cc : pair of conjunction of prop args, then append kon tud onto con tud *)
(* define AND as well *)

(* since (h AND k) is usually taken to mean that h precedes k, typing AND s.t. k'r DR's are on top
 [hence the variable flip in the return type] *)
(* Oh yeah- so fun thing about formalizing AND is dealing with some of the associativity issues related to +/++/+++ *)
(* Definition d_AND : forall {m n : nat} {u : Vect statterm m} {v : Vect statterm n}, kon m u -> kon n v -> kon (n+m) (v++u)
    :=  fun (m n : nat) (u : Vect statterm m) (v : Vect statterm n) (h : kon m u) (k : kon n v) (j : nat) (w : Vect statterm j)
            (c : con j w) (hv : HetVect ((n + m) + j) ((v ++ u) ++ w)) =>
        let (a,r) := (hsplit_at hv) in
        let (l1,l2) := (hsplit_at a) in
        let (p,t) := (h j w c (l2 +++ r)) in
        let (q,t0) := (k (m + j) (u ++ w) (cc h j w c) (l1 +++ (l2 +++ r))) in
        (p and q, ?FOO).
        ?FOO : tud ((n+m)+j) ((v ++ u) ++ w) hv *)
        (* can't figure this out exactly right now… *)

(* NOT only applies assertions, not questions *)
(* ie kon's with empty tud *)
(* future work though- just model off Carl and Scott's paper *)
(* Decided to make the return tud be empty- we can always change that behavior later if we want to *)
Definition NOT : forall {m : nat} {u : Vect statterm m}, kon m u -> kon 0 []
    :=  fun (m : nat) (u : Vect statterm m) (k : kon m u) (n : nat) (v : Vect statterm n) (c : con n v) (h : HetVect n v) =>
        (not (hexists (fun h' : HetVect m u => fst (k n v c (h' +++ h)))),empty_tud h).


(*common header begin*)
Require Import Utf8.
From Coq Require Import ssreflect ssrfun ssrbool.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.
Set Maximal Implicit Insertion.

Require Import List.
Import ListNotations.
(*common header end*)

Require Import Seq.

Require Import Formula.
Require Import Term.

Require Import Omega.

Require Import ListFacts.
Require Import UserTactics.

Require Import Derivation.
Require Import Encoding.

(*simplifies assumptions In (x, phi) (Γ_all rs bound i), In t phi*)
Ltac inspect_in_Γ :=
  gimme In where Γ_all; autorewrite with lookup_Γ;
  (firstorder (subst; try done));
  gimme (@In formula); autorewrite with in_formula';
  (firstorder (subst; try done)).

(*only s_rule can be used deriving a type with two parameters for a normal form*)
Lemma two_params_rule : forall (rs : list rule) (bound n i: nat) (N : term) (phi psi : formula') (s : formula),
  head_form N ->
  derivation n (Γ_all rs bound i) N (arr phi (arr psi s)) ->
  (exists (i : nat) (r : rule) (e : nat), In (i, r) (indexed 0 rs) /\ N = free_var (x_rule i) /\
    (phi = isl \/ phi = isr \/ phi = bullet) /\ s = symbol e).
Proof.
move => rs bound n i.
elim /lt_wf_ind : n.
move => n IH; intros *.
inversion; inversion.
{
inspect_in_Γ.
all: gimme @eq; case; intros; subst.
all: (do 3 eexists); firstorder eassumption.
}
(*use IH*)
exfalso.
gimme derivation. move /IH.
move /(_ ltac:(omega)).
firstorder done.
Qed.

Lemma invert_pos : forall (rs : list rule) (N : term) (bound n i : nat) (t : formula),
  normal_form N -> (t = isl \/ t = isr \/ t = bullet) -> derivation n (Γ_all rs bound i) N t ->
  exists (j : nat), In j (seq 0 bound) /\ N = free_var (y_pos j).
Proof.
intros *; case; first last.
intros; gimme derivation; inversion; firstorder done.

move => {N} N.
case.
{ (*actual case*)
move => ? ?; inversion.
all: inspect_in_Γ.
}

intros; gimme derivation; inversion.
move => {N} N N2.
case.
{ (*one argument case*)
intros; exfalso; do 2 (gimme derivation; inversion).
inspect_in_Γ.
}
intros; do 2 (gimme derivation; inversion).
intros; exfalso;
do 2 (gimme derivation; inversion).
gimme derivation; move /two_params_rule.
firstorder (by subst).
Qed.

(*a symbol is derived only using x_rule or x_1*)
Lemma term_1 : forall (rs : list rule) (n bound e : nat) (N : term),
  normal_form N ->
  derivation n (Γ_all rs bound 0) N (symbol e) ->
  (exists (i j : nat) (r : rule) (M : term),
    In (i, r) (indexed 0 rs) /\ In j (seq 0 bound) /\
    N = term_app (term_app (free_var (x_rule i)) (free_var (y_pos j))) M)
  \/ (N = free_var x_1).
Proof.
intros *.
case; last (intros; gimme derivation; inversion).
move => {N} N.
case.
{ (*N = x_1*)
move => {N} x.
inversion.
right.
inspect_in_Γ.
gimme @eq.
match goal with [|- context[if ?P then _ else _]] => case : P; inversion end.
}
intros *; by inversion.

move => {N} N N2.
case.
{ (*x N1 not possible*)
intros; exfalso.
do 2 (gimme derivation; inversion).
inspect_in_Γ.
}
{ (*head is bound*)
intros; do 2 (gimme derivation; inversion).
}
{ (*actual case M N1 N2*)
move => {N} N N1.
intros.
left.
do 2 (gimme derivation; inversion).
gimme derivation. move /two_params_rule.
nip; auto.

firstorder subst.
all: gimme Forall; inversion.
all: gimme derivation; move /invert_pos.
all: firstorder (subst).
all: do 4 eexists; eauto.
}
Qed.

Lemma dollar_not_in_Γ_all : forall (rs : list rule) (x : label) (phi : formula') (bound : nat),
  @In formula dollar phi -> In (x, phi) (Γ_all rs bound (1 + bound)) -> False.
Proof.
intros.
inspect_in_Γ.
gimme where dollar.
match goal with [|- context[if ?P then _ else _]] => case : P; first inversion end.
match goal with [|- context[if ?P then _ else _]] => case : P; inversion end.
Qed.

Lemma triangle_not_in_Γ_all : forall (rs : list rule) (x : label) (phi : formula') (bound : nat),
  @In formula triangle phi -> In (x, phi) (Γ_all rs 0 0) -> False.
Proof.
intros.
inspect_in_Γ.
Qed.

(*dollar is derived only by x_0 and x_star*)
Lemma term_shape_dollar : forall (rs : list rule) (n bound : nat) (N : term),
  normal_form N ->
  derivation n (Γ_all rs bound (1 + bound)) N dollar ->
    (exists (N' : term), normal_form N' /\ N = term_app (free_var x_0) N') \/
    (exists (N' : term), normal_form (term_abs N') /\ N = term_app (free_var x_star) (term_abs N')).
Proof.
intros *.
case; last (move => ? ?; inversion). (*N is not an abstraction*)
move => {N} N.
case.
{
move => x; inversion.
exfalso.
apply : dollar_not_in_Γ_all; eauto.
}
(*head cannot be bound*)
intros *; inversion.
move => {N} N N'.
case.
{
move => x HN'; inversion.
gimme derivation; inversion.
inspect_in_Γ.
gimme @eq; case; intro; subst.
right.
do 2 (gimme Forall; inversion).
gimme derivation; inversion; eauto; exfalso.

{
inspect_in_Γ.
}

{
gimme derivation. move /two_params_rule.
nip.
gimme normal_form; inversion.
by gimme head_form; inversion.
clear; firstorder (subst; try done).
}
}

intros; exfalso. do 2 (gimme derivation; inversion). (*head cannt be bound*)
intros; exfalso.
do 2 (gimme derivation; inversion).
(*head cannot have two arguments because types are too short*)
gimme derivation. move /two_params_rule.
nip; first auto.
firstorder done.
Qed.

Lemma extend_Γ_lr_lt : forall (bound i : nat), i < bound ->
  Γ_lr (1+bound) i = Γ_lr bound i ++ [(y_pos bound, (bullet : formula'))].
Proof.
move => bound i H. rewrite /Γ_lr /s_pos.
autorewrite with seq.
do ? inspect_eqb.
f_equal.
Qed.

Lemma extend_Γ_lr0 : forall (bound : nat),
  Γ_lr (1+bound) bound = Γ_lr bound bound ++ [(y_pos bound, (isl : formula'))].
Proof.
move => bound. rewrite /Γ_lr /s_pos.
autorewrite with seq.
do ? inspect_eqb.
f_equal.
Qed.

Lemma extend_Γ_lr1 : forall (bound : nat),
  Γ_lr (1+bound) (1+bound) = Γ_lr bound (1+bound) ++ [(y_pos bound, (isr : formula'))].
Proof.
move => bound. rewrite /Γ_lr /s_pos.
autorewrite with seq.
do ? inspect_eqb.
f_equal.
Qed.

Lemma extend_Γ_lr2 : forall (bound : nat),
  Γ_lr (1+bound) (2+bound) = Γ_lr bound (1+bound) ++ [(y_pos bound, (bullet : formula'))].
Proof.
move => bound. rewrite /Γ_lr /s_pos.
autorewrite with seq.
do ? inspect_eqb.
f_equal.

set indices := (seq 0 bound).
move Heq : (bound) => bound'.
have : bound <= bound' by omega.
subst indices.
move : bound {Heq} bound'.

elim; first reflexivity.
move => bound IH bound' H.
autorewrite with seq.

f_equal.
apply IH; omega.
do ? inspect_eqb.
reflexivity.
Qed.

Lemma invert_forall_x_0 : forall (rs : list rule) (n bound: nat) (N : term),
  Forall (fun (Γi : environment) => derivation n Γi (term_app (free_var x_0) N) star)
    (map (Γ_all rs bound) (seq 0 bound))
  -> Forall (fun (Γi : environment) => derivation (Nat.pred n) Γi N (symbol 0))
    (map (Γ_all rs bound) (seq 0 bound)).
Proof.
intros *.
rewrite ? Forall_forall.
move => HDs Γ H.
move /(_ Γ H) : HDs.
gimme In; rewrite in_map_iff.
move => [i [? ?]]; subst.
inversion; gimme derivation; inversion.
inspect_in_Γ.
gimme @eq; case; intro; subst.
gimme Forall; by inversion.
Qed.

(*if triangle is inhabited in (Γ_init ++ Γ_step rs), then hash, dollar is inhabited in (Γ_all rs 0 0)*)
Lemma soundness_init : forall (rs : list rule) (n : nat) (N : term),
  normal_form N ->
  derivation n (Γ_init ++ Γ_step rs) N triangle ->
  exists (n' : nat) (N' : term), normal_form N' /\
  derivation n' (Γ_all rs 0 0) N' hash /\
  derivation n' (Γ_all rs 0 0) N' dollar.
Proof.
intros *.

have : (Γ_init ++ Γ_step rs) = Γ_all rs 0 0 by reflexivity.
move => ->.

case; last (move => ? ?; inversion). (*N is not an abstraction*)
move => {N} N.
case.
{
move => x; inversion.
exfalso.
apply : triangle_not_in_Γ_all; eauto.
}
(*head cannot be bound*)
intros *; inversion.
move => {N} N N'.
case.
{
(*actual case*)
move => x HN'; inversion.
gimme derivation; inversion.
inspect_in_Γ.
gimme @eq; case; intro; subst.
do 2 (gimme Forall; inversion).
eauto.
}

intros; exfalso. do 2 (gimme derivation; inversion). (*head cannot be bound*)
intros; exfalso.
do 2 (gimme derivation; inversion).
(*head cannot have two arguments because types are too short*)
gimme derivation. move /two_params_rule.
nip; first auto.
firstorder done.
Qed.

(*if stars, hash, dollar is inhabited in (Γ_all rs bound [0 .. 1+bound]), then 0 is inhabited in (Γ_all rs bound [0 .. bound'])*)
Lemma soundness_expand : forall (rs : list rule) (n bound : nat) (N : term),
  normal_form N ->
  Forall (fun Γi => derivation n Γi N star) (map (Γ_all rs bound) (seq 0 bound)) ->
  derivation n (Γ_all rs bound bound) N hash ->
  derivation n (Γ_all rs bound (1+bound)) N dollar ->
  exists (n' bound' : nat) (N' : term),
  normal_form N' /\
  Forall (fun Γi => derivation n' Γi N' (symbol 0)) (map (Γ_all rs bound') (seq 0 (1+bound'))).
Proof.
move => rs. elim /lt_wf_ind.
move => n IH bound N HN HDs HDN1 HDN2.
move /term_shape_dollar : (HDN2). nip; auto.
case.
{ (*x_0 is used*)
move => [N' [HN' ?]]; subst N; clear HN.
gimme Forall; move /invert_forall_x_0.
move => HDs.
exists (Nat.pred n), bound, N'.
split; auto.
autorewrite with seq; split; auto.
(* hash <- 0 *)
move : HDN1; inversion; gimme derivation; inversion.
gimme In; gimme In; autorewrite with in_x_Γ; move => ->.
(do_last 3 case); try done.
case; intro; subst.
gimme Forall; by inversion.
}

(*x_star is used*)
move => [N' [HN' ?]]; subst N; clear HN.
move : HDN2; inversion.
gimme derivation; inversion.
gimme In; gimme In; autorewrite with in_x_Γ; move => ->.
case; first done.
case; first done.
case; last done.
case; intros; subst.
do 3 (gimme Forall; inversion).
do 2 (gimme derivation; inversion).
gimme where derivation; move /(_ (y_pos bound)).
gimme where derivation; move /(_ (y_pos bound)).
(*show that shape context is extended by 1*)
move /(weakening (Γ':=Γ_init ++ Γ_lr (1+bound) (2+bound) ++ Γ_step rs)).
nip; first (rewrite extend_Γ_lr2; list_inclusion).
move => HN'1.
move /(weakening (Γ':=Γ_init ++ Γ_lr (1+bound) (1+bound) ++ Γ_step rs)).
nip; first (rewrite extend_Γ_lr1; list_inclusion).
move => HN'2.
apply : IH.
5: exact HN'1.
all: try (omega + assumption).
(*instantiate N' is in normal form*)
apply instantiate_normal_form.
gimme normal_form; inversion; done + (gimme head_form; inversion).
(*show Forall Γi |- ? : star*)
autorewrite with seq.
split.
{
gimme Forall; clear.
rewrite ? Forall_forall.
move => Hds Γ'.
rewrite ? in_map_iff.
move => [i [? ?]]; subst.
move /(_ (Γ_all rs bound i)) : Hds.
rewrite ? in_map_iff.
nip; first eauto.
inversion.
gimme derivation; inversion.
gimme In; gimme In; autorewrite with in_x_Γ; move => ->.

case; last (case; case; try done).
case; intros; subst.
do ? (gimme Forall; inversion).
gimme derivation; inversion.
gimme where derivation; move /(_ (y_pos bound)).
move /weakening. apply.
gimme In; move /in_seq => [? ?].
rewrite /Γ_all.
rewrite extend_Γ_lr_lt; try omega.
list_inclusion.
}
{
(*bound : hash <- star*)
move : HDN1; clear.
inversion.
gimme derivation; inversion.
gimme In; gimme In; autorewrite with in_x_Γ; move => ->.
case; first done.
case; last (intuition done).
case; intro; subst.
do ? (gimme Forall; inversion).
gimme derivation; inversion.
gimme where derivation; move /(_ (y_pos bound)).
move /weakening.
apply.
rewrite /Γ_all.
rewrite extend_Γ_lr0. list_inclusion.
}
Qed.

Lemma invert_derivation_y_pos_lt : forall rs n bound i j s, derivation n (Γ_all rs bound i) (free_var (y_pos j)) s -> i < j -> s = bullet.
Proof.
intros; gimme derivation; inversion.
inspect_in_Γ.
gimme (@eq label); case; intro; subst.
by (do ? inspect_eqb).
Qed.

Lemma invert_derivation_y_pos_gt : forall rs n bound i j s, derivation n (Γ_all rs bound i) (free_var (y_pos j)) s -> i > 1 + j -> s = bullet.
Proof.
intros; gimme derivation; inversion.
inspect_in_Γ.
gimme (@eq label); case; intro; subst.
by (do ? inspect_eqb).
Qed.

Lemma invert_derivation_y_pos_isl : forall rs n bound j s, derivation n (Γ_all rs bound j) (free_var (y_pos j)) s -> s = isl.
Proof.
intros; gimme derivation; inversion.
inspect_in_Γ.
gimme (@eq label); case; intro; subst.
by (do ? inspect_eqb).
Qed.

Lemma invert_derivation_y_pos_isr : forall rs n bound j s, derivation n (Γ_all rs bound (S j)) (free_var (y_pos j)) s -> s = isr.
Proof.
intros; gimme derivation; inversion.
inspect_in_Γ.
gimme (@eq label); case; intro; subst.
by (do ? inspect_eqb).
Qed.

Lemma get_s_rule_bullet : forall (rs : list rule) (r : rule) (phi psi : formula') (a : nat),
  In (arr phi (arr psi (symbol a))) (s_rule rs r) -> In (atom bullet) phi -> phi = bullet /\ psi = symbol a.
Proof.
intros *.
autorewrite with in_formula'.
firstorder; subst.
all: gimme @eq; case; intros; subst; try done.
all: gimme In; inversion; try done.
Qed.

Lemma get_s_rule_isl : forall (rs : list rule) (a' a b c d : nat) (phi psi : formula'),
  In (arr phi (arr psi (symbol a'))) (s_rule rs ((a,b),(c,d))) -> In (atom isl) phi -> phi = isl /\ psi = symbol c /\ a' = a.
Proof.
intros *.
autorewrite with in_formula'.
firstorder.
all: gimme @eq; case; intros; subst; try done.
all: gimme @eq; case; intros; subst; try done.
all: gimme In; inversion; try done.
Qed.

Lemma get_s_rule_isr : forall (rs : list rule) (a' a b c d : nat) (phi psi : formula'),
  In (arr phi (arr psi (symbol a'))) (s_rule rs ((a,b),(c,d))) -> In (atom isr) phi -> phi = isr /\ psi = symbol d /\ a' = b.
Proof.
intros *.
autorewrite with in_formula'.
firstorder.
all: gimme @eq; case; intros; subst; try done.
all: gimme @eq; case; intros; subst; try done.
all: gimme In; inversion; try done.
Qed.

(*if [a_0 .. a_bound] is inhabited in (Γ_all rs bound [0 .. bound], then a_0..a_bound rewrites to 1..1 *)
Lemma soundness_step : forall (rs : list rule) (n bound : nat) (N : term) (v : list nat),
  normal_form N ->
  length v = 1 + bound ->
  Forall (fun '(i, a) => derivation n (Γ_all rs bound i) N (symbol a)) (indexed 0 v) ->
  rewrites_to rs v (map (fun _ => 1) v).
Proof.
move => rs. elim /lt_wf_ind.
move => n IH bound N v HN Hv HDs.

have : exists (e : nat), derivation n (Γ_all rs bound 0) N (symbol e).
revert dependent v.
case; first (cbn; intros; done).
intros; gimme Forall; inversion. eexists; eassumption.

move => [e ?].
gimme derivation. move /term_1.
nip; auto.
case.
{
move => [i [j [r [M [? [Hj ?]]]]]].
subst N.
move /in_seq : (Hj) => [_ ?].

have : 1 + j < length v by omega.
move /split_word => [v1 [v2 [a [b [? Hv1]]]]].
subst v.
gimme Forall.
rewrite -> indexed_app.
rewrite /indexed -/indexed Forall_app Hv1.
rewrite <- plus_n_O.
move => [?].
move /Forall_cons=> [?].
move /Forall_cons=> [?] ?.
do ? (gimme derivation where term_app; inversion).
do ? (gimme derivation where free_var; inversion).

(*show that arguments at j, 1+j positions are isl and isr*)
gimme Forall where (y_pos j).
move /forall_exists_in_formula' => [sl [?]].
move /invert_derivation_y_pos_isl.
intro; subst sl.
gimme Forall where (y_pos j).
move /forall_exists_in_formula' => [sr [?]].
move /invert_derivation_y_pos_isr.
intro; subst sr.

gimme In where Γ_all.
gimme In where Γ_all.
autorewrite with lookup_Γ.
firstorder (subst; try done).
do 2 (gimme (@eq label); case).
intros; subst.
gimme In. move /(in_indexed_eq).
move /(_ _ ltac:(eassumption)); intro; subst.
gimme In. move /(in_indexed_eq).
move /(_ _ ltac:(eassumption)); intro; subst.
have : exists (a' b' c' d' : nat), r = ((a',b'),(c',d')).
clear; case : r.
case => ? ?; case => ? ?; eauto.
move => [a' [b' [c' [d' ?]]]]; subst r.

(*show isl rewrites a' to c'*)
gimme In where a.
move /get_s_rule_isl.
nip; first auto.
move => [? [? ?]]; subst.

(*show isr rewrites b' to d'*)
gimme In where b.
move /get_s_rule_isr.
nip; first auto.
move => [? [? ?]]; subst.

gimme In where rs; move /in_indexed_in.
move => ?.
apply : (ssts_step ltac:(eassumption)).
have : (map (λ _ : nat, 1) (v1 ++ a' :: b' :: v2)) = (map (λ _ : nat, 1) (v1 ++ c' :: d' :: v2)) by rewrite ? map_app.
move => ->.
eapply (IH (S n)); first omega.

gimme normal_form; inversion.
gimme head_form; inversion; eassumption.

rewrite <- Hv.
by rewrite ? app_length.

(*show derivability of (v1 ++ c' :: d' :: v2)*)
rewrite -> indexed_app.
rewrite /indexed -/indexed.
rewrite <- plus_n_O.
apply Forall_app.
split.
{ (*derivability of v1*)
gimme Forall where (indexed 0 v1).
rewrite ? Forall_forall.
move => HDs [i a] Hia.
move /(_ (i, a) Hia) : HDs; inversion.
do 2 (gimme derivation; inversion).
gimme In where x_rule.
autorewrite with lookup_Γ.
firstorder (subst; try done).
gimme Forall where y_pos.
move /forall_exists_in_formula' => [s [?]].

move /invert_derivation_y_pos_lt.
nip. gimme (In (i, a)). move /in_indexed_bounds; intros; omega.
intro; subst.
gimme In where a.
move /get_s_rule_bullet.
nip; auto.
move => [? ?]; subst.
gimme Forall; by inversion.
}
(*derivability of c'*)
constructor.
gimme Forall where c'.
inversion; assumption.
(*derivability of d'*)
constructor.
gimme Forall where d'.
inversion; assumption.

{ (*derivability of v2*)
gimme Forall where v2.
rewrite ? Forall_forall.
move => HDs [i a] Hia.
move /(_ (i, a) Hia) : HDs; inversion.
do 2 (gimme derivation; inversion).
gimme In where x_rule.
autorewrite with lookup_Γ.
firstorder (subst; try done).
gimme Forall where y_pos.
move /forall_exists_in_formula' => [s [?]].

move /invert_derivation_y_pos_gt.
nip. gimme (In (i, a)). move /in_indexed_bounds; intros; omega.
intro; subst.
gimme In where a.
move /get_s_rule_bullet.
nip; auto.
move => [? ?]; subst.
gimme Forall; by inversion.
}

} (*end of inductive case*)
clear Hv.
intro; subst.
suff : v = (map (λ _ : nat, 1) v).
move => <-. apply ssts_refl.
gimme Forall; clear.
move : {1}(0) => m.
elim : v m; first auto.
move => a v IH m.
rewrite /indexed -/indexed.
move /Forall_cons => [HD HDs].
cbn.
f_equal; last eauto.
{
gimme derivation; inversion.
gimme In; gimme In.
autorewrite with lookup_Γ.
firstorder (subst; try done).
gimme In; inversion; last done.
gimme (@eq formula); by case.
}
Qed.

(*if triangle is inhabited in (Γ_init ++ Γ_step rs), then 0..0 rewrites to 1..1*)
Theorem soundness : forall (rs : list rule) (n : nat) (N : term),
  normal_form N ->
  derivation n (Γ_init ++ Γ_step rs) N triangle ->
  exists (m : nat), rewrites_to rs (repeat 0 (1+m)) (repeat 1 (1+m)).
Proof.
intros.
gimme derivation.
move /soundness_init. nip; first done.
clear. move => [n [N [? [?]]]].
have : (Γ_all rs 0 0) = (Γ_all rs 0 1) by reflexivity.
move => ->.
move /soundness_expand.
do 4 (nip; first auto).
cbn; auto.
clear.
move => [n [bound [N [? ?]]]].
exists bound.
gimme normal_form; move /(soundness_step (n := n) (bound := bound) (rs := rs) (v := (repeat 0 (1 + bound)))).
have ? := repeat_length.
nip; first (cbn; auto).

nip.
{ (*show that derivations are equavalent*)
gimme Forall.
clear.
move : {2 4}(0) => m.
move : (Γ_all rs bound) => Γ.
elim : bound m.
cbn.
intro; inversion.
constructor; auto.

move => bound IH m.

have : (map Γ (seq m (1 + S bound))) =
  (Γ m) :: (map Γ (seq (1+m) (1 + bound))) by reflexivity.
have : (indexed m (repeat 0 (1 + S bound))) = (m, 0) :: (indexed (1+m) (repeat 0 (1 + bound))) by reflexivity.
move => -> ->.

move /Forall_cons => [? ?].
constructor; eauto.
}

have : (map (λ _ : nat, 1) (repeat 0 (1 + bound))) = (repeat 1 (1 + bound)).
clear; elim: bound; first auto.
cbn; intros; f_equal; auto.

congruence.
Qed.


Require Import
  MathClasses.interfaces.canonical_names MathClasses.interfaces.universal_algebra Coq.Program.Program.

Section packed.
  Context (σ: Signature) {V: Type}.

  Inductive Applied: sorts σ → Type :=
    | AppliedOp o: Arguments (σ o) → Applied (result _ (σ o))
    | AppliedVar: V → ∀ s, Applied s
  with Arguments: OpType (sorts σ) → Type :=
    | NoMoreArguments s: Arguments (ne_list.one s)
    | MoreArguments o' o: Applied o' → Arguments o → Arguments (ne_list.cons o' o).

  Definition head_arg x y (a: Arguments (ne_list.cons x y)): Applied x :=
    match a with
    | MoreArguments k l m n => m
    end.

  Definition tail_args x y (a: Arguments (ne_list.cons x y)): Arguments y :=
    match a with
    | MoreArguments k l m n => n
    end.

  Context (P: ∀ {s}, Applied s → Type).
  Arguments P {s} _.

  Section forallArgs.
    Fixpoint forallArgs {o} (a: Arguments o): Type :=
      match a with
      | NoMoreArguments _ => True
      | MoreArguments _ _ z v => prod (P z) (forallArgs v)
      end.

    Definition PofSplit {o}: Arguments o → Type :=
      match o with
      | ne_list.one _ => λ _, unit
      | ne_list.cons x y => λ a, prod (P (head_arg x y a)) (forallArgs (tail_args _ _ a))
      end.

    Definition forallSplit `(a: Arguments (ne_list.cons y z)):
      forallArgs a → prod (P (head_arg y z a)) (forallArgs (tail_args _ _ a)).
    Proof.
     intro.
     change (PofSplit a).
     destruct a; simpl.
      exact tt.
     assumption.
    Defined. (* todo: write as term *)
  End forallArgs.

  Context
    (Pop: ∀ o x, forallArgs x → P (AppliedOp o x))
    (Pvar: ∀ v s, P (AppliedVar v s)).

  Fixpoint better_Applied_rect {o} (a: Applied o): P a :=
    match a with
    | AppliedOp x y => Pop x y (better_args y)
    | AppliedVar x v => Pvar x v
    end
  with better_args {o} (a: Arguments o): forallArgs a :=
    match a with
    | NoMoreArguments _ => I
    | MoreArguments _ _ x y => (better_Applied_rect x, better_args y)
    end.
End packed.

(* Conversion /from/ packed representation: *)

Fixpoint curry {σ} {V} {o} (a: Applied σ o): Term σ V (ne_list.one o) :=
  match a in (Applied _ s) (*return (Term σ V (ne_list.one s))*) with
  | AppliedOp _ op y => apply_args y (app_tree σ (Op σ V op))
  | AppliedVar _ v x => Var σ V v x
  end
with apply_args {σ} {V} {o} (a: @Arguments σ V o): op_type (Term0 σ V) o → Term0 σ V (result _ o) :=
  match a with
  | NoMoreArguments _ y => id
  | MoreArguments _ x y u q => λ z, apply_args q (z (curry u))
  end.

(* Conversion /to/ packed representation: *)

Fixpoint decode `(t: Term σ V o): Arguments σ o → Applied σ (result _ o) :=
  match t with
  | Var _ _ x y => λ z, AppliedVar σ x y
  | Op _ _ x => AppliedOp σ x
  | App _ _ x y z w => λ p, decode z (MoreArguments σ y x (decode w (NoMoreArguments σ _)) p)
  end.

(* Back and forth: *)

Definition curry_decode `(t: Term σ V o) (a: Arguments σ o):
  curry (decode t a) ≡ apply_args a (app_tree σ t).
Proof with simpl in *; try reflexivity.
 induction t...
  dependent destruction a... (* DANGER: uses JMeq_eq *)
 rewrite IHt1...
 rewrite IHt2...
Qed.

(* Nullary specializations: *)

Definition decode0 `(t: Term0 σ V s): Applied σ s := decode t (NoMoreArguments σ _).

Definition curry_decode0 `(t: Term0 σ V o): curry (decode0 t) ≡ t.
Proof. apply (curry_decode t). Qed.