Require Import Coqlib.
Require Export ZArith.
Require Import String.
Require Import PCM.
Require Export AList.

Set Implicit Arguments.

Local Open Scope nat_scope.

Notation gname := string (only parsing). (*** convention: not capitalized ***)
Notation mname := string (only parsing). (*** convention: capitalized ***)

Fixpoint _find_idx {A} (f: A -> bool) (l: list A) (acc: nat): option (nat * A) :=
  match l with
  | [] => None
  | hd :: tl => if (f hd) then Some (acc, hd) else _find_idx f tl (S acc)
  end
.

Definition find_idx {A} (f: A -> bool) (l: list A): option (nat * A) := _find_idx f l 0.

Notation "'do' ' X <- A ; B" := (o_bind A (fun _x => match _x with | X => B end))
                                  (at level 200, X pattern, A at level 100, B at level 200)
                                : o_monad_scope.

Lemma find_idx_red {A} (f: A -> bool) (l: list A):
  find_idx f l =
  match l with
  | [] => None
  | hd :: tl =>
    if (f hd)
    then Some (0%nat, hd)
    else
      do (n, a) <- find_idx f tl;
      Some (S n, a)
  end.
Proof.
  unfold find_idx. generalize 0. induction l; ss.
  i. des_ifs; ss.
  - rewrite Heq0. ss.
  - rewrite Heq0. specialize (IHl (S n)). rewrite Heq0 in IHl. ss.
Qed.

Module SkEnv.

  Notation mblock := nat (only parsing).
  Notation ptrofs := Z (only parsing).

  Record t: Type := mk {
    blk2id: mblock -> option gname;
    id2blk: gname -> option mblock;
  }
  .

  Definition wf (ske: t): Prop :=
    forall id blk, ske.(id2blk) id = Some blk <-> ske.(blk2id) blk = Some id.

End SkEnv.

Require Import Orders.

Module Sk.
  Class ld: Type := mk {
    t:> Type;
    unit: t;
    add: t -> t -> t;
    canon: t -> t;
    wf: t -> Prop;
    add_comm: forall a b (WF: wf (add a b)),
        canon (add a b) = canon (add b a);
    add_assoc: forall a b c, add a (add b c) = add (add a b) c;
    add_unit_l: forall a, add unit a = a;
    add_unit_r: forall a, add a unit = a;
    wf_comm: forall a b, wf (add a b) -> wf (add b a);
    unit_wf: wf unit;
    wf_mon: forall a b, wf (canon (add a b)) -> wf (canon a);

    extends := fun a b => exists ctx, canon (add a ctx) = b;
  }
  .

  (* Imp Instance *)
  Inductive gdef: Type := Gfun | Gvar (gv: Z).

  Module GDef <: Typ. Definition t := gdef. End GDef.
  Module SkSort := AListSort GDef.

  Definition sort: alist gname gdef -> alist gname gdef := SkSort.sort.

  Program Definition gdefs: ld :=
    @mk (alist gname gdef) nil (@List.app _) sort (fun sk => @List.NoDup _ (List.map fst sk)) _ _ _ _ _ _ _.
  Next Obligation.
  Proof.
    eapply SkSort.sort_add_comm. auto.
    (* eapply Permutation.Permutation_NoDup; [|et]. *)
    (* eapply Permutation.Permutation_map. *)
    (* symmetry. eapply SkSort.sort_permutation. *)
  Qed.
  Next Obligation.
  Proof.
    eapply List.app_assoc.
  Qed.
  Next Obligation.
  Proof.
    rewrite List.app_nil_r. auto.
  Qed.
  Next Obligation.
  Proof.
    i. eapply Permutation.Permutation_NoDup; [|et].
    eapply Permutation.Permutation_map.
    apply Permutation.Permutation_app_comm.
  Qed.
  Next Obligation.
  Proof.
    econs.
  Qed.
  Next Obligation.
  Proof.
    cut (NoDup (map fst a)).
    { i. eapply Permutation.Permutation_NoDup; [|et].
      eapply Permutation.Permutation_map.
      eapply SkSort.sort_permutation. }
    cut (NoDup (map fst (a ++ b))).
    { i. rewrite map_app in H0.
      eapply nodup_app_l. et. }
    i. eapply Permutation.Permutation_NoDup; [|et].
    eapply Permutation.Permutation_map.
    symmetry. eapply SkSort.sort_permutation.
  Qed.

  Local Existing Instance gdefs.

  Definition sort_add_comm sk0 sk1
             (WF: wf (add sk0 sk1))
    :
      sort (add sk0 sk1) = sort (add sk1 sk0).
  Proof.
    eapply SkSort.sort_add_comm. eapply WF.
  Qed.

  Definition sort_wf sk (WF: wf sk):
    wf (sort sk).
  Proof.
    ss. eapply Permutation.Permutation_NoDup; [|apply WF].
    eapply Permutation.Permutation_map.
    eapply SkSort.sort_permutation.
  Qed.

  (*** TODO: It might be nice if Sk.t also constitutes a resource algebra ***)
  (*** At the moment, List.app is not assoc/commutative. We need to equip RA with custom equiv. ***)

  Definition load_skenv (sk: t): (SkEnv.t) :=
    let n := List.length sk in
    {|
      SkEnv.blk2id := fun blk => do '(gn, _) <- (List.nth_error sk blk); Some gn;
      SkEnv.id2blk := fun id => do '(blk, _) <- find_idx (fun '(id', _) => string_dec id id') sk; Some blk
    |}
  .

  Lemma load_skenv_wf
        sk
        (WF: wf sk)
    :
      <<WF: SkEnv.wf (load_skenv sk)>>
  .
  Proof.
    r in WF.
    rr. split; i; ss.
    - uo; des_ifs.
      + f_equal. ginduction sk; ss. i. inv WF.
        rewrite find_idx_red in Heq1. des_ifs; ss.
        { des_sumbool. subst. ss. clarify. }
        des_sumbool. uo. des_ifs. destruct p. ss.
        hexploit IHsk; et.
      + exfalso. ginduction sk; ss. i. inv WF.
        rewrite find_idx_red in Heq2. des_ifs; ss.
        des_sumbool. uo. des_ifs. destruct p. ss.
        hexploit IHsk; et.
    - ginduction sk; ss.
      { i. uo. ss. destruct blk; ss. }
      i. destruct a. inv WF. uo. destruct blk; ss; clarify.
      {  rewrite find_idx_red. uo. des_ifs; des_sumbool; ss. }
      hexploit IHsk; et. i.
      rewrite find_idx_red. uo. des_ifs; des_sumbool; ss. exfalso.
      subst. clear - Heq1 H2. ginduction sk; ss. i.
      rewrite find_idx_red in Heq1. des_ifs; des_sumbool; ss; et.
      uo. des_ifs. destruct p. eapply IHsk; et.
  Qed.

  Definition incl (sk0 sk1: Sk.t): Prop :=
    forall gn gd (IN: List.In (gn, gd) sk0),
      List.In (gn, gd) sk1.

  Program Instance incl_PreOrder: PreOrder incl.
  Next Obligation.
  Proof.
    ii. ss.
  Qed.
  Next Obligation.
  Proof.
    ii. eapply H0. eapply H. ss.
  Qed.

  Lemma sort_incl sk
    :
      incl sk (sort sk).
  Proof.
    ii. eapply Permutation.Permutation_in; [|apply IN].
    eapply SkSort.sort_permutation.
  Qed.

  Lemma sort_incl_rev sk
    :
      incl (sort sk) sk.
  Proof.
    ii. eapply Permutation.Permutation_in; [|apply IN].
    symmetry. eapply SkSort.sort_permutation.
  Qed.

  Definition incl_env (sk0: Sk.t) (skenv: SkEnv.t): Prop :=
    forall gn gd (IN: List.In (gn, gd) sk0),
    exists blk, <<FIND: skenv.(SkEnv.id2blk) gn = Some blk>>.

  Lemma incl_incl_env sk0 sk1
        (INCL: incl sk0 sk1)
    :
      incl_env sk0 (load_skenv sk1).
  Proof.
    ii. exploit INCL; et. i. ss. uo. des_ifs; et.
    exfalso. clear - x0 Heq0. ginduction sk1; et.
    i. ss. rewrite find_idx_red in Heq0. des_ifs.
    des_sumbool. uo.  des_ifs. des; clarify.
    eapply IHsk1; et.
  Qed.

  Lemma in_env_in_sk :
    forall sk blk symb
      (FIND: SkEnv.blk2id (Sk.load_skenv sk) blk = Some symb),
    exists def, In (symb, def) sk.
  Proof.
    i. unfold SkEnv.blk2id. ss.
    uo. des_ifs. des; clarify.
    eapply nth_error_In in Heq0. et.
  Qed.

  Lemma in_sk_in_env :
    forall sk def symb
           (IN: In (symb, def) sk),
    exists blk, SkEnv.blk2id (Sk.load_skenv sk) blk = Some symb.
  Proof.
    i. unfold SkEnv.blk2id. ss.
    uo. eapply In_nth_error in IN. des.
    eexists. rewrite IN. et.
  Qed.

  Lemma env_range_some :
    forall sk blk
      (BLKRANGE : blk < Datatypes.length sk),
      <<FOUND : exists symb, SkEnv.blk2id (Sk.load_skenv sk) blk = Some symb>>.
  Proof.
    i. depgen sk. induction blk; i; ss; clarify.
    { destruct sk; ss; clarify.
      { lia. }
      uo. destruct p. exists s. ss. }
    destruct sk; ss; clarify.
    { lia. }
    apply lt_S_n in BLKRANGE. eapply IHblk; eauto.
  Qed.

  Lemma env_found_range :
    forall sk symb blk
      (FOUND : SkEnv.id2blk (Sk.load_skenv sk) symb = Some blk),
      <<BLKRANGE : blk < Datatypes.length sk>>.
  Proof.
    induction sk; i; ss; clarify.
    uo; des_ifs. destruct p0. rewrite find_idx_red in Heq0. des_ifs.
    { apply Nat.lt_0_succ. }
    destruct blk.
    { apply Nat.lt_0_succ. }
    uo. des_ifs. destruct p. ss. clarify. apply lt_n_S. eapply IHsk; eauto.
    instantiate (1:=symb). rewrite Heq0. ss.
  Qed.

End Sk.


Require Import Coq.Lists.List Coq.Bool.Bool.
Require Import Coq.Setoids.Setoid Coq.Classes.RelationClasses.
Require Import ExtLib.Tactics.EqDep.
Require Import ExtLib.Tactics.Consider.
Require Import MirrorShard.Expr.
Require Import MirrorShard.SepTheory.
Require Import MirrorShard.Folds MirrorShard.Tactics.

Set Implicit Arguments.
Set Strict Implicit.

Definition BadInj types (e : expr types) := False.
Definition BadPred (f : func) := False.
Definition BadPredApply types (f : func) (es : list (expr types)) (_ : env types) := False.

Module Type SepExpr (ST : SepTheory.SepTheory).

  Section env.
    Variable types : list type.

    Record predicate := PSig
    { SDomain : list tvar
    ; SDenotation : functionTypeD (map (@tvarD types) SDomain) ST.hprop
    }.

    Definition predicates : Type := list predicate.

    Parameter Default_predicate : predicate.

    Inductive sexpr : Type :=
    | Emp : sexpr
    | Inj : expr types -> sexpr
    | Star : sexpr -> sexpr -> sexpr
    | Exists : tvar -> sexpr -> sexpr
    | Func : func -> list (expr types) -> sexpr
    | Const : ST.hprop -> sexpr
    .

    Definition tpredicate : Type := list tvar.
    Definition tpredicates : Type := list tpredicate.

    Definition typeof_pred : predicate -> tpredicate := SDomain.
    Definition typeof_preds : predicates -> tpredicates := map typeof_pred.

    Section types.
      Variable funcs : tfunctions.
      Variable preds : tpredicates.
      Variable tU : tenv.

      Fixpoint WellTyped_sexpr (tG : tenv) (s : sexpr) : bool :=
        match s with
          | Emp => true
          | Inj e => is_well_typed funcs tU tG e tvProp
          | Star l r => WellTyped_sexpr tG l && WellTyped_sexpr tG r
          | Exists t e => WellTyped_sexpr (t :: tG) e
          | Func f args =>
            match nth_error preds f with
              | None => false
              | Some ts => all2 (is_well_typed funcs tU tG) args ts
            end
          | Const _ => true
        end.

    End types.

    (** sexprD (U ++ U') (G ++ G') e <===>
     ** sexprD (U ++ U'' ++ U') (G ++ G'' ++ G')
     **    (liftSExpr (length U) (length U'') (length G) (length G'') e)
     **)
    Fixpoint liftSExpr ua ub a b s : sexpr :=
      match s with
        | Emp => Emp
        | Const c => Const c
        | Inj p => Inj (liftExpr ua ub a b p)
        | Star l r => Star (liftSExpr ua ub a b l) (liftSExpr ua ub a b r)
        | Exists t s => Exists t (liftSExpr ua ub (S a) b s)
        | Func f args => Func f (map (liftExpr ua ub a b) args)
      end.

    Section funcs_preds.
      Variable funcs : functions types.
      Variable preds : predicates.
      Variable meta_env : env types.

      Fixpoint sexprD (var_env : env types) (s : sexpr) : ST.hprop :=
        match s with
          | Emp => ST.emp
          | Inj p =>
            match exprD funcs meta_env var_env p tvProp with
              | None => ST.inj (BadInj p)
              | Some p => ST.inj p
            end
          | Star l r =>
            ST.star (sexprD var_env l) (sexprD var_env r)
          | Exists t b =>
            ST.ex (fun x : tvarD types t => sexprD (@existT _ _ t x :: var_env) b)
          | Func f b =>
            match nth_error preds f with
              | None => ST.inj (BadPred f)
              | Some f' =>
                match applyD (@exprD types funcs meta_env var_env) (SDomain f') b _ (SDenotation f') with
                  | None => ST.inj (BadPredApply f b var_env)
                  | Some p => p
                end
            end
          | Const p => p
        end.

      Definition himp (var_env : env types)
        (gl gr : sexpr) : Prop :=
        ST.himp (sexprD var_env gl) (sexprD var_env gr).

      Definition heq (var_env : env types)
        (gl gr : sexpr) : Prop :=
        ST.heq (sexprD var_env gl) (sexprD var_env gr).

    End funcs_preds.

    Fixpoint existsEach (ls : list tvar) {struct ls} : sexpr -> sexpr :=
      match ls with
        | nil => fun x => x
        | t :: ts => fun y => Exists t (@existsEach ts y)
      end.

  End env.

  Implicit Arguments Emp [ types ].
  Implicit Arguments Star [ types ].
  Implicit Arguments Exists [ types ].
  Implicit Arguments Func [ types ].
  Implicit Arguments Const [ types ].
  Implicit Arguments Inj [ types ].

End SepExpr.

Module SepExprFacts (ST : SepTheory) (SE : SepExpr ST).
  Module SEP_FACTS := SepTheory_Rewrites ST.

  Section env.
    Variable types : list type.
    Variable funcs : functions types.
    Variable preds : SE.predicates types.

    Variables U G : env types.

    Global Instance Trans_himp : Transitive (@SE.himp types funcs preds U G).
    Proof.
      red. unfold SE.himp. intros; etransitivity; eauto.
    Qed.

    Global Instance Trans_heq : Transitive (@SE.heq types funcs preds U G).
    Proof.
      red. unfold SE.heq. intros; etransitivity; eauto.
    Qed.

    Global Instance Refl_himp : Reflexive (@SE.himp types funcs preds U G).
    Proof.
      red; unfold SE.himp; intros. reflexivity.
    Qed.

    Global Instance Refl_heq : Reflexive (@SE.heq types funcs preds U G).
    Proof.
      red; unfold SE.heq; intros. reflexivity.
    Qed.

    Global Instance Sym_heq : Symmetric (@SE.heq types funcs preds U G).
    Proof.
      red; unfold SE.heq; intros. symmetry. auto.
    Qed.

    Global Instance Equiv_heq : Equivalence (SE.heq funcs preds U G).
    Proof.
      constructor; eauto with typeclass_instances.
    Qed.

    Lemma heq_defn : forall P Q,
      (@SE.himp types funcs preds U G P Q /\
       @SE.himp types funcs preds U G Q P) <->
      (@SE.heq types funcs preds U G P Q).
    Proof.
      unfold SE.heq, SE.himp. intros; apply ST.heq_defn.
    Qed.

    Lemma heq_himp : forall P Q,
      @SE.heq types funcs preds U G P Q ->
      @SE.himp types funcs preds U G P Q.
    Proof.
      unfold SE.heq, SE.himp. intros. apply ST.heq_defn in H; intuition.
    Qed.

    Lemma himp_not_WellTyped : forall tfuncs tG tU f P Q l,
      WellTyped_env tU U ->
      WellTyped_env tG G ->
      WellTyped_funcs tfuncs funcs ->
      (forall p,
        nth_error preds f = Some p ->
        Folds.all2 (@is_well_typed types tfuncs tU tG) l (SE.SDomain p) = true ->
        SE.himp funcs preds U G (SE.Star (SE.Func f l) P) Q) ->
      SE.himp funcs preds U G (SE.Star (SE.Func f l) P) Q.
    Proof.
      intros. unfold SE.himp in *; simpl in *. consider (nth_error preds f); intros;
        try solve [ eapply ST.himp_star_pure_c; contradiction ].
      match goal with
        | [ |- context [ match ?X with | _ => _ end ] ] =>
          case_eq X
      end; intros; try solve [ eapply ST.himp_star_pure_c; contradiction ].
      specialize (H3 _ refl_equal). rewrite <- H3. rewrite H4. reflexivity.

      clear H2. clear H3. destruct p; simpl in *. generalize dependent l.
      induction SDomain; destruct l; simpl; intros; auto; try congruence.
      revert H4. consider (exprD funcs U G e a); intros.
      erewrite is_well_typed_correct_only by eauto. eapply IHSDomain; eauto. congruence.
    Qed.

    Add Parametric Relation : (@SE.sexpr types) (@SE.himp types funcs preds U G)
      reflexivity proved by  Refl_himp
      transitivity proved by Trans_himp
    as himp_rel.

    Add Parametric Relation : (@SE.sexpr types) (@SE.heq types funcs preds U G)
      reflexivity proved by  Refl_heq
      symmetry proved by Sym_heq
      transitivity proved by Trans_heq
    as heq_rel.

    Global Add Parametric Morphism : (@SE.Star types) with
      signature (SE.himp funcs preds U G ==> SE.himp funcs preds U G ==> SE.himp funcs preds U G)
      as star_himp_mor.
    Proof.
      unfold SE.himp; simpl; intros; eapply SEP_FACTS.star_himp_mor; eauto.
    Qed.

    Global Add Parametric Morphism : (@SE.Star types) with
      signature (SE.heq funcs preds U G ==> SE.heq funcs preds U G ==> SE.heq funcs preds U G)
      as star_heq_mor.
    Proof.
      unfold SE.himp; simpl; intros; eapply SEP_FACTS.star_heq_mor; eauto.
    Qed.

    Global Add Parametric Morphism : (SE.himp funcs preds U G) with
      signature (SE.heq funcs preds U G ==> SE.heq funcs preds U G ==> Basics.impl)
      as himp_heq_mor.
    Proof.
      unfold SE.heq; simpl; intros. eapply SEP_FACTS.himp_heq_mor; eauto.
    Qed.

    Global Add Parametric Morphism : (SE.himp funcs preds U G) with
      signature (SE.himp funcs preds U G --> SE.himp funcs preds U G ==> Basics.impl)
      as himp_himp_mor.
    Proof.
      unfold SE.himp; simpl; intros. intro. etransitivity. eauto. etransitivity; eauto.
    Qed.

    Global Add Parametric Morphism : (SE.himp funcs preds U G) with
      signature (SE.himp funcs preds U G --> SE.himp funcs preds U G ++> Basics.impl)
      as himp_himp_mor'.
    Proof.
      unfold SE.himp; simpl; intros. eapply SEP_FACTS.himp_himp_mor; eauto.
    Qed.

    Global Add Parametric Morphism : (SE.sexprD funcs preds U G) with
      signature (SE.heq funcs preds U G ==> ST.heq)
      as heq_ST_heq_mor.
    Proof.
      unfold SE.heq; simpl; auto.
    Qed.

    Global Add Parametric Morphism : (SE.sexprD funcs preds U G) with
      signature (SE.himp funcs preds U G ==> ST.himp)
      as himp_ST_himp_mor.
    Proof.
      unfold SE.himp; simpl; auto.
    Qed.

    Lemma heq_star_emp_r : forall P,
      SE.heq funcs preds U G (SE.Star P SE.Emp) P.
    Proof.
      unfold SE.heq; simpl; intros; autorewrite with hprop; reflexivity.
    Qed.

    Lemma heq_star_emp_l : forall P,
      SE.heq funcs preds U G (SE.Star SE.Emp P) P.
    Proof.
      unfold SE.heq; simpl; intros; autorewrite with hprop; reflexivity.
    Qed.

    Lemma heq_star_assoc : forall P Q R,
      SE.heq funcs preds U G (SE.Star (SE.Star P Q) R) (SE.Star P (SE.Star Q R)).
    Proof.
      unfold SE.heq; simpl; intros; autorewrite with hprop. rewrite ST.heq_star_assoc. reflexivity.
    Qed.

    Lemma heq_star_comm : forall P Q,
      SE.heq funcs preds U G (SE.Star P Q) (SE.Star Q P).
    Proof.
      unfold SE.heq; simpl; intros; apply ST.heq_star_comm.
    Qed.

    Lemma heq_star_frame : forall P Q R S,
      SE.heq funcs preds U G P R ->
      SE.heq funcs preds U G Q S ->
      SE.heq funcs preds U G (SE.Star P Q) (SE.Star R S).
    Proof.
      unfold SE.heq; simpl; intros. eapply ST.heq_star_frame; auto.
    Qed.

    Lemma himp_star_frame : forall P Q R S,
      SE.himp funcs preds U G P R ->
      SE.himp funcs preds U G Q S ->
      SE.himp funcs preds U G (SE.Star P Q) (SE.Star R S).
    Proof.
      unfold SE.himp; simpl; intros. rewrite H; rewrite H0; reflexivity.
    Qed.

    Lemma heq_star_comm_p : forall P Q R,
      SE.heq funcs preds U G (SE.Star P Q) R ->
      SE.heq funcs preds U G (SE.Star Q P) R.
    Proof.
      intros. rewrite heq_star_comm. auto.
    Qed.

    Lemma heq_star_comm_c : forall P Q R,
      SE.heq funcs preds U G R (SE.Star P Q) ->
      SE.heq funcs preds U G R (SE.Star Q P).
    Proof.
      intros. rewrite heq_star_comm. auto.
    Qed.

    Lemma heq_star_assoc_p1 : forall P Q R S,
      SE.heq funcs preds U G (SE.Star P (SE.Star Q R)) S ->
      SE.heq funcs preds U G (SE.Star (SE.Star P Q) R) S.
    Proof.
      intros. rewrite heq_star_assoc; auto.
    Qed.

    Lemma heq_star_assoc_p2 : forall P Q R S,
      SE.heq funcs preds U G (SE.Star Q (SE.Star P R)) S ->
      SE.heq funcs preds U G (SE.Star (SE.Star P Q) R) S.
    Proof.
      intros. apply heq_star_assoc_p1 in H. rewrite <- H.
      apply heq_star_frame; try reflexivity. rewrite heq_star_comm. reflexivity.
    Qed.

    Lemma heq_star_assoc_c1 : forall P Q R S,
      SE.heq funcs preds U G S (SE.Star P (SE.Star Q R)) ->
      SE.heq funcs preds U G S (SE.Star (SE.Star P Q) R).
    Proof.
      intros. rewrite heq_star_assoc; auto.
    Qed.

    Lemma heq_star_assoc_c2 : forall P Q R S,
      SE.heq funcs preds U G S (SE.Star Q (SE.Star P R)) ->
      SE.heq funcs preds U G S (SE.Star (SE.Star P Q) R).
    Proof.
      intros. apply heq_star_assoc_c1 in H. rewrite H.
      apply heq_star_frame; try reflexivity. apply heq_star_comm; reflexivity.
    Qed.

    Lemma heq_star_emp_p : forall P S,
      SE.heq funcs preds U G P S ->
      SE.heq funcs preds U G (SE.Star SE.Emp P) S.
    Proof.
      intros. rewrite heq_star_emp_l. auto.
    Qed.

    Lemma heq_star_emp_c : forall P S,
      SE.heq funcs preds U G S P ->
      SE.heq funcs preds U G S (SE.Star SE.Emp P).
    Proof.
      intros. rewrite heq_star_emp_l. auto.
    Qed.

  End env.

  Ltac heq_canceler :=
    let cancel cp ap1 ap2 ep cc ac1 ac2 ec frm P Q :=
      let rec iter_right Q :=
        match Q with
          | SE.Emp =>
            apply ec
          | SE.Star ?L ?R =>
            (apply ac1 ; iter_right L) || (apply ac2 ; iter_right R)
          | _ =>
            apply frm; [ reflexivity | ]
        end
      in
      let rec iter_left P :=
        match P with
          | SE.Emp =>
            apply ep
          | SE.Star ?L ?R =>
            (apply ap1 ; iter_left L) || (apply ap2 ; iter_left R)
          | _ =>
            match Q with
              | SE.Star ?A ?B =>
                iter_right A || (apply cc; iter_right B)
            end
        end
      in
      match P with
        | SE.Star ?A ?B =>
          iter_left A || (apply cp; iter_left B)
      end
    in
    repeat (rewrite heq_star_emp_l || rewrite heq_star_emp_r) ;
    repeat match goal with
             | [ |- @SE.heq _ _ _ _ _ ?P ?Q ] =>
               cancel heq_star_comm_p heq_star_assoc_p1 heq_star_assoc_p2 heq_star_emp_p
                      heq_star_comm_c heq_star_assoc_c1 heq_star_assoc_c2 heq_star_emp_c
                      heq_star_frame P Q
(*    | [ |- SE.himp _ _ _ _ _ ?P ?Q ] =>
   cancel himp_star_comm_p himp_star_assoc_p himp_star_comm_c himp_star_assoc_c P Q
   *)
    end; try reflexivity.

  Section other.
    Variable types : list type.
    Variable funcs : functions types.
    Variable preds : SE.predicates types.

    Theorem sexprD_weaken_wt : forall U U' G' s G,
      SE.WellTyped_sexpr (typeof_funcs funcs) (SE.typeof_preds preds) (typeof_env U) (typeof_env G) s = true ->
      ST.heq (SE.sexprD funcs preds U G s)
                (SE.sexprD funcs preds (U ++ U') (G ++ G') s).
    Proof.
      induction s; simpl; intros; think; try reflexivity.
      { consider (exprD funcs U G e tvProp); intros.
        erewrite exprD_weaken by eauto. reflexivity.
        rewrite <- ST.heq_star_emp_r.
        eapply is_well_typed_correct in H; eauto using typeof_env_WellTyped_env, typeof_funcs_WellTyped_funcs.
        rewrite H0 in H. exfalso; destruct H; congruence. }
      { eapply ST.heq_ex. intros. rewrite IHs; eauto. reflexivity. }
      { unfold SE.typeof_preds in *. rewrite map_nth_error_full in H.
        consider (nth_error preds f); intros; try reflexivity. inversion H1; subst.
        clear H1 H. destruct p; simpl in *. generalize dependent SDomain.
        induction l; destruct SDomain; intros; simpl in *; think; try (reflexivity || congruence).
        eapply is_well_typed_correct in H; eauto using typeof_env_WellTyped_env, typeof_funcs_WellTyped_funcs.
        destruct H. erewrite exprD_weaken; eauto. rewrite H. eauto. }
    Qed.

    Theorem sexprD_weaken : forall s U G G' U',
      ST.himp (SE.sexprD funcs preds U G s)
                    (SE.sexprD funcs preds (U ++ U') (G ++ G') s).
    Proof.
      induction s; simpl; intros; try reflexivity.
      { consider (exprD funcs U G e tvProp); intros.
        erewrite exprD_weaken by eauto. reflexivity.
        rewrite <- ST.heq_star_emp_r.
        eapply ST.himp_star_pure_c. contradiction. }
      { rewrite IHs1. rewrite IHs2. reflexivity. }
      { apply ST.himp_ex. intros. rewrite IHs with (U' := U') (G' := G'). reflexivity. }
      { destruct (nth_error preds f); try reflexivity.
        match goal with
          | [ |- ST.himp match ?X with _ => _ end _ ] =>
            consider X
        end; intros.
        erewrite Expr.applyD_weaken by eauto. reflexivity.
        rewrite <- ST.heq_star_emp_r.
        eapply ST.himp_star_pure_c. unfold BadPredApply. contradiction. }
    Qed.

    Theorem liftSExpr_sexprD : forall s U U' U'' G G' G'',
      ST.heq (SE.sexprD funcs preds (U ++ U') (G ++ G') s)
                (SE.sexprD funcs preds (U ++ U'' ++ U') (G ++ G'' ++ G')
                  (SE.liftSExpr (length U) (length U'') (length G) (length G'') s)).
    Proof.
      do 7 intro. revert G. induction s; simpl; intros; think; try reflexivity.
      rewrite <- liftExpr_ext. reflexivity.
      apply ST.heq_ex. intros. etransitivity.
      change (existT (tvarD types) t v :: G ++ G') with ((existT (tvarD types) t v :: G) ++ G'). eapply IHs. reflexivity.
      destruct (nth_error preds f); try reflexivity.
      match goal with
        | [ |- ST.heq match ?X with _ => _ end match ?Y with _ => _ end ] =>
          cutrewrite (X = Y); try reflexivity
      end.
      destruct p; simpl. clear. revert l; induction SDomain; destruct l; simpl; auto.
      rewrite <- liftExpr_ext. destruct (exprD funcs (U ++ U') (G ++ G') e a); eauto.
    Qed.

    Theorem liftSExpr_combine : forall (s : SE.sexpr types) ua ub uc a b c,
      SE.liftSExpr ua ub a b (SE.liftSExpr ua uc a c s) =
      SE.liftSExpr ua (uc + ub) a (c + b) s.
    Proof.
      clear. induction s; intros; simpl; think; try reflexivity.
      rewrite liftExpr_combine. reflexivity.
      f_equal. clear. induction l; simpl; intros; try rewrite liftExpr_combine; think; auto.
    Qed.

    Theorem liftSExpr_0 : forall (s : SE.sexpr types) ua a,
      SE.liftSExpr ua 0 a 0 s = s.
    Proof.
      clear; induction s; intros; simpl; think; try reflexivity.
      rewrite liftExpr_0; auto.
      f_equal. clear. induction l; simpl; intros; try rewrite liftExpr_0; think; auto.
    Qed.
  End other.

  Theorem himp_not_WellTyped_sexpr : forall ts funcs (preds : SE.predicates ts) s vars uvars,
    SE.WellTyped_sexpr (typeof_funcs funcs) (SE.typeof_preds preds) (typeof_env uvars) (typeof_env vars) s = false ->
    ST.himp (SE.sexprD funcs preds uvars vars s) (ST.inj False).
  Proof.
    induction s; simpl; intros; auto; try congruence.
    { consider (exprD funcs uvars vars e tvProp); intros; try reflexivity.
      eapply is_well_typed_correct_only in H0; eauto using typeof_env_WellTyped_env, typeof_funcs_WellTyped_funcs. congruence. }
    { apply andb_false_iff in H. destruct H.
      rewrite IHs1 by auto. eapply ST.himp_star_pure_c; contradiction.
      rewrite ST.heq_star_comm.
      rewrite IHs2 by auto. eapply ST.himp_star_pure_c; contradiction. }
    { eapply ST.himp_ex_p. intros.
      rewrite IHs. reflexivity. auto. }
    { unfold SE.typeof_preds in H.
      rewrite map_nth_error_full in H. destruct (nth_error preds f); try reflexivity.
      destruct p; simpl in *. generalize dependent SDomain. induction l; destruct SDomain; simpl in *; intros; auto; try (congruence || reflexivity).
      consider (is_well_typed (typeof_funcs funcs) (typeof_env uvars) (typeof_env vars) a t); intros.
      eapply is_well_typed_correct in H. destruct H. rewrite H.
      rewrite IHl. reflexivity. auto.
      eauto using typeof_env_WellTyped_env.
      eauto using typeof_env_WellTyped_env.
      eauto using typeof_funcs_WellTyped_funcs.
      consider (exprD funcs uvars vars a t); intros; try reflexivity.
      eapply is_well_typed_correct_only in H1; eauto using typeof_env_WellTyped_env, typeof_funcs_WellTyped_funcs. congruence. }
  Qed.

  Theorem himp_WellTyped_sexpr : forall ts funcs (preds : SE.predicates ts) s vars uvars Q,
    (SE.WellTyped_sexpr (typeof_funcs funcs) (SE.typeof_preds preds) (typeof_env uvars) (typeof_env vars) s = true ->
     ST.himp (SE.sexprD funcs preds uvars vars s) Q) ->
    ST.himp (SE.sexprD funcs preds uvars vars s) Q.
  Proof.
    intros. consider (SE.WellTyped_sexpr (typeof_funcs funcs) (SE.typeof_preds preds)
        (typeof_env uvars) (typeof_env vars) s); intros; auto.
    rewrite himp_not_WellTyped_sexpr; auto.
    rewrite <- ST.heq_star_emp_r.
    eapply ST.himp_star_pure_c; contradiction.
  Qed.

  Module ST_EXT := SepTheory.SepTheory_Ext ST.

  Lemma himp_existsEach_ST_EXT_existsEach : forall types funcs preds U (P : SE.sexpr types) vars G,
    ST.heq (SE.sexprD funcs preds U G (SE.existsEach vars P))
           (ST_EXT.existsEach vars (fun env => SE.sexprD funcs preds U (rev env ++ G) P)).
  Proof.
    Opaque ST_EXT.existsEach.
    induction vars; simpl; intros. rewrite ST_EXT.existsEach_nil. simpl. reflexivity.
    change (a :: vars) with ((a :: nil) ++ vars). rewrite ST_EXT.existsEach_app.
    rewrite ST_EXT.existsEach_cons. apply ST.heq_ex. intros. rewrite ST_EXT.existsEach_nil. rewrite IHvars.
    simpl. eapply ST_EXT.heq_existsEach. intros. rewrite app_ass. reflexivity.
  Qed.

  Theorem WellTyped_sexpr_weaken : forall ts tf tp U U' r G G',
    SE.WellTyped_sexpr (types := ts) tf tp U G r = true ->
    SE.WellTyped_sexpr tf tp (U ++ U') (G ++ G') r = true.
  Proof.
    clear. induction r; simpl in *; intros; auto.
    { eapply is_well_typed_weaken. auto. }
    { repeat rewrite andb_true_iff in *. intuition. }
    { change (t :: G ++ G') with ((t :: G) ++ G'). eapply IHr; auto. }
    { destruct (nth_error tp f); auto. eapply all2_is_well_typed_weaken. auto. }
  Qed.

End SepExprFacts.

Module Make (ST : SepTheory.SepTheory) <: SepExpr ST.
  Section env.
    Variable types : list type.
    Variable pcType : tvar.
    Variable stateType : tvar.

    Record predicate := PSig
    { SDomain : list tvar
    ; SDenotation : functionTypeD (map (@tvarD types) SDomain) ST.hprop
    }.

    Definition predicates := list predicate.

    Definition Default_predicate : predicate :=
    {| SDomain := nil
     ; SDenotation := ST.emp
     |} .

    Inductive sexpr : Type :=
    | Emp : sexpr
    | Inj : expr types -> sexpr
    | Star : sexpr -> sexpr -> sexpr
    | Exists : tvar -> sexpr -> sexpr
    | Func : func -> list (expr types) -> sexpr
    | Const : ST.hprop -> sexpr
    .

    Definition tpredicate : Type := list tvar.
    Definition tpredicates : Type := list tpredicate.

    Definition typeof_pred : predicate -> tpredicate := SDomain.
    Definition typeof_preds : predicates -> tpredicates := map typeof_pred.

    Section types.
      Variable funcs : tfunctions.
      Variable preds : tpredicates.
      Variable tU : tenv.

      Fixpoint WellTyped_sexpr (tG : tenv) (s : sexpr) : bool :=
        match s with
          | Emp => true
          | Inj e => is_well_typed funcs tU tG e tvProp
          | Star l r => WellTyped_sexpr tG l && WellTyped_sexpr tG r
          | Exists t e => WellTyped_sexpr (t :: tG) e
          | Func f args =>
            match nth_error preds f with
              | None => false
              | Some ts => all2 (is_well_typed funcs tU tG) args ts
            end
          | Const _ => true
        end.

    End types.

    Variable funcs : functions types.
    Variable sfuncs : predicates.
    Variable meta_env : env types.

    Fixpoint sexprD (var_env : env types) (s : sexpr) : ST.hprop :=
      match s with
        | Emp => ST.emp
        | Inj p =>
          match exprD funcs meta_env var_env p tvProp with
            | None => ST.inj (BadInj p)
            | Some p => ST.inj p
          end
        | Star l r =>
          ST.star (sexprD var_env l) (sexprD var_env r)
        | Exists t b =>
          ST.ex (fun x : tvarD types t => sexprD (@existT _ _ t x :: var_env) b)
        | Func f b =>
          match nth_error sfuncs f with
            | None => ST.inj (BadPred f)
            | Some f' =>
              match applyD (@exprD types funcs meta_env var_env) (SDomain f') b _ (SDenotation f') with
                | None => ST.inj (BadPredApply f b var_env)
                | Some p => p
              end
          end
        | Const p => p
      end.

    Definition himp (var_env : env types)
      (gl gr : sexpr) : Prop :=
      ST.himp (sexprD var_env gl) (sexprD var_env gr).

    Definition heq (var_env : env types)
      (gl gr : sexpr) : Prop :=
      ST.heq (sexprD var_env gl) (sexprD var_env gr).

    Fixpoint existsEach (ls : list tvar) {struct ls} : sexpr -> sexpr :=
      match ls with
        | nil => fun x => x
        | t :: ts => fun y => Exists t (@existsEach ts y)
      end.

    Fixpoint liftSExpr ua ub a b s : sexpr :=
      match s with
        | Emp => Emp
        | Const c => Const c
        | Inj p => Inj (liftExpr ua ub a b p)
        | Star l r => Star (liftSExpr ua ub a b l) (liftSExpr ua ub a b r)
        | Exists t s => Exists t (liftSExpr ua ub (S a) b s)
        | Func f args => Func f (map (liftExpr ua ub a b) args)
      end.

  End env.
End Make.


From stdpp Require Export namespaces.
From iris.proofmode Require Import tactics.
From iris.algebra Require Import gmap.
From iris.base_logic.lib Require Export fancy_updates.
From iris.base_logic.lib Require Import wsat.
From iris Require Import options.
Import uPred.

(** Semantic Invariants *)
Definition inv_def `{!invG Σ} (N : namespace) (P : iProp Σ) : iProp Σ :=
  □ ∀ E, ⌜↑N ⊆ E⌝ → |={E,E ∖ ↑N}=> ▷ P ∗ (▷ P ={E ∖ ↑N,E}=∗ True).
Definition inv_aux : seal (@inv_def). Proof. by eexists. Qed.
Definition inv := inv_aux.(unseal).
Arguments inv {Σ _} N P.
Definition inv_eq : @inv = @inv_def := inv_aux.(seal_eq).
Instance: Params (@inv) 3 := {}.

(** * Invariants *)
Section inv.
  Context `{!invG Σ}.
  Implicit Types i : positive.
  Implicit Types N : namespace.
  Implicit Types E : coPset.
  Implicit Types P Q R : iProp Σ.

  (** ** Internal model of invariants *)
  Definition own_inv (N : namespace) (P : iProp Σ) : iProp Σ :=
    ∃ i, ⌜i ∈ (↑N:coPset)⌝ ∧ ownI i P.

  Lemma own_inv_acc E N P :
    ↑N ⊆ E → own_inv N P ={E,E∖↑N}=∗ ▷ P ∗ (▷ P ={E∖↑N,E}=∗ True).
  Proof.
    rewrite uPred_fupd_eq /uPred_fupd_def. iDestruct 1 as (i) "[Hi #HiP]".
    iDestruct "Hi" as % ?%elem_of_subseteq_singleton.
    rewrite {1 4}(union_difference_L (↑ N) E) // ownE_op; last set_solver.
    rewrite {1 5}(union_difference_L {[ i ]} (↑ N)) // ownE_op; last set_solver.
    iIntros "(Hw & [HE $] & $) !> !>".
    iDestruct (ownI_open i with "[$Hw $HE $HiP]") as "($ & $ & HD)".
    iIntros "HP [Hw $] !> !>". iApply (ownI_close _ P). by iFrame.
  Qed.

  Lemma fresh_inv_name (E : gset positive) N : ∃ i, i ∉ E ∧ i ∈ (↑N:coPset).
  Proof.
    exists (coPpick (↑ N ∖ gset_to_coPset E)).
    rewrite -elem_of_gset_to_coPset (comm and) -elem_of_difference.
    apply coPpick_elem_of=> Hfin.
    eapply nclose_infinite, (difference_finite_inv _ _), Hfin.
    apply gset_to_coPset_finite.
  Qed.

  Lemma own_inv_alloc N E P : ▷ P ={E}=∗ own_inv N P.
  Proof.
    rewrite uPred_fupd_eq. iIntros "HP [Hw $]".
    iMod (ownI_alloc (.∈ (↑N : coPset)) P with "[$HP $Hw]")
      as (i ?) "[$ ?]"; auto using fresh_inv_name.
    do 2 iModIntro. iExists i. auto.
  Qed.

  (* This does not imply [own_inv_alloc] due to the extra assumption [↑N ⊆ E]. *)
  Lemma own_inv_alloc_open N E P :
    ↑N ⊆ E → ⊢ |={E, E∖↑N}=> own_inv N P ∗ (▷P ={E∖↑N, E}=∗ True).
  Proof.
    rewrite uPred_fupd_eq. iIntros (Sub) "[Hw HE]".
    iMod (ownI_alloc_open (.∈ (↑N : coPset)) P with "Hw")
      as (i ?) "(Hw & #Hi & HD)"; auto using fresh_inv_name.
    iAssert (ownE {[i]} ∗ ownE (↑ N ∖ {[i]}) ∗ ownE (E ∖ ↑ N))%I
      with "[HE]" as "(HEi & HEN\i & HE\N)".
    { rewrite -?ownE_op; [|set_solver..].
      rewrite assoc_L -!union_difference_L //. set_solver. }
    do 2 iModIntro. iFrame "HE\N". iSplitL "Hw HEi"; first by iApply "Hw".
    iSplitL "Hi".
    { iExists i. auto. }
    iIntros "HP [Hw HE\N]".
    iDestruct (ownI_close with "[$Hw $Hi $HP $HD]") as "[$ HEi]".
    do 2 iModIntro. iSplitL; [|done].
    iCombine "HEi HEN\i HE\N" as "HEN".
    rewrite -?ownE_op; [|set_solver..].
    rewrite assoc_L -!union_difference_L //; set_solver.
  Qed.

  Lemma own_inv_to_inv M P: own_inv M P -∗ inv M P.
  Proof.
    iIntros "#I". rewrite inv_eq. iIntros (E H).
    iPoseProof (own_inv_acc with "I") as "H"; eauto.
  Qed.

  (** ** Public API of invariants *)
  Global Instance inv_contractive N : Contractive (inv N).
  Proof. rewrite inv_eq. solve_contractive. Qed.

  Global Instance inv_ne N : NonExpansive (inv N).
  Proof. apply contractive_ne, _. Qed.

  Global Instance inv_proper N : Proper (equiv ==> equiv) (inv N).
  Proof. apply ne_proper, _. Qed.

  Global Instance inv_persistent N P : Persistent (inv N P).
  Proof. rewrite inv_eq. apply _. Qed.

  Lemma inv_alter N P Q : inv N P -∗ ▷ □ (P -∗ Q ∗ (Q -∗ P)) -∗ inv N Q.
  Proof.
    rewrite inv_eq. iIntros "#HI #HPQ !>" (E H).
    iMod ("HI" $! E H) as "[HP Hclose]".
    iDestruct ("HPQ" with "HP") as "[$ HQP]".
    iIntros "!> HQ". iApply "Hclose". iApply "HQP". done.
  Qed.

  Lemma inv_iff N P Q : inv N P -∗ ▷ □ (P ↔ Q) -∗ inv N Q.
  Proof.
    iIntros "#HI #HPQ". iApply (inv_alter with "HI").
    iIntros "!> !> HP". iSplitL "HP".
    - by iApply "HPQ".
    - iIntros "HQ". by iApply "HPQ".
  Qed.

  Lemma inv_alloc N E P : ▷ P ={E}=∗ inv N P.
  Proof.
    iIntros "HP". iApply own_inv_to_inv.
    iApply (own_inv_alloc N E with "HP").
  Qed.

  Lemma inv_alloc_open N E P :
    ↑N ⊆ E → ⊢ |={E, E∖↑N}=> inv N P ∗ (▷P ={E∖↑N, E}=∗ True).
  Proof.
    iIntros (?). iMod own_inv_alloc_open as "[HI $]"; first done.
    iApply own_inv_to_inv. done.
  Qed.

  Lemma inv_acc E N P :
    ↑N ⊆ E → inv N P ={E,E∖↑N}=∗ ▷ P ∗ (▷ P ={E∖↑N,E}=∗ True).
  Proof.
    rewrite inv_eq /inv_def; iIntros (?) "#HI". by iApply "HI".
  Qed.

  Lemma inv_combine N1 N2 N P Q :
    N1 ## N2 →
    ↑N1 ∪ ↑N2 ⊆@{coPset} ↑N →
    inv N1 P -∗ inv N2 Q -∗ inv N (P ∗ Q).
  Proof.
    rewrite inv_eq. iIntros (??) "#HinvP #HinvQ !>"; iIntros (E ?).
    iMod ("HinvP" with "[%]") as "[$ HcloseP]"; first set_solver.
    iMod ("HinvQ" with "[%]") as "[$ HcloseQ]"; first set_solver.
    iMod (fupd_intro_mask' _ (E ∖ ↑N)) as "Hclose"; first set_solver.
    iIntros "!> [HP HQ]".
    iMod "Hclose" as %_. iMod ("HcloseQ" with "HQ") as %_. by iApply "HcloseP".
  Qed.

  Lemma inv_combine_dup_l N P Q :
    □ (P -∗ P ∗ P) -∗
    inv N P -∗ inv N Q -∗ inv N (P ∗ Q).
  Proof.
    rewrite inv_eq. iIntros "#HPdup #HinvP #HinvQ !>" (E ?).
    iMod ("HinvP" with "[//]") as "[HP HcloseP]".
    iDestruct ("HPdup" with "HP") as "[$ HP]".
    iMod ("HcloseP" with "HP") as %_.
    iMod ("HinvQ" with "[//]") as "[$ HcloseQ]".
    iIntros "!> [HP HQ]". by iApply "HcloseQ".
  Qed.

  (** ** Proof mode integration *)
  Global Instance into_inv_inv N P : IntoInv (inv N P) N := {}.

  Global Instance into_acc_inv N P E:
    IntoAcc (X := unit) (inv N P)
            (↑N ⊆ E) True (fupd E (E ∖ ↑N)) (fupd (E ∖ ↑N) E)
            (λ _ : (), (▷ P)%I) (λ _ : (), (▷ P)%I) (λ _ : (), None).
  Proof.
    rewrite inv_eq /IntoAcc /accessor bi.exist_unit.
    iIntros (?) "#Hinv _". iApply "Hinv"; done.
  Qed.

  (** ** Derived properties *)
  Lemma inv_acc_strong E N P :
    ↑N ⊆ E → inv N P ={E,E∖↑N}=∗ ▷ P ∗ ∀ E', ▷ P ={E',↑N ∪ E'}=∗ True.
  Proof.
    iIntros (?) "Hinv".
    iPoseProof (inv_acc (↑ N) N with "Hinv") as "H"; first done.
    rewrite difference_diag_L.
    iPoseProof (fupd_mask_frame_r _ _ (E ∖ ↑ N) with "H") as "H"; first set_solver.
    rewrite left_id_L -union_difference_L //. iMod "H" as "[$ H]"; iModIntro.
    iIntros (E') "HP".
    iPoseProof (fupd_mask_frame_r _ _ E' with "(H HP)") as "H"; first set_solver.
    by rewrite left_id_L.
  Qed.

  Lemma inv_acc_timeless E N P `{!Timeless P} :
    ↑N ⊆ E → inv N P ={E,E∖↑N}=∗ P ∗ (P ={E∖↑N,E}=∗ True).
  Proof.
    iIntros (?) "Hinv". iMod (inv_acc with "Hinv") as "[>HP Hclose]"; auto.
    iIntros "!> {$HP} HP". iApply "Hclose"; auto.
  Qed.

  Lemma inv_split_l N P Q : inv N (P ∗ Q) -∗ inv N P.
  Proof.
    iIntros "#HI". iApply inv_alter; eauto.
    iIntros "!> !> [$ $] $".
  Qed.
  Lemma inv_split_r N P Q : inv N (P ∗ Q) -∗ inv N Q.
  Proof.
    rewrite (comm _ P Q). eapply inv_split_l.
  Qed.
  Lemma inv_split N P Q : inv N (P ∗ Q) -∗ inv N P ∗ inv N Q.
  Proof.
    iIntros "#H".
    iPoseProof (inv_split_l with "H") as "$".
    iPoseProof (inv_split_r with "H") as "$".
  Qed.

End inv.


(*

  Copyright 2014 Cornell University
  Copyright 2015 Cornell University
  Copyright 2016 Cornell University
  Copyright 2017 Cornell University

  This file is part of VPrl (the Verified Nuprl project).

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

  VPrl 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 General Public License
  along with VPrl.  If not, see <http://www.gnu.org/licenses/>.

  Websites: http://nuprl.org/html/verification/
            http://nuprl.org/html/Nuprl2Coq
            https://github.com/vrahli/NuprlInCoq

  Authors: Vincent Rahli

 *)

Require Export per_props_function.
Require Export list. (* WTF?? *)

Lemma equality_in_w {p} :
  forall lib (s1 s2 : @CTerm p) A v B,
    equality lib s1 s2 (mkc_w A v B)
    <=>
    {eqa : per
     , {eqb : (forall a a' : CTerm, forall e : eqa a a', per)
        , nuprl lib A A eqa
        # (forall a a' : CTerm,
           forall e : eqa a a',
             nuprl lib (substc a v B) (substc a' v B) (eqb a a' e))
        # weq lib eqa eqb s1 s2}}.
Proof.
  introv; sp_iff Case; introv e.

  - unfold equality in e; exrepnd.
    unfold nuprl in e1.
    inversion e1; try not_univ.
    allunfold @per_w; allunfold @type_family; exrepnd.
    computes_to_value_isvalue.
    allfold (@nuprl p lib).
    exists eqa eqb; sp.
    allunfold @eq_term_equals; discover; sp.

  - exrepnd.
    exists (weq lib eqa eqb); sp.
    apply CL_w.
    exists eqa eqb; sp.
    exists A A v v B B; sp; spcast; computes_to_value_refl.
Qed.

(**

  Using the Coq induction principle we obtain for [weq], we can prove
  the following induction principle for our W types.  The then use
  this principle to prove the [rule_w_induction] rule below.

*)

Lemma w_ind_eq {p} :
  forall lib (A : @CTerm p) va B (Q : CTerm -> CTerm -> [U]),
    (forall t1 t2 t3 t4, cequivc lib t1 t3 -> cequivc lib t2 t4 -> Q t1 t2 -> Q t3 t4)
    -> (forall a1 a2 f1 f2,
          equality lib a1 a2 A
          -> equality lib f1 f2 (mkc_fun (substc a1 va B) (mkc_w A va B))
          -> (forall b1 b2,
                equality lib b1 b2 (substc a1 va B)
                -> Q (mkc_apply f1 b1) (mkc_apply f2 b2))
          -> Q (mkc_sup a1 f1) (mkc_sup a2 f2))
    -> (forall w1 w2, equality lib w1 w2 (mkc_w A va B) -> Q w1 w2).
Proof.
  introv ceq ind e.
  rw @equality_in_w in e; exrepnd.
  induction e1; spcast.
  apply ceq with (t1 := mkc_sup a f) (t2 := mkc_sup a' f');
    try (complete (apply cequivc_sym; apply computes_to_valc_implies_cequivc; sp)).

  assert (eqa a' a')
         as e'
         by (eapply equality_eq_refl; eauto;
             eapply equality_eq_sym; eauto).

  apply ind; try (complete (exists eqa; sp)).

  rw <- @fold_mkc_fun.
  rw @equality_in_function.
  dands.

  (* 1 *)
  exists (eqb a a' e); sp.
  generalize (e2 a a' e); intro n.
  apply nuprl_refl in n; sp.

  (* 2 *)
  introv eq.
  allrw @substc_cnewvar.
  exists (weq lib eqa eqb); sp.
  apply CL_w; unfold per_w; unfold type_family.
  exists eqa eqb; sp.
  exists A A va va B B; sp; spcast; apply computes_to_valc_refl; apply iscvalue_mkc_w.

  (* 3 *)
  introv eq.
  allrw @substc_cnewvar.
  rw @equality_in_w.
  exists eqa eqb; sp.
  apply_hyp.
  unfold equality in eq; exrepnd.
  generalize (e2 a a' e); intro n.
  assert (eq_term_equals eq0 (eqb a a' e)) as eqt;
    try (complete (eapply nuprl_uniquely_valued; eauto;
                   allapply @nuprl_refl; sp)).

  (* 4 *)
  introv eq.
  apply_hyp; sp.
  unfold equality in eq; exrepnd.
  generalize (e2 a a' e); intro n.
  assert (eq_term_equals eq0 (eqb a a' e)) as eqt;
    try (complete (eapply nuprl_uniquely_valued; eauto;
                   allapply @nuprl_refl; sp)).
Qed.

(* begin hide *)

Lemma w_ind_eq2 {p} :
  forall lib (A : @CTerm p) va B (Q : CTerm -> [U]),
    (forall t1 t2, cequivc lib t1 t2 -> Q t1 -> Q t2)
    -> (forall a1 a2 f1 f2,
          equality lib a1 a2 A
          -> equality lib f1 f2 (mkc_fun (substc a1 va B) (mkc_w A va B))
          -> (forall b1 b2,
                equality lib b1 b2 (substc a1 va B)
                -> Q (mkc_apply f1 b1))
          -> Q (mkc_sup a1 f1))
    -> (forall w1 w2, equality lib w1 w2 (mkc_w A va B) -> Q w1).
Proof.
  introv ceq ind e.
  generalize (w_ind_eq lib A va B (fun t1 t2 => Q t1)).
  intro h.
  dest_imp h hyp.
  introv c1 c2 q1.
  apply ceq with (t1 := t1); sp.
  apply h with (w2 := w2); sp.
Qed.

Lemma w_ind {p} :
  forall lib (A : @CTerm p) va B (Q : CTerm -> Prop),
    (forall t t', cequivc lib t t' -> Q t -> Q t')
    -> (forall a f,
          member lib a A
          -> member lib f (mkc_fun (substc a va B) (mkc_w A va B))
          -> Q (mkc_sup a f))
    -> (forall w, member lib w (mkc_w A va B) -> Q w).
Proof.
  introv ceq ind m.
  generalize (w_ind_eq lib A va B (fun t1 t2 => Q t1)); intro i.
  apply i with (w2 := w); sp.
  apply ceq with (t := t1); sp.
  apply ind; allapply @equality_refl; sp.
Qed.

Lemma equality_in_pw {o} :
  forall lib (s1 s2 : @CTerm o) P ap A bp ba B cp ca cb C p,
    equality lib s1 s2 (mkc_pw P ap A bp ba B cp ca cb C p)
    <=>
    {eqp : per
     , {eqa : (forall p p' : CTerm, forall ep : eqp p p', per)
     , {eqb : (forall p p' : CTerm,
               forall ep : eqp p p',
               forall a a' : CTerm,
               forall ea : eqa p p' ep a a',
                 per)
        , nuprl lib P P eqp
        # (forall p p' : CTerm,
           forall ep : eqp p p',
             nuprl lib (substc p ap A) (substc p' ap A) (eqa p p' ep))
        # (forall p p' : CTerm,
           forall ep : eqp p p',
           forall a a' : CTerm,
           forall ea : eqa p p' ep a a',
             nuprl lib (lsubstc2 bp p ba a B)
                   (lsubstc2 bp p' ba a' B)
                   (eqb p p' ep a a' ea))
        # (forall p p',
           forall ep : eqp p p',
           forall a a',
           forall ea : eqa p p' ep a a',
           forall b b',
           forall eb : eqb p p' ep a a' ea b b',
             eqp (lsubstc3 cp p ca a cb b C)
                 (lsubstc3 cp p' ca a' cb b' C))
        # eqp p p
        # pweq lib eqp eqa eqb cp ca cb C p s1 s2}}}.
Proof.
  introv; sp_iff Case; introv e.

  - unfold equality in e; exrepnd.
    unfold nuprl in e1.
    inversion e1; try not_univ.
    allunfold @per_pw; allunfold @type_pfamily; exrepnd.
    computes_to_value_isvalue.
    allfold (@nuprl o).
    exists eqp eqa eqb; sp.
    allunfold @eq_term_equals; discover; sp.

  - exrepnd.
    exists (pweq lib eqp eqa eqb cp ca cb C p); sp.
    apply CL_pw.
    exists eqp eqa eqb p p; sp.
    exists cp cp ca ca cb cb C C; sp.
    exists P P ap ap A A bp bp.
    exists ba ba B B; sp; spcast; computes_to_value_refl.
Qed.

Lemma isprog_vars_lsubstc3v3 {p} :
  forall v1 u1 v2 u2 v3 u3 (t : @CVTerm p [v1,v2,v3]),
    isprog_vars
      [u3]
      (lsubst (get_cvterm [v1;v2;v3] t)
              [(v1,get_cterm u1),(v2,get_cterm u2),(v3,mk_var u3)]).
Proof.
  introv.
  destruct_cterms.
  rw @isprog_vars_eq; simpl; dands.

  generalize (eqvars_free_vars_disjoint x1 [(v1, x0), (v2, x), (v3, mk_var u3)]);
    introv eqv.
  rw eqvars_prop in eqv.
  rw subvars_prop; introv k.
  rw in_single_iff.
  apply eqv in k; clear eqv.
  apply isprog_vars_eq in i1; repnd.
  rw in_app_iff in k; rw in_remove_nvars in k; repdors; repnd.

  simpl in k0; repeat (rw not_over_or in k0); repnd.
  rw subvars_prop in i2.
  apply i2 in k1; simpl in k1; sp.

  revert k; simpl; boolvar; simpl;
  allrw in_app_iff; allrw in_single_iff; allrw in_remove_nvar; repnd;
  allrw @isprog_eq; allunfold @isprogram; repnd; allrw; simpl;
  intro k; repdors; try (complete sp).

  apply isprog_vars_eq in i1; repnd.
  apply lsubst_wf_iff; sp.
  unfold wf_sub, sub_range_sat; simpl; introv k; repdors; cpx;
  allrw @isprog_eq; allunfold @isprogram; sp.
Qed.

Definition lsubstc3v3 {p} (v1 : NVar) (u1 : @CTerm p)
                      (v2 : NVar) (u2 : CTerm)
                      (v3 : NVar) (u3 : NVar)
                      (t : CVTerm [v1;v2;v3]) : CVTerm [u3] :=
  exist (isprog_vars [u3])
        (lsubst (get_cvterm [v1;v2;v3] t)
                [(v1,get_cterm u1),(v2,get_cterm u2),(v3,mk_var u3)])
        (isprog_vars_lsubstc3v3 v1 u1 v2 u2 v3 u3 t).

Lemma lsubst_mk_pw {o} :
  forall (P : @NTerm o) ap A bp ba B cp ca cb C p sub,
    prog_sub sub
    -> isprog P
    -> isprog_vars [ap] A
    -> isprog_vars [bp;ba] B
    -> isprog_vars [cp;ca;cb] C
    -> isprog_vars (dom_sub sub) p
    -> lsubst (mk_pw P ap A bp ba B cp ca cb C p) sub
       = mk_pw P ap A bp ba B cp ca cb C (lsubst p sub).
Proof.
  introv ps iP iA iB iC ip.
  change_to_lsubst_aux4.
  simpl.
  allrw @fold_nobnd.
  rw @fold_pw; simpl.
  allrw @sub_filter_nil_r.

  assert (lsubst_aux P sub = P) as eqP.
  apply lsubst_aux_trivial; introv i; discover; dands; try (complete sp).
  intro j.
  allrw @isprog_eq; allunfold @isprogram; repnd.
  rw iP0 in j; sp.
  rw eqP.

  assert (lsubst_aux A (sub_filter sub [ap]) = A) as eqA.
  apply lsubst_aux_trivial; introv i.
  apply in_sub_filter in i; repnd; discover; dands; try (complete sp).
  intro j.
  rw @isprog_vars_eq in iA; repnd.
  rw subvars_prop in iA0; apply iA0 in j; sp.
  rw eqA.

  assert (lsubst_aux B (sub_filter sub [bp,ba]) = B) as eqB.
  apply lsubst_aux_trivial; introv i.
  apply in_sub_filter in i; repnd; discover; dands; try (complete sp).
  intro j.
  rw @isprog_vars_eq in iB; repnd.
  rw subvars_prop in iB0; apply iB0 in j; sp.
  rw eqB.

  assert (lsubst_aux C (sub_filter sub [cp,ca,cb]) = C) as eqC.
  apply lsubst_aux_trivial; introv i.
  apply in_sub_filter in i; repnd; discover; dands; try (complete sp).
  intro j.
  rw @isprog_vars_eq in iC; repnd.
  rw subvars_prop in iC0; apply iC0 in j; sp.
  rw eqC.

  sp.
Qed.

Ltac cpx2 :=
  match goal with
    | [ H1 : closed ?x, H2 : LIn ?v (free_vars ?x) |- _ ] =>
        rewrite H1 in H2; simpl in H2; complete (destruct H2)
  end.

Lemma substc_mkc_pw_vs {o} :
  forall (p : @CTerm o) a b v P ap A bp ba B cp ca cb C,
    !LIn v (bound_vars (get_cvterm [cp;ca;cb] C))
    -> substc b v
              (mkc_pw_vs [v] P ap A bp ba B cp ca cb C
                         (lsubstc3v3 cp p ca a cb v C))
       = mkc_pw P ap A bp ba B cp ca cb C (lsubstc3 cp p ca a cb b C).
Proof.
  introv niv.
  destruct_cterms; simpl.
  apply cterm_eq; simpl.
  unfold csubst, subst; simpl.
  rw @lsubst_mk_pw;
    try (complete sp);
    try (complete (unfold prog_sub, sub_range_sat; simpl; sp; cpx; rw @isprogram_eq; sp)).

  rw @simple_lsubst_lsubst; simpl.

  assert (lsubst x2 [(v, x0)] = x2) as eq.
  rw @lsubst_trivial; allsimpl; try (complete sp); introv k; repdors; cpx.
  allrw @isprog_eq; dands; try (complete sp); allunfold @isprogram; repnd; allrw; sp.
  rw eq; clear eq.

  assert (lsubst x1 [(v, x0)] = x1) as eq.
  rw @lsubst_trivial; allsimpl; try (complete sp); introv k; repdors; cpx.
  allrw @isprog_eq; dands; try (complete sp); allunfold @isprogram; repnd; allrw; sp.
  rw eq; clear eq.

  assert (lsubst (mk_var v) [(v, x0)] = x0) as eq.
  change_to_lsubst_aux4; simpl; boolvar; sp.
  rw eq; clear eq.

  assert (lsubst x3 [(cp, x2), (ca, x1), (cb, x0), (v, x0)]
          = lsubst x3 [(cp, x2), (ca, x1), (cb, x0)]) as eq.
  clear niv.
  generalize (in_deq NVar deq_nvar v [cp,ca,cb]); intro k; destruct k as [k | k]; simpl in k.
  (* v in list *)
  assert ([(cp, x2), (ca, x1), (cb, x0), (v, x0)] = snoc [(cp, x2), (ca, x1), (cb, x0)] (v, x0)) as e by sp.
  rw e; clear e.
  rw @lsubst_snoc_dup; try (complete sp).
  introv j; simpl in j; repdors; cpx; allrw @isprog_eq; sp.
  allrw @isprog_eq; sp.
  (* v not in list *)
  allrw not_over_or; repnd.
  allrw @isprog_vars_eq; repnd.
  allrw subvars_prop; allsimpl.
  rw @simple_lsubst_trim.
  symmetry.
  rw @simple_lsubst_trim.
  simpl; boolvar; try (complete sp); discover; repdors; try subst; try (complete sp).
  introv j; simpl in j; repdors; cpx; allrw @isprog_eq; allunfold @isprogram; repnd; allrw; simpl; try (complete sp).
  introv j; simpl in j; repdors; cpx; allrw @isprog_eq; allunfold @isprogram; repnd; allrw; simpl; try (complete sp).
  rw eq; sp.

  introv k; repdors; cpx; try (complete sp);
  allrw @isprog_eq; allunfold @isprogram; repnd; allrw; sp; simpl.
  rw disjoint_singleton_l.
  exact niv.

  introv k; repdors; cpx; try (complete sp); allrw @isprog_eq; sp.

  clear niv; simpl; rw @isprog_vars_eq; simpl; sp.

  rw @isprog_vars_eq in i3; repnd.
  rw subvars_prop in i6.
  generalize (eqvars_free_vars_disjoint x3 [(cp, x2), (ca, x1), (cb, mk_var v)]); intro eqv.
  rw subvars_prop; introv j; rw eqvars_prop in eqv; apply eqv in j.
  rw in_single_iff.
  rw in_app_iff in j; rw in_remove_nvars in j; repdors; repnd.
  simpl in j0; repeat (rw not_over_or in j0); repnd; discover; allsimpl; sp.
  apply in_sub_free_vars in j; exrepnd.
  revert j0; simpl; boolvar; simpl; introv k; repdors; cpx;
  allrw @isprog_eq; allunfold @isprogram; repnd; try cpx2.

  allrw @isprog_eq; allrw @isprog_vars_eq; allunfold @isprogram; repnd.
  apply lsubst_wf_iff; sp.
  unfold wf_sub, sub_range_sat; simpl; introv k; repdors; cpx.
Qed.

Lemma param_w_ind {o} :
  forall lib (P : @CTerm o) ap A bp ba B cp ca cb C (Q : CTerm -> CTerm -> CTerm -> [U]),
    (forall p t1 t2 t3 t4, cequivc lib t1 t3 -> cequivc lib t2 t4 -> Q p t1 t2 -> Q p t3 t4)
    -> (forall p a1 a2 f1 f2 vb,
       equality lib a1 a2 (substc p ap A)
       -> equality lib f1 f2 (mkc_function
                            (lsubstc2 bp p ba a1 B)
                            vb
                            (mkc_pw_vs [vb]
                                       P ap A bp ba B cp ca cb C
                                       (lsubstc3v3 cp p ca a1 cb vb C)))
       -> (forall b1 b2,
             equality lib b1 b2 (lsubstc2 bp p ba a1 B)
             -> Q (lsubstc3 cp p ca a1 cb b1 C)
                  (mkc_apply f1 b1)
                  (mkc_apply f2 b2))
       -> Q p
            (mkc_sup a1 f1)
            (mkc_sup a2 f2))
    -> (forall p w1 w2,
          equality lib w1 w2 (mkc_pw P ap A bp ba B cp ca cb C p)
          -> Q p w1 w2).
Proof.
  introv ceq ind e.
  apply equality_in_pw in e; exrepnd.
  induction e0; spcast.
  apply ceq with (t1 := mkc_sup a1 f1) (t2 := mkc_sup a2 f2);
    try (complete (apply cequivc_sym; apply computes_to_valc_implies_cequivc; sp)).

  assert (eqa p p ep a2 a2)
         as ea2
         by (generalize (e2 p p ep); intro na;
             apply (equality_eq_refl lib) with (A := substc p ap A) (B := substc p ap A) (b := a1); sp;
             apply (equality_eq_sym lib) with (A := substc p ap A) (B := substc p ap A); sp).

  assert ({v : NVar, !LIn v (bound_vars (get_cvterm [cp, ca, cb] C))})
         as ev
         by (exists (fresh_var (bound_vars (get_cvterm [cp, ca, cb] C)));
             apply fresh_var_not_in); exrepnd.

  apply ind with (vb := v); try (complete (exists (eqa p p ep); sp)).

  rw @equality_in_function.
  dands.

  (* 1 *)
  exists (eqb p p ep a1 a2 ea); sp.
  generalize (e3 p p ep a1 a2 ea); intro n.
  apply nuprl_refl in n; sp.

  (* 2 *)
  intros b b' eq.
  rw @substc_mkc_pw_vs; simpl; try (complete sp).
  rw @substc_mkc_pw_vs; simpl; try (complete sp).
  exists (pweq lib eqp eqa eqb cp ca cb C (lsubstc3 cp p ca a1 cb b C)); sp.
  apply CL_pw; unfold per_pw; unfold type_pfamily.
  exists eqp eqa eqb (lsubstc3 cp p ca a1 cb b C) (lsubstc3 cp p ca a1 cb b' C).
  exists cp cp ca ca cb cb C C; sp.
  exists P P ap ap A A.
  exists bp bp ba ba B B; sp; spcast; try (apply computes_to_valc_refl; apply iscvalue_mkc_pw).
  assert (eqa p p ep a1 a1)
         as ea1
         by (eapply equality_eq_refl; eauto).
  apply e4 with (ep := ep) (ea := ea1).
  unfold equality in eq; exrepnd.
  generalize (e3 p p ep a1 a1 ea1); intro n.
  assert (eq_term_equals eq0 (eqb p p ep a1 a1 ea1))
         as eqt
         by (apply (nuprl_uniquely_valued lib) with (t := lsubstc2 bp p ba a1 B); sp;
             allapply nuprl_refl; sp).
  rw <- eqt; sp.

  (* 3 *)
  intros b b' eq.
  rw @substc_mkc_pw_vs; simpl; try (complete sp).
  apply equality_in_pw.
  exists eqp eqa eqb; dands; try (complete sp).

  assert (eqa p p ep a1 a1)
         as ea1
         by (eapply equality_eq_refl; eauto).
  apply e4 with (ep := ep) (ea := ea1).
  unfold equality in eq; exrepnd.
  generalize (e3 p p ep a1 a1 ea1); intro n.
  assert (eq_term_equals eq0 (eqb p p ep a1 a1 ea1))
         as eqt
         by (apply (nuprl_uniquely_valued lib) with (t := lsubstc2 bp p ba a1 B); sp;
             allapply nuprl_refl; sp).
  rw <- eqt; sp.
  eapply equality_eq_refl; eauto.

  apply_hyp.
  unfold equality in eq; exrepnd.
  generalize (e3 p p ep a1 a2 ea); intro n.
  assert (eq_term_equals eq0 (eqb p p ep a1 a2 ea))
         as eqt
         by (eapply nuprl_uniquely_valued; eauto;
             allapply @nuprl_refl; sp).
  rw <- eqt; sp.

  (* 4 *)
  intros b b' eq.
  apply_hyp.
  unfold equality in eq; exrepnd.
  generalize (e3 p p ep a1 a2 ea); intro n.
  assert (eq_term_equals eq0 (eqb p p ep a1 a2 ea))
         as eqt
         by (eapply nuprl_uniquely_valued; eauto;
             allapply @nuprl_refl; sp).
  rw <- eqt; sp.

  assert (eqa p p ep a1 a1)
         as ea1
         by (eapply equality_eq_refl; eauto).
  apply e4 with (ep := ep) (ea := ea1).
  unfold equality in eq; exrepnd.
  generalize (e3 p p ep a1 a1 ea1); intro n.
  assert (eq_term_equals eq0 (eqb p p ep a1 a1 ea1))
         as eqt
         by (eapply nuprl_uniquely_valued; eauto;
             allapply nuprl_refl; sp).
  rw <- eqt; sp.
  eapply equality_eq_refl; eauto.
Qed.

(* Not as useful as 3 because we don't have any constraint on vb *)
Lemma param_w_ind2 {o} :
  forall lib (P : @CTerm o) ap A bp ba B cp ca cb C (Q : CTerm -> CTerm -> CTerm -> CTerm -> [U]),
    (forall p1 p2 t1 t2 t3 t4,
       cequivc lib t1 t3 -> cequivc lib t2 t4 -> Q p1 p2 t1 t2 -> Q p1 p2 t3 t4)
    -> (forall p1 p2 a1 a2 f1 f2 vb,
       equality lib p1 p2 P
       -> equality lib a1 a2 (substc p1 ap A)
       -> equality lib f1 f2 (mkc_function
                            (lsubstc2 bp p1 ba a1 B)
                            vb
                            (mkc_pw_vs [vb]
                                       P ap A bp ba B cp ca cb C
                                       (lsubstc3v3 cp p1 ca a1 cb vb C)))
       -> (forall b1 b2,
             equality lib b1 b2 (lsubstc2 bp p1 ba a1 B)
             -> Q (lsubstc3 cp p1 ca a1 cb b1 C)
                  (lsubstc3 cp p2 ca a2 cb b2 C)
                  (mkc_apply f1 b1)
                  (mkc_apply f2 b2))
       -> Q p1
            p2
            (mkc_sup a1 f1)
            (mkc_sup a2 f2))
    -> (forall p1 p2 w1 w2,
          equality lib p1 p2 P
          -> equality lib w1 w2 (mkc_pw P ap A bp ba B cp ca cb C p1)
          -> Q p1 p2 w1 w2).
Proof.
  introv ceq ind eqip e.
  apply equality_in_pw in e; exrepnd.
  revert_dependents p2.
  induction e0; spcast.
  introv eqip.
  apply ceq with (t1 := mkc_sup a1 f1) (t2 := mkc_sup a2 f2);
    try (complete (apply cequivc_sym; apply computes_to_valc_implies_cequivc; sp)).

  assert (eqa p p ep a2 a2)
         as ea2
         by (generalize (e2 p p ep); intro na;
             apply (equality_eq_refl lib) with (A := substc p ap A) (B := substc p ap A) (b := a1); sp;
             eapply equality_eq_sym; eauto).

  assert ({v : NVar, !LIn v (bound_vars (get_cvterm [cp, ca, cb] C))})
         as ev
         by (exists (fresh_var (bound_vars (get_cvterm [cp, ca, cb] C)));
             apply fresh_var_not_in); exrepnd.

  apply ind with (vb := v); try (complete sp); try (complete (exists (eqa p p ep); sp)).

  rw @equality_in_function.
  dands.

  (* 1 *)
  exists (eqb p p ep a1 a2 ea); sp.
  generalize (e3 p p ep a1 a2 ea); intro n.
  apply nuprl_refl in n; sp.

  (* 2 *)
  intros b b' eq.
  rw @substc_mkc_pw_vs; simpl; try (complete sp).
  rw @substc_mkc_pw_vs; simpl; try (complete sp).
  exists (pweq lib eqp eqa eqb cp ca cb C (lsubstc3 cp p ca a1 cb b C)); sp.
  apply CL_pw; unfold per_pw; unfold type_pfamily.
  exists eqp eqa eqb (lsubstc3 cp p ca a1 cb b C) (lsubstc3 cp p ca a1 cb b' C).
  exists cp cp ca ca cb cb C C; sp.
  exists P P ap ap A A.
  exists bp bp ba ba B B; sp; spcast; try (apply computes_to_valc_refl; apply iscvalue_mkc_pw).
  assert (eqa p p ep a1 a1)
         as ea1
         by (eapply equality_eq_refl; eauto).
  apply e4 with (ep := ep) (ea := ea1).
  unfold equality in eq; exrepnd.
  generalize (e3 p p ep a1 a1 ea1); intro n.
  assert (eq_term_equals eq0 (eqb p p ep a1 a1 ea1))
         as eqt
         by (eapply nuprl_uniquely_valued; eauto;
             allapply nuprl_refl; sp).
  rw <- eqt; sp.

  (* 3 *)
  intros b b' eq.
  rw @substc_mkc_pw_vs; simpl; try (complete sp).
  apply equality_in_pw.
  exists eqp eqa eqb; dands; try (complete sp).

  assert (eqa p p ep a1 a1)
         as ea1
         by (eapply equality_eq_refl; eauto).
  apply e4 with (ep := ep) (ea := ea1).
  unfold equality in eq; exrepnd.
  generalize (e3 p p ep a1 a1 ea1); intro n.
  assert (eq_term_equals eq0 (eqb p p ep a1 a1 ea1))
         as eqt
         by (eapply nuprl_uniquely_valued; eauto;
             allapply nuprl_refl; sp).
  rw <- eqt; sp.
  eapply equality_eq_refl; eauto.

  apply_hyp.
  unfold equality in eq; exrepnd.
  generalize (e3 p p ep a1 a2 ea); intro n.
  assert (eq_term_equals eq0 (eqb p p ep a1 a2 ea))
         as eqt
         by (eapply nuprl_uniquely_valued; eauto;
             allapply @nuprl_refl; sp).
  rw <- eqt; sp.

  (* 4 *)
  intros b b' eq.
  apply_hyp.
  unfold equality in eq; exrepnd.
  generalize (e3 p p ep a1 a2 ea); intro n.
  assert (eq_term_equals eq0 (eqb p p ep a1 a2 ea))
         as eqt
         by (eapply nuprl_uniquely_valued; eauto;
             allapply @nuprl_refl; sp).
  rw <- eqt; sp.

  assert (eqa p p ep a1 a1)
         as ea1
         by (eapply equality_eq_refl; eauto).
  apply e4 with (ep := ep) (ea := ea1).
  unfold equality in eq; exrepnd.
  generalize (e3 p p ep a1 a1 ea1); intro n.
  assert (eq_term_equals eq0 (eqb p p ep a1 a1 ea1))
         as eqt
         by (eapply nuprl_uniquely_valued; eauto;
             allapply nuprl_refl; sp).
  rw <- eqt; sp.
  eapply equality_eq_refl; eauto.

  generalize (equality_eq lib P p p2 eqp); intro ip.
  dest_imp ip hyp.
  apply ip in eqip; clear ip.

  assert (eqa p p2 eqip a1 a2) as eqia.
  generalize (e2 p p2 eqip); intro n1.
  generalize (e2 p p ep); intro n2.
  apply nuprl_uniquely_valued with (eq1 := eqa p p2 eqip) in n2.
  dup ea as eqia.
  rw <- n2 in eqia; sp.
  allapply @nuprl_refl; sp.

  assert (eqb p p2 eqip a1 a2 eqia b b') as eqib.
  generalize (e3 p p2 eqip a1 a2 eqia); intro n.
  apply nuprl_refl in n.
  apply @equality_eq with (a := b) (b := b') in n.
  rw <- n in eq; sp.

  generalize (e4 p p2 eqip a1 a2 eqia b b' eqib); intro e.
  exists eqp; sp.
Qed.

(* This version is the most useful one so far *)
Lemma param_w_ind3 {o} :
  forall lib (P : @CTerm o) ap A bp ba B cp ca cb C (Q : CTerm -> CTerm -> CTerm -> CTerm -> [U]),
    (forall p1 p2 t1 t2 t3 t4,
       cequivc lib t1 t3 -> cequivc lib t2 t4 -> Q p1 p2 t1 t2 -> Q p1 p2 t3 t4)
    -> (forall p1 p2 a1 a2 f1 f2 vb,
          !LIn vb (bound_vars (get_cvterm [cp, ca, cb] C))
          -> equality lib p1 p2 P
          -> equality lib a1 a2 (substc p1 ap A)
          -> equality lib f1 f2 (mkc_function
                               (lsubstc2 bp p1 ba a1 B)
                               vb
                               (mkc_pw_vs [vb]
                                          P ap A bp ba B cp ca cb C
                                          (lsubstc3v3 cp p1 ca a1 cb vb C)))
          -> (forall b1 b2,
                equality lib b1 b2 (lsubstc2 bp p1 ba a1 B)
                -> Q (lsubstc3 cp p1 ca a1 cb b1 C)
                     (lsubstc3 cp p2 ca a2 cb b2 C)
                     (mkc_apply f1 b1)
                     (mkc_apply f2 b2))
          -> Q p1
               p2
               (mkc_sup a1 f1)
               (mkc_sup a2 f2))
    -> (forall p1 p2 w1 w2,
          equality lib p1 p2 P
          -> equality lib w1 w2 (mkc_pw P ap A bp ba B cp ca cb C p1)
          -> Q p1 p2 w1 w2).
Proof.
  introv ceq ind eqip e.
  apply equality_in_pw in e; exrepnd.
  revert_dependents p2.
  induction e0; spcast.
  introv eqip.
  apply ceq with (t1 := mkc_sup a1 f1) (t2 := mkc_sup a2 f2);
    try (complete (apply cequivc_sym; apply computes_to_valc_implies_cequivc; sp)).

  assert (eqa p p ep a2 a2)
         as ea2
         by (generalize (e2 p p ep); intro na;
             apply (equality_eq_refl lib) with (A := substc p ap A) (B := substc p ap A) (b := a1); sp;
             apply (equality_eq_sym lib) with (A := substc p ap A) (B := substc p ap A); sp).

  assert ({v : NVar, !LIn v (bound_vars (get_cvterm [cp, ca, cb] C))})
         as ev
         by (exists (fresh_var (bound_vars (get_cvterm [cp, ca, cb] C)));
             apply fresh_var_not_in); exrepnd.

  apply ind with (vb := v); try (complete sp); try (complete (exists (eqa p p ep); sp)).

  rw @equality_in_function.
  dands.

  (* 1 *)
  exists (eqb p p ep a1 a2 ea); sp.
  generalize (e3 p p ep a1 a2 ea); intro n.
  apply nuprl_refl in n; sp.

  (* 2 *)
  intros b b' eq.
  rw @substc_mkc_pw_vs; simpl; try (complete sp).
  rw @substc_mkc_pw_vs; simpl; try (complete sp).
  exists (pweq lib eqp eqa eqb cp ca cb C (lsubstc3 cp p ca a1 cb b C)); sp.
  apply CL_pw; unfold per_pw; unfold type_pfamily.
  exists eqp eqa eqb (lsubstc3 cp p ca a1 cb b C) (lsubstc3 cp p ca a1 cb b' C).
  exists cp cp ca ca cb cb C C; sp.
  exists P P ap ap A A.
  exists bp bp ba ba B B; sp; spcast; try (apply computes_to_valc_refl; apply iscvalue_mkc_pw).
  assert (eqa p p ep a1 a1)
         as ea1
         by (eapply equality_eq_refl; eauto).
  apply e4 with (ep := ep) (ea := ea1).
  unfold equality in eq; exrepnd.
  generalize (e3 p p ep a1 a1 ea1); intro n.
  assert (eq_term_equals eq0 (eqb p p ep a1 a1 ea1))
         as eqt
         by (eapply nuprl_uniquely_valued; eauto; allapply nuprl_refl; sp).
  rw <- eqt; sp.

  (* 3 *)
  intros b b' eq.
  rw @substc_mkc_pw_vs; simpl; try (complete sp).
  apply equality_in_pw.
  exists eqp eqa eqb; dands; try (complete sp).

  assert (eqa p p ep a1 a1)
         as ea1 by (eapply equality_eq_refl; eauto).
  apply e4 with (ep := ep) (ea := ea1).
  unfold equality in eq; exrepnd.
  generalize (e3 p p ep a1 a1 ea1); intro n.
  assert (eq_term_equals eq0 (eqb p p ep a1 a1 ea1))
         as eqt
         by (eapply nuprl_uniquely_valued; eauto;
             allapply nuprl_refl; sp).
  rw <- eqt; sp.
  eapply equality_eq_refl; eauto.

  apply_hyp.
  unfold equality in eq; exrepnd.
  generalize (e3 p p ep a1 a2 ea); intro n.
  assert (eq_term_equals eq0 (eqb p p ep a1 a2 ea))
         as eqt
         by (eapply nuprl_uniquely_valued; eauto;
             allapply @nuprl_refl; sp).
  rw <- eqt; sp.

  (* 4 *)
  intros b b' eq.
  apply_hyp.
  unfold equality in eq; exrepnd.
  generalize (e3 p p ep a1 a2 ea); intro n.
  assert (eq_term_equals eq0 (eqb p p ep a1 a2 ea))
         as eqt
         by (eapply nuprl_uniquely_valued; eauto;
             allapply @nuprl_refl; sp).
  rw <- eqt; sp.

  assert (eqa p p ep a1 a1)
         as ea1
         by (eapply equality_eq_refl; eauto).
  apply e4 with (ep := ep) (ea := ea1).
  unfold equality in eq; exrepnd.
  generalize (e3 p p ep a1 a1 ea1); intro n.
  assert (eq_term_equals eq0 (eqb p p ep a1 a1 ea1))
         as eqt
         by (eapply nuprl_uniquely_valued; eauto;
             allapply nuprl_refl; sp).
  rw <- eqt; sp.
  eapply equality_eq_refl; eauto.

  generalize (equality_eq lib P p p2 eqp); intro ip.
  dest_imp ip hyp.
  apply ip in eqip; clear ip.

  assert (eqa p p2 eqip a1 a2) as eqia.
  generalize (e2 p p2 eqip); intro n1.
  generalize (e2 p p ep); intro n2.
  apply nuprl_uniquely_valued with (eq1 := eqa p p2 eqip) in n2.
  dup ea as eqia.
  rw <- n2 in eqia; sp.
  allapply @nuprl_refl; sp.

  assert (eqb p p2 eqip a1 a2 eqia b b') as eqib.
  generalize (e3 p p2 eqip a1 a2 eqia); intro n.
  apply nuprl_refl in n.
  apply @equality_eq with (a := b) (b := b') in n.
  rw <- n in eq; sp.

  generalize (e4 p p2 eqip a1 a2 eqia b b' eqib); intro e.
  exists eqp; sp.
Qed.

(* slightly better than 3 because we can provide a list of variables that
 * v has to be disjoint with *)
Lemma param_w_ind4 {o} :
  forall lib (P : @CTerm o) ap A bp ba B cp ca cb C (Q : CTerm -> CTerm -> CTerm -> CTerm -> [U]) vs,
    (forall p1 p2 t1 t2 t3 t4,
       cequivc lib t1 t3 -> cequivc lib t2 t4 -> Q p1 p2 t1 t2 -> Q p1 p2 t3 t4)
    -> (forall p1 p2 a1 a2 f1 f2 vb,
          !LIn vb vs
          -> equality lib p1 p2 P
          -> equality lib a1 a2 (substc p1 ap A)
          -> equality lib f1 f2 (mkc_function
                               (lsubstc2 bp p1 ba a1 B)
                               vb
                               (mkc_pw_vs [vb]
                                          P ap A bp ba B cp ca cb C
                                          (lsubstc3v3 cp p1 ca a1 cb vb C)))
          -> (forall b1 b2,
                equality lib b1 b2 (lsubstc2 bp p1 ba a1 B)
                -> Q (lsubstc3 cp p1 ca a1 cb b1 C)
                     (lsubstc3 cp p2 ca a2 cb b2 C)
                     (mkc_apply f1 b1)
                     (mkc_apply f2 b2))
          -> Q p1
               p2
               (mkc_sup a1 f1)
               (mkc_sup a2 f2))
    -> (forall p1 p2 w1 w2,
          equality lib p1 p2 P
          -> equality lib w1 w2 (mkc_pw P ap A bp ba B cp ca cb C p1)
          -> Q p1 p2 w1 w2).
Proof.
  introv ceq ind eqip e.
  apply equality_in_pw in e; exrepnd.
  revert_dependents p2.
  induction e0; spcast.
  introv eqip.
  apply ceq with (t1 := mkc_sup a1 f1) (t2 := mkc_sup a2 f2);
    try (complete (apply cequivc_sym; apply computes_to_valc_implies_cequivc; sp)).

  assert (eqa p p ep a2 a2)
         as ea2
         by (generalize (e2 p p ep); intro na;
             apply (equality_eq_refl lib) with (A := substc p ap A) (B := substc p ap A) (b := a1); sp;
             apply (equality_eq_sym lib) with (A := substc p ap A) (B := substc p ap A); sp).

  assert ({v : NVar, !LIn v (bound_vars (get_cvterm [cp, ca, cb] C) ++ vs)})
         as ev
         by (exists (fresh_var (bound_vars (get_cvterm [cp, ca, cb] C) ++ vs));
             apply fresh_var_not_in); exrepnd.

  allrw in_app_iff.

  apply ind with (vb := v);
    try (complete sp);
    try (complete (exists (eqa p p ep); sp)).

  rw @equality_in_function.
  dands.

  (* 1 *)
  exists (eqb p p ep a1 a2 ea); sp.
  generalize (e3 p p ep a1 a2 ea); intro n.
  apply nuprl_refl in n; sp.

  (* 2 *)
  intros b b' eq.
  rw @substc_mkc_pw_vs; simpl; try (complete sp).
  rw @substc_mkc_pw_vs; simpl; try (complete sp).
  exists (pweq lib eqp eqa eqb cp ca cb C (lsubstc3 cp p ca a1 cb b C)); sp.
  apply CL_pw; unfold per_pw; unfold type_pfamily.
  exists eqp eqa eqb (lsubstc3 cp p ca a1 cb b C) (lsubstc3 cp p ca a1 cb b' C).
  exists cp cp ca ca cb cb C C; sp.
  exists P P ap ap A A.
  exists bp bp ba ba B B; sp; spcast; try (apply computes_to_valc_refl; apply iscvalue_mkc_pw).
  assert (eqa p p ep a1 a1)
         as ea1 by (eapply equality_eq_refl; eauto).
  apply e4 with (ep := ep) (ea := ea1).
  unfold equality in eq; exrepnd.
  generalize (e3 p p ep a1 a1 ea1); intro n.
  assert (eq_term_equals eq0 (eqb p p ep a1 a1 ea1))
         as eqt
         by (eapply nuprl_uniquely_valued; eauto; allapply nuprl_refl; sp).
  rw <- eqt; sp.

  (* 3 *)
  intros b b' eq.
  rw @substc_mkc_pw_vs; simpl; try (complete sp).
  apply equality_in_pw.
  exists eqp eqa eqb; dands; try (complete sp).

  assert (eqa p p ep a1 a1)
         as ea1 by (eapply equality_eq_refl; eauto).
  apply e4 with (ep := ep) (ea := ea1).
  unfold equality in eq; exrepnd.
  generalize (e3 p p ep a1 a1 ea1); intro n.
  assert (eq_term_equals eq0 (eqb p p ep a1 a1 ea1))
         as eqt
         by (eapply nuprl_uniquely_valued; eauto; allapply nuprl_refl; sp).
  rw <- eqt; sp.
  eapply equality_eq_refl; eauto.

  apply_hyp.
  unfold equality in eq; exrepnd.
  generalize (e3 p p ep a1 a2 ea); intro n.
  assert (eq_term_equals eq0 (eqb p p ep a1 a2 ea))
         as eqt
         by (eapply nuprl_uniquely_valued; eauto; allapply @nuprl_refl; sp).
  rw <- eqt; sp.

  (* 4 *)
  intros b b' eq.
  apply_hyp.
  unfold equality in eq; exrepnd.
  generalize (e3 p p ep a1 a2 ea); intro n.
  assert (eq_term_equals eq0 (eqb p p ep a1 a2 ea))
         as eqt
         by (eapply nuprl_uniquely_valued; eauto; allapply @nuprl_refl; sp).
  rw <- eqt; sp.

  assert (eqa p p ep a1 a1)
         as ea1 by (eapply equality_eq_refl; eauto).
  apply e4 with (ep := ep) (ea := ea1).
  unfold equality in eq; exrepnd.
  generalize (e3 p p ep a1 a1 ea1); intro n.
  assert (eq_term_equals eq0 (eqb p p ep a1 a1 ea1))
         as eqt
         by (eapply nuprl_uniquely_valued; eauto; allapply nuprl_refl; sp).
  rw <- eqt; sp.
  eapply equality_eq_refl; eauto.

  generalize (equality_eq lib P p p2 eqp); intro ip.
  dest_imp ip hyp.
  apply ip in eqip; clear ip.

  assert (eqa p p2 eqip a1 a2) as eqia.
  generalize (e2 p p2 eqip); intro n1.
  generalize (e2 p p ep); intro n2.
  apply nuprl_uniquely_valued with (eq1 := eqa p p2 eqip) in n2.
  dup ea as eqia.
  rw <- n2 in eqia; sp.
  allapply @nuprl_refl; sp.

  assert (eqb p p2 eqip a1 a2 eqia b b') as eqib.
  generalize (e3 p p2 eqip a1 a2 eqia); intro n.
  apply nuprl_refl in n.
  apply @equality_eq with (a := b) (b := b') in n.
  rw <- n in eq; sp.

  generalize (e4 p p2 eqip a1 a2 eqia b b' eqib); intro e.
  exists eqp; sp.
Qed.

(* Useless *)
Lemma param_w_ind5 {o} :
  forall lib (P : @CTerm o) ap A bp ba B cp ca cb C (Q : CTerm -> CTerm -> [U]),
    (forall p t1 t2,
       cequivc lib t1 t2 -> Q p t1 -> Q p t2)
    -> (forall p1 p2 a1 a2 f1 f2 vb,
          !LIn vb (bound_vars (get_cvterm [cp, ca, cb] C))
          -> equality lib p1 p2 P
          -> equality lib a1 a2 (substc p1 ap A)
          -> equality lib f1 f2 (mkc_function
                               (lsubstc2 bp p1 ba a1 B)
                               vb
                               (mkc_pw_vs [vb]
                                          P ap A bp ba B cp ca cb C
                                          (lsubstc3v3 cp p1 ca a1 cb vb C)))
          -> (forall b1 b2,
                equality lib b1 b2 (lsubstc2 bp p1 ba a1 B)
                -> equality lib p1 p2 P
                -> Q (lsubstc3 cp p1 ca a1 cb b1 C)
                     (mkc_apply f1 b1))
          -> Q p1
               (mkc_sup a1 f1))
    -> (forall p1 p2 w1 w2,
          equality lib p1 p2 P
          -> equality lib w1 w2 (mkc_pw P ap A bp ba B cp ca cb C p1)
          -> Q p1 w1).
Proof.
  introv ceq ind eqip e.
  apply equality_in_pw in e; exrepnd.
  revert_dependents p2.
  induction e0 as [ p t1 t2 ep a1 f1 a2 f2 ea c1 c2 i r ]; spcast.
  introv eqip.
  apply ceq with (t1 := mkc_sup a1 f1);
    try (complete (apply cequivc_sym; apply computes_to_valc_implies_cequivc; sp)).

  assert (eqa p p ep a2 a2)
         as ea2
         by (generalize (e2 p p ep); intro na;
             apply (equality_eq_refl lib) with (A := substc p ap A) (B := substc p ap A) (b := a1); sp;
             apply (equality_eq_sym lib) with (A := substc p ap A) (B := substc p ap A); sp).

  assert ({v : NVar, !LIn v (bound_vars (get_cvterm [cp, ca, cb] C))})
         as ev
         by (exists (fresh_var (bound_vars (get_cvterm [cp, ca, cb] C)));
             apply fresh_var_not_in); exrepnd.

  apply ind with (vb := v) (p2 := p2) (a2 := a2) (f2 := f2);
    try (complete sp); try (complete (exists (eqa p p ep); sp)).

  rw @equality_in_function.
  dands.

  (* 1 *)
  exists (eqb p p ep a1 a2 ea); sp.
  generalize (e3 p p ep a1 a2 ea); intro n.
  apply nuprl_refl in n; sp.

  (* 2 *)
  intros b b' eq.
  rw @substc_mkc_pw_vs; simpl; try (complete sp).
  rw @substc_mkc_pw_vs; simpl; try (complete sp).
  exists (pweq lib eqp eqa eqb cp ca cb C (lsubstc3 cp p ca a1 cb b C)); sp.
  apply CL_pw; unfold per_pw; unfold type_pfamily.
  exists eqp eqa eqb (lsubstc3 cp p ca a1 cb b C) (lsubstc3 cp p ca a1 cb b' C).
  exists cp cp ca ca cb cb C C; sp.
  exists P P ap ap A A.
  exists bp bp ba ba B B; sp; spcast; try (apply computes_to_valc_refl; apply iscvalue_mkc_pw).
  assert (eqa p p ep a1 a1)
         as ea1 by (eapply equality_eq_refl; eauto).
  apply e4 with (ep := ep) (ea := ea1).
  unfold equality in eq; exrepnd.
  generalize (e3 p p ep a1 a1 ea1); intro n.
  assert (eq_term_equals eq0 (eqb p p ep a1 a1 ea1))
         as eqt
         by (eapply nuprl_uniquely_valued; eauto; allapply nuprl_refl; sp).
  rw <- eqt; sp.

  (* 3 *)
  intros b b' eq.
  rw @substc_mkc_pw_vs; simpl; try (complete sp).
  apply equality_in_pw.
  exists eqp eqa eqb; dands; try (complete sp).

  assert (eqa p p ep a1 a1)
         as ea1 by (eapply equality_eq_refl; eauto).
  apply e4 with (ep := ep) (ea := ea1).
  unfold equality in eq; exrepnd.
  generalize (e3 p p ep a1 a1 ea1); intro n.
  assert (eq_term_equals eq0 (eqb p p ep a1 a1 ea1))
         as eqt
         by (eapply nuprl_uniquely_valued; eauto; allapply nuprl_refl; sp).
  rw <- eqt; sp.
  eapply equality_eq_refl; eauto.

  apply_hyp.
  unfold equality in eq; exrepnd.
  generalize (e3 p p ep a1 a2 ea); intro n.
  assert (eq_term_equals eq0 (eqb p p ep a1 a2 ea))
         as eqt
         by (eapply nuprl_uniquely_valued; eauto; allapply @nuprl_refl; sp).
  rw <- eqt; sp.

  (* 4 *)
  intros b b' eib eip.
  apply r with (b2 := b') (p2 := lsubstc3 cp p2 ca a2 cb b' C).
  unfold equality in eib; exrepnd.
  generalize (e3 p p ep a1 a2 ea); intro n.
  assert (eq_term_equals eq (eqb p p ep a1 a2 ea))
         as eqt
         by (eapply nuprl_uniquely_valued; eauto; allapply @nuprl_refl; sp).
  rw <- eqt; sp.

  assert (eqa p p ep a1 a1)
         as ea1 by (eapply equality_eq_refl; eauto).
  apply e4 with (ep := ep) (ea := ea1).
  unfold equality in eib; exrepnd.
  generalize (e3 p p ep a1 a1 ea1); intro n.
  assert (eq_term_equals eq (eqb p p ep a1 a1 ea1))
         as eqt
         by (eapply nuprl_uniquely_valued; eauto; allapply nuprl_refl; sp).
  rw <- eqt; sp.
  eapply equality_eq_refl; eauto.

  generalize (equality_eq lib P p p2 eqp); intro ip.
  dest_imp ip hyp.
  apply ip in eqip; clear ip.

  assert (eqa p p2 eqip a1 a2) as eqia.
  generalize (e2 p p2 eqip); intro n1.
  generalize (e2 p p ep); intro n2.
  apply nuprl_uniquely_valued with (eq1 := eqa p p2 eqip) in n2.
  dup ea as eqia.
  rw <- n2 in eqia; sp.
  allapply @nuprl_refl; sp.

  assert (eqb p p2 eqip a1 a2 eqia b b') as eqib.
  generalize (e3 p p2 eqip a1 a2 eqia); intro n.
  apply nuprl_refl in n.
  apply @equality_eq with (a := b) (b := b') in n.
  rw <- n in eib; sp.

  generalize (e4 p p2 eqip a1 a2 eqia b b' eqib); intro e.
  exists eqp; sp.
Qed.

Lemma weq_implies {p} :
  forall lib (eqa1 eqa2 : per(p)) eqb1 eqb2,
    eq_term_equals eqa1 eqa2
    -> (forall (a a' : CTerm) (ea1 : eqa1 a a') (ea2 : eqa2 a a'),
          eq_term_equals (eqb1 a a' ea1) (eqb2 a a' ea2))
    -> forall t1 t2,
         weq lib eqa1 eqb1 t1 t2
         -> weq lib eqa2 eqb2 t1 t2.
Proof.
  introv eqia eqib weq1.
  induction weq1.

  assert (eqa2 a a') as ea2 by (allrw <-; sp).

  apply @weq_cons
        with
        (a  := a)
        (f  := f)
        (a' := a')
        (f' := f')
        (e  := ea2);
    try (complete sp).

  introv eia.

  apply_hyp.
  generalize (eqib a a' e ea2); intro eqt; allrw; sp.
Qed.

Lemma eq_term_equals_weq {p} :
  forall lib (eqa1 eqa2 : per(p)) eqb1 eqb2,
    eq_term_equals eqa1 eqa2
    -> (forall (a a' : CTerm) (ea1 : eqa1 a a') (ea2 : eqa2 a a'),
          eq_term_equals (eqb1 a a' ea1) (eqb2 a a' ea2))
    -> eq_term_equals (weq lib eqa1 eqb1)
                      (weq lib eqa2 eqb2).
Proof.
  introv eqia eqib.
  unfold eq_term_equals; introv; split; intro k.
  apply @weq_implies with (eqa1 := eqa1) (eqb1 := eqb1); sp.

  apply @weq_implies with (eqa1 := eqa2) (eqb1 := eqb2); sp;
  apply eq_term_equals_sym; sp.
Qed.

Lemma equality_in_w_v1 {p} :
  forall lib A v B (t1 t2 : @CTerm p),
    equality lib t1 t2 (mkc_w A v B)
    <=> {a1, a2, f1, f2 : CTerm
         , t1 ===>(lib) (mkc_sup a1 f1)
         # t2 ===>(lib) (mkc_sup a2 f2)
         # equality lib a1 a2 A
         # equality lib f1 f2 (mkc_fun (substc a1 v B) (mkc_w A v B))
         # (forall a a', equality lib a a' A -> tequality lib (substc a v B) (substc a' v B))}.
Proof.
  introv; split; intro e.

  - unfold equality in e; exrepnd.
    inversion e1; try not_univ.
    allunfold @per_w; exrepnd.
    allunfold @type_family; exrepnd.
    allfold (@nuprl p lib).
    computes_to_value_isvalue.
    allunfold @eq_term_equals; discover.
    destruct h.
    exists a a' f f'; sp.
    exists eqa; sp.
    rw <- @fold_mkc_fun.
    rw @equality_in_function; dands.

    exists (eqb a a' e).
    apply @nuprl_refl with (t2 := substc a' v0 B0); sp.

    intros b1 b2 eib.
    generalize (equality_eq1 lib (substc a v0 B0) (substc a' v0 B0) b1 b2 (eqb a a' e));
      intro k; repeat (dest_imp k hyp).
    discover.
    allrw @substc_cnewvar.
    exists eq; sp.

    intros b1 b2 eib.
    allrw @substc_cnewvar.
    exists eq; sp.
    allrw.
    apply_hyp.
    generalize (equality_eq1 lib (substc a v0 B0) (substc a' v0 B0) b1 b2 (eqb a a' e));
      intro k; repeat (dest_imp k hyp).
    discover; sp.

    allunfold @equality; exrepnd.
    generalize (nuprl_uniquely_valued lib A0 eq0 eqa); introv k; repeat (dest_imp k hyp).
    assert (eqa a0 a'0) as ea by (allrw <-; sp).
    exists (eqb a0 a'0 ea); sp.

  - exrepnd.
    unfold equality in e3; exrepnd.
    rename eq into eqa.

    generalize (choice_teq lib A v B v B e1); intro n; exrepnd.

    exists (weq lib eqa (fun a a' ea => f a a' (eq_equality1 lib a a' A eqa ea e3))); dands.

    apply CL_w; unfold per_w.
    exists eqa.
    exists (fun a a' ea => f a a' (eq_equality1 lib a a' A eqa ea e3)); sp.
    unfold type_family.
    fold (@nuprl p lib).
    exists A A v v B B; sp;
    try (complete (spcast; apply computes_to_valc_refl; try (apply iscvalue_mkc_w))).

    apply @weq_cons with (a := a1) (f := f1) (a' := a2) (f' := f2) (e := e5); sp.
    generalize (n0 a1 a2 (eq_equality1 lib a1 a2 A eqa e5 e3)); intro n.
    rw <- @fold_mkc_fun in e4.
    rw @equality_in_function in e4; repnd.
    generalize (e4 b b'); intro k.
    dest_imp k hyp.
    exists (f a1 a2 (eq_equality1 lib a1 a2 A eqa e5 e3)); sp.
    allapply @nuprl_refl; sp.
    allrw @substc_cnewvar.
    unfold equality in k; exrepnd.
    inversion k1; try not_univ.
    allunfold @per_w; exrepnd.
    allunfold @type_family; exrepnd; allfold (@nuprl p lib).
    computes_to_value_isvalue.
    allunfold @eq_term_equals; discover.

    assert (eq_term_equals eqa0 eqa)
           as eqta by (eapply nuprl_uniquely_valued; eauto).

    assert (forall (a a' : CTerm) (ea : eqa a a') (ea' : eqa0 a a'),
              eq_term_equals (f a a' (eq_equality1 lib a a' A0 eqa ea e3)) (eqb a a' ea'))
           as eqtb.
    introv.
    generalize (n0 a a' (eq_equality1 lib a a' A0 eqa ea e3)); intro n1.
    assert (nuprl lib (substc a v0 B0) (substc a' v0 B0) (eqb a a' ea')) as n2 by sp.
    apply (nuprl_uniquely_valued lib) with (t := substc a v0 B0); sp; allapply @nuprl_refl; sp.
    apply weq_implies with (eqa1 := eqa0) (eqb1 := eqb); sp.
    apply eq_term_equals_sym; sp.
Qed.

Lemma tequality_mkc_w {p} :
  forall lib (A1 : @CTerm p) v1 B1
         A2 v2 B2,
    tequality lib
      (mkc_w A1 v1 B1)
      (mkc_w A2 v2 B2)
    <=>
    (tequality lib A1 A2
     # (forall a1 a2,
        equality lib a1 a2 A1
        -> tequality lib (substc a1 v1 B1) (substc a2 v2 B2))).
Proof.
  introv; split; intro e; repnd.

  - unfold tequality in e; exrepnd.
    unfold nuprl in e0.
    inversion e0; try not_univ.
    allunfold @per_w; exrepnd.
    allunfold @type_family; exrepnd; spcast; allfold (@nuprl p lib).
    computes_to_value_isvalue.
    dands.

    + allapply @tequality_if_nuprl; sp.

    + introv eia.
      generalize (equality_eq1 lib A A' a1 a2 eqa); intro i; dest_imp i hyp.
      rw <- i in eia.
      exists (eqb a1 a2 eia); sp.

  - unfold tequality.
    unfold tequality in e0; exrepnd.
    rename eq into eqa.

    generalize (choice_teq1 lib A1 eqa v1 B1 v2 B2); intro neqb.
    dest_imp neqb hyp; try (complete (allapply @nuprl_refl; sp)).
    dest_imp neqb hyp; exrepnd.
    rename f into eqb.

    exists (weq lib eqa eqb).
    apply CL_w; unfold per_w.
    exists eqa eqb; sp.
    unfold type_family.
    exists A1 A2 v1 v2 B1 B2; dands;
    try (complete sp);
    try (complete (spcast; apply computes_to_valc_refl; try (apply iscvalue_mkc_w))).
Qed.


Require Import UFO.Lang.Syntax.
Require Import UFO.Lang.Bindings_map.
Require Import TLC.LibReflect.
Set Implicit Arguments.

Implicit Types EP EV LV V L : Set.

Local Obligation Tactic := idtac.

Program Definition fsub_lid L (id' : lid L) (X : var) (id : lid L) : lid L :=
  match id' with
  | lid_f Y => _
  | lid_b _ => id'
  end.
Next Obligation.
Proof.
intros L id' X id Y G.
destruct (var_compare X Y) eqn:Heq ;
  rewrite var_compare_eq in Heq ;
  rew_bool_eq in Heq ; [ apply id | apply id' ].
Defined.

Definition fsub_lbl LV L (ℓ : lbl LV L) (X : var) (id : lid L) : lbl LV L :=
  match ℓ with
  | lbl_var _ => ℓ
  | lbl_id id' => lbl_id (fsub_lid id' X id)
  end.

Definition
  fsub_ef EP EV LV L (e : ef EP EV LV L) (X : var) (id : lid L) : ef EP EV LV L :=
  match e with
  | ef_par _ => e
  | ef_var _ => e
  | ef_lbl ℓ => ef_lbl (fsub_lbl ℓ X id)
  end
.

Fixpoint
  fsub_eff EP EV LV L (E : eff EP EV LV L) (X : var) (id : lid L) : eff EP EV LV L :=
  match E with
  | [] => []
  | e :: E' => (fsub_ef e X id) :: (fsub_eff E' X id)
  end
.

Fixpoint
  fsub_it EP EV LV L κ (N : it EP EV LV L κ) (X : var) (id : lid L) : it EP EV LV L κ :=
  match N with
  | it_name 𝔽 => it_name 𝔽
  | it_inst N E => it_inst (fsub_it N X id) (fsub_eff E X id)
  end
.

Fixpoint
  fsub_ms EP EV LV L (σ : ms EP EV LV L) (X : var) (id : lid L) : ms EP EV LV L :=
  match σ with
  | ms_ev σ => ms_ev (fsub_ms σ X id)
  | ms_lv σ => ms_lv (fsub_ms σ X id)
  | ms_tm T σ => ms_tm (fsub_ty T X id) (fsub_ms σ X id)
  | ms_res T E => ms_res (fsub_ty T X id) (fsub_eff E X id)
  end
with
  fsub_ty EP EV LV L (T : ty EP EV LV L) (X : var) (id : lid L) : ty EP EV LV L :=
  match T with
  | 𝟙 => 𝟙
  | ty_it N ℓ => ty_it (fsub_it N X id) (fsub_lbl ℓ X id)
  | ty_ms σ ℓ => ty_ms (fsub_ms σ X id) (fsub_lbl ℓ X id)
  | ty_cont Ta Ea Tb Eb =>
    ty_cont (fsub_ty Ta X id) (fsub_eff Ea X id) (fsub_ty Tb X id) (fsub_eff Eb X id)
  end
.

Fixpoint
  fsub_md EV LV V L (m : md EV LV V L) (X : var) (id : lid L) : md EV LV V L :=
  match m with
  | md_ev m => md_ev (fsub_md m X id)
  | md_lv m => md_lv (fsub_md m X id)
  | md_tm m => md_tm (fsub_md m X id)
  | md_res t => md_res (fsub_tm t X id)
  end
with
  fsub_ktx EV LV V L (K : ktx EV LV V L) (X : var) (id : lid L) : ktx EV LV V L :=
  match K with
  | ktx_hole => ktx_hole
  | ktx_down K Y =>
      ktx_down (fsub_ktx K X id) Y
  | ktx_up K =>
      ktx_up (fsub_ktx K X id)
  | ktx_op K =>
      ktx_op (fsub_ktx K X id)
  | ktx_let K t =>
      ktx_let (fsub_ktx K X id) (fsub_tm t X id)
  | ktx_throw K t =>
      ktx_throw (fsub_ktx K X id) (fsub_tm t X id)
  | ktx_app_eff K E =>
      ktx_app_eff (fsub_ktx K X id) (fsub_eff E X id)
  | ktx_app_lbl K ℓ =>
      ktx_app_lbl (fsub_ktx K X id) (fsub_lbl ℓ X id)
  | ktx_app_tm1 K t =>
      ktx_app_tm1 (fsub_ktx K X id) (fsub_tm t X id)
  | ktx_app_tm2 K v =>
      ktx_app_tm2 (fsub_ktx K X id) (fsub_val v X id)
  end
with
  fsub_val EV LV V L (v : val EV LV V L) (X : var) (id : lid L) : val EV LV V L :=
  match v with
  | val_unit => val_unit
  | val_var x => val_var x
  | val_cont K => fsub_ktx K X id
  | val_md m id' => val_md (fsub_md m X id) (fsub_lid id' X id)
  | val_fix m id' => val_fix (fsub_md m X id) (fsub_lid id' X id)
  end
with
  fsub_tm EV LV V L (t : tm EV LV V L) (X : var) (id : lid L) : tm EV LV V L :=
  match t with
  | tm_val v => fsub_val v X id
  | tm_op t => tm_op (fsub_tm t X id)
  | ⇧ t => ⇧ (fsub_tm t X id)
  | ⬇ t => ⬇ (fsub_tm t X (L_shift_lid id))
  | ⇩ X t => ⇩ X (fsub_tm t X id)
  | tm_let s t => tm_let (fsub_tm s X id) (fsub_tm t X id)
  | tm_throw t s => tm_throw (fsub_tm t X id) (fsub_tm s X id)
  | tm_app_eff t E => tm_app_eff (fsub_tm t X id) (fsub_eff E X id)
  | tm_app_lbl t ℓ => tm_app_lbl (fsub_tm t X id) (fsub_lbl ℓ X id)
  | tm_app_tm t s => tm_app_tm (fsub_tm t X id) (fsub_tm s X id)
  end
.


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 C D E F P Q DD FF X CC : Universe, ((wd_ A B /\ (wd_ D E /\ (wd_ E F /\ (wd_ B Q /\ (wd_ E P /\ (wd_ B C /\ (wd_ A C /\ (wd_ D F /\ (wd_ D P /\ (wd_ E FF /\ (wd_ E DD /\ (wd_ CC B /\ (wd_ E X /\ (col_ E DD P /\ (col_ DD X FF /\ (col_ B C CC /\ (col_ E X P /\ (col_ E F FF /\ col_ E D DD)))))))))))))))))) -> col_ D E P)).
Proof.
  time tac.
Qed.

End FOFProblem.