Require Import VST.msl.Extensionality.
Require Import VST.msl.sepalg.
Require Import VST.msl.ageable.
Require Import VST.msl.age_sepalg.
Require Import VST.msl.base.
Require Import VST.msl.predicates_hered.
Require Import VST.msl.predicates_sl.
Require Import VST.msl.subtypes.
Require Import VST.msl.subtypes_sl.
Require Import VST.msl.predicates_rec.

(* Given a separation algebra on type [A], we can make a separation logic
   with predicates of type  [pred A].  But the type   [B -> pred A] is also
   a natural separation logic.  These typeclasses automagically extend
   the separation-logic operators to the pointwise-function case.
   At present, this is just the beginnings of an experiment with this idea;
   don't expect it to work well enough to be useful.
   Andrew Appel, August 2012, following an approach suggested by Rob Dockins
*)

Class StarOp A := {  starOp : A -> A -> A }.

#[global] Instance baseStarOp {A}{agA: ageable A}{JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{AgeA: Age_alg A}{EO: Ext_ord A}{EA: Ext_alg A}
 : StarOp (pred A) := {| starOp := sepcon |}.

#[global] Instance funStarOp (B: Type)(A: Type)(StarA: StarOp A) : StarOp (B -> A) :=
   {| starOp := fun (P Q : B -> A) (b : B) =>  starOp (P b) (Q b) |}.

Set Warnings "-notation-overridden".
Notation "P '*' Q" := (starOp P Q) : pred.
Set Warnings "notation-overridden".
(* Opaque baseStarOp *)

Class DerivesOp A := {  derivesOp : A -> A -> Prop }.

#[global] Instance baseDerivesOp {A}{agA: ageable A}{EO: Ext_ord A}
 : DerivesOp (pred A) := {| derivesOp := @derives A agA EO|}.

#[global] Instance funDerivesOp (B: Type)(A: Type)(DerivesA: DerivesOp A) : DerivesOp (B -> A)
 := {| derivesOp := fun (P Q : B -> A)  => forall b, derivesOp (P b) (Q b) |}.
Set Warnings "-notation-overridden".
Declare Scope logic_derives.
Notation "P '|--' Q" := (derivesOp P%pred Q%pred) : logic_derives.
Set Warnings "notation-overridden".
Open Scope logic_derives.
(* Opaque baseDerivesOp. *)

Class WandOp A := {  wandOp : A -> A -> A }.

#[global] Instance baseWandOp {A}{agA: ageable A}{JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{AgeA: Age_alg A}{EO: Ext_ord A}{EA: Ext_alg A}
 : WandOp (pred A) := {| wandOp := wand |}.

#[global] Instance funWandOp (B: Type)(A: Type)(WandA: WandOp A) : WandOp (B -> A) :=
   {| wandOp := fun (P Q : B -> A) (b : B) =>  wandOp (P b) (Q b) |}.

Set Warnings "-notation-overridden".
Notation "P '-*' Q" := (wandOp P Q) : pred.
Set Warnings "notation-overridden".
(* Opaque baseWandOp *)

Class EmpOp A := { Emp: A}.

#[global] Instance baseEmpOp {A}{agA: ageable A}{JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{AgeA: Age_alg A}{EO: Ext_ord A}
  : EmpOp (pred A) := {| Emp := @emp A JA SA agA AgeA EO |}.

#[global] Instance funEmpOp  (B: Type)(A: Type)(EmpA: EmpOp A) : EmpOp (B -> A) :=
   {| Emp := fun (b : B) =>  Emp  |}.

Section Test.
Variable environ: Type.
Variables (rmap : Type)
      (Join_rmap: Join rmap) (Perm_rmap: @Perm_alg rmap Join_rmap)
      (Sep_rmap: @Sep_alg rmap Join_rmap)
      (Canc_rmap: @Canc_alg rmap Join_rmap)
      (Disj_rmap: @Disj_alg rmap Join_rmap)
      (ag_rmap: ageable rmap)
      (Age_rmap: @Age_alg rmap Join_rmap ag_rmap Sep_rmap)
      (Ext_rmap: @Ext_ord rmap ag_rmap)
      (ExtA_rmap: @Ext_alg rmap ag_rmap Ext_rmap Join_rmap Sep_rmap).
#[local] Existing Instance  Join_rmap.
#[local] Existing Instance  Perm_rmap.
#[local] Existing Instance  Sep_rmap.
#[local] Existing Instance  Canc_rmap.
#[local] Existing Instance  Disj_rmap.
#[local] Existing Instance  ag_rmap.
#[local] Existing Instance  Age_rmap.
#[local] Existing Instance  Ext_rmap.
#[local] Existing Instance  ExtA_rmap.

Lemma test1: forall (P : environ -> pred rmap) (Q: pred rmap),
   P * Emp |-- P.
Proof.
 intros.
  intro. simpl; rewrite sepcon_emp.
auto.
Qed.

End Test.


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 P : Universe, ((wd_ A D /\ (wd_ A B /\ (wd_ B C /\ (wd_ A C /\ (wd_ A D /\ (wd_ C D /\ (wd_ B D /\ (wd_ P A /\ (wd_ P D /\ (wd_ B P /\ (wd_ P C /\ (col_ C P D /\ (col_ A D D /\ col_ B P C))))))))))))) -> col_ B C D)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import Coq.Lists.List.
Require Import Rewriter.Language.Pre.
Require Import Rewriter.Util.Bool.
Require Import Rewriter.Util.NatUtil.
Require Import Rewriter.Util.ListUtil.
Require Import Rewriter.Util.Prod.
Require Import Rewriter.Util.Option.
Import ListNotations.

Import Pre.RewriteRuleNotations.

Lemma eval_nat_rect_arrow
  : forall A B O_case S_case n v,
    @nat_rect_arrow_nodep A B O_case S_case ('n) v
    = ident.eagerly (@nat_rect_arrow_nodep) _ _ O_case S_case ('n) v.
Proof. reflexivity. Qed.

Lemma eval_nat_rect
  : forall P O_case S_case n,
    @Thunked.nat_rect P O_case S_case ('n)
    = ident.eagerly (@Thunked.nat_rect) _ O_case S_case ('n).
Proof. reflexivity. Qed.

Lemma eval_list_rect_arrow
  : forall A P Q N C ls v,
    @list_rect_arrow_nodep A P Q N C ls v
    = ident.eagerly (@list_rect_arrow_nodep) A P Q N C ls v.
Proof. reflexivity. Qed.

Lemma eval_list_rect
  : forall A P N C ls,
    @Thunked.list_rect A P N C ls
    = ident.eagerly (@Thunked.list_rect) A P N C ls.
Proof. reflexivity. Qed.

Lemma eval_list_case_nil
  : forall A P N C, @Thunked.list_case A P N C nil = N tt.
Proof. reflexivity. Qed.
Lemma eval_list_case_cons
  : forall A P N C x xs, @Thunked.list_case A P N C (x :: xs) = C x xs.
Proof. reflexivity. Qed.

Lemma eval_list_nth_default
  : forall A default ls n,
    @List.nth_default A default ls ('n)
    = ident.eagerly (@List.nth_default) A default ls ('n).
Proof. reflexivity. Qed.

Lemma eval_prod_rect
  : forall A B P f x y, @prod_rect_nodep A B P f (x, y) = f x y.
Proof. reflexivity. Qed.

Lemma eval_option_rect_Some
  : forall A P S N x, @Thunked.option_rect A P S N (Some x) = S x.
Proof. reflexivity. Qed.
Lemma eval_option_rect_None
  : forall A P S N, @Thunked.option_rect A P S N None = N tt.
Proof. reflexivity. Qed.

Lemma eval_bool_rect_true : forall T t f, @Thunked.bool_rect T t f true = t tt.
Proof. reflexivity. Qed.
Lemma eval_bool_rect_false : forall T t f, @Thunked.bool_rect T t f false = f tt.
Proof. reflexivity. Qed.

Import PrimitiveProd.
Import Pre.RewriteRuleNotations.

Module Export Instances.
  Global Instance eval_rect_nat_rules : rules_proofs_for_eager_type nat
    := existT (PrimitiveHList.hlist (@Datatypes.snd bool Prop))
              [Types.dont_do_again _; Types.dont_do_again _]
              (@eval_nat_rect_arrow, (@eval_nat_rect, tt))%primproj.

  Global Instance eval_rect_list_rules : rules_proofs_for_eager_type list
    := existT (PrimitiveHList.hlist (@Datatypes.snd bool Prop))
              [Types.dont_do_again _; Types.dont_do_again _; Types.dont_do_again _; Types.dont_do_again _; Types.dont_do_again _]
              (@eval_list_rect_arrow, (@eval_list_rect, (@eval_list_case_nil, (@eval_list_case_cons, (@eval_list_nth_default, tt)))))%primproj.

  Global Instance eval_rect_prod_rules : rules_proofs_for_eager_type prod
    := existT (PrimitiveHList.hlist (@Datatypes.snd bool Prop))
              [Types.dont_do_again _]
              (@eval_prod_rect, tt)%primproj.

  Global Instance eval_rect_option_rules : rules_proofs_for_eager_type option
    := existT (PrimitiveHList.hlist (@Datatypes.snd bool Prop))
              [Types.dont_do_again _; Types.dont_do_again _]
              (@eval_option_rect_Some, (@eval_option_rect_None, tt))%primproj.

  Global Instance eval_rect_bool_rules : rules_proofs_for_eager_type bool
    := existT (PrimitiveHList.hlist (@Datatypes.snd bool Prop))
              [Types.dont_do_again _; Types.dont_do_again _]
              (@eval_bool_rect_true, (@eval_bool_rect_false, tt))%primproj.
End Instances.


(*

  Copyright 2014 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/>.

  Website: http://nuprl.org/html/verification/
  Authors: Abhishek Anand & Vincent Rahli

*)

Require Import rules_useful.
Require Import sequents_useful.
Require Import sequents_equality.
(** printing |- $\vdash$ *)
(** printing ->  $\rightarrow$ *)
(* begin hide *)

(* end hide *)

(* [15] ============ FUNCTIONALITY ============ *)

(* we need [x : Base] to be hidden because in the main sequent
   we get two substitutions x -> t1 and x -> t2 such that
   t1 = t2 in A, but in the second sequent we get
   t1 = t2 in Base.
*)

(**

  This is the functionality rule that exposes the functionality part
  of the meaning of sequents:
<<
   G, x : A, J |- C ext t

     By functionality y z

     G, [x : Base], [z : x in A], J |- C ext t
     G, x : Base, y : Base, z : x = y in A, J |- C = C[x\y]
>>
*)

Definition rule_functionality {p}
           (G J   : @barehypotheses p)
           (A C t : NTerm)
           (x y z : NVar)
           (i     : nat) :=
  mk_rule
    (mk_baresequent (snoc G (mk_hyp x A) ++ J) (mk_concl C t))
    [ mk_baresequent
        (snoc (snoc G (mk_hhyp x mk_base))
              (mk_hhyp z (mk_member (mk_var x) A))
              ++ J)
        (mk_concl C t),
      mk_baresequent
        (snoc (snoc (snoc G (mk_hyp x mk_base))
                    (mk_hyp y mk_base))
              (mk_hyp z (mk_equality (mk_var x) (mk_var y) A))
              ++ J)
        (mk_conclax (mk_equality C (subst C x (mk_var y)) (mk_uni i)))
    ]
    [].

Lemma rule_functionaliy_true {pp} :
  forall lib (G J   : @barehypotheses pp)
         (A C t : NTerm)
         (x y z : NVar)
         (i     : nat)
         (bc    : !LIn y (bound_vars C)),
    rule_true lib (rule_functionality G J A C t x y z i).
Proof.
  unfold rule_functionality, rule_true, closed_type_baresequent, closed_extract_baresequent; simpl.
  intros.
  clear cargs.

  (* We prove the well-formedness of things *)
  destseq; allsimpl.
  generalize (hyps (mk_baresequent
                      (snoc (snoc G (mk_hhyp x mk_base))
                            (mk_hhyp z (mk_member (mk_var x) A)) ++ J)
                      (mk_concl C t))
                   (inl eq_refl))
             (hyps (mk_baresequent
                      (snoc (snoc (snoc G (mk_hyp x mk_base)) (mk_hyp y mk_base))
                            (mk_hyp z (mk_equality (mk_var x) (mk_var y) A)) ++ J)
                      (mk_conclax (mk_equality C (subst C x (mk_var y)) (mk_uni i))))
                   (inr (inl eq_refl)));
    simpl; intros hyp1 hyp2; clear hyps.
  destruct hyp1 as [ ws1 hyp1 ].
  destruct hyp2 as [ ws2 hyp2 ].
  destseq; allsimpl; proof_irr; GC.

  allunfold @closed_type; allunfold @closed_extract; allsimpl.

  assert (covered t (nh_vars_hyps (snoc G (mk_hyp x A) ++ J))) as cv.
  clear hyp1 hyp2.
  dwfseq.
  introv j.
  discover.
  allrw in_app_iff; allrw in_snoc; sp.

  exists cv.

  (* We prove some simple facts on our sequents *)
  assert (!LIn x (vars_hyps G)
          # !LIn x (vars_hyps J)
          # !LIn y (vars_hyps G)
          # !LIn y (vars_hyps J)
          # !LIn z (vars_hyps G)
          # !LIn z (vars_hyps J)
          # !LIn x (free_vars A)
          # !LIn y (free_vars A)
          # !LIn y (free_vars C)
          # !LIn z (free_vars C)
          # !LIn x (free_vars t)
          # !LIn y (free_vars t)
          # !LIn z (free_vars t)
          # !LIn y (free_vars_hyps J)
          # !LIn z (free_vars_hyps J)
          # !LIn y (hyps_free_vars J)
          # !LIn z (hyps_free_vars J)
          # x <> y
          # x <> z
          # y <> z) as vhyps.

  clear hyp1 hyp2.
  dwfseq.
  sp; try (complete (discover; allrw in_app_iff; allrw in_snoc; sp;
                     generalize (subvars_hs_vars_hyps G); intro k1; rw subvars_prop in k1;
                     generalize (subvars_hs_vars_hyps J); intro k2; rw subvars_prop in k2;
                     discover; sp)).

  destruct vhyps as [ nixG vhyps ].
  destruct vhyps as [ nixJ vhyps ].
  destruct vhyps as [ niyG vhyps ].
  destruct vhyps as [ niyJ vhyps ].
  destruct vhyps as [ nizG vhyps ].
  destruct vhyps as [ nizJ vhyps ].
  destruct vhyps as [ nixA vhyps ].
  destruct vhyps as [ niyA vhyps ].
  destruct vhyps as [ niyC vhyps ].
  destruct vhyps as [ nizC vhyps ].
  destruct vhyps as [ nixt vhyps ].
  destruct vhyps as [ niyt vhyps ].
  destruct vhyps as [ nizt vhyps ].
  destruct vhyps as [ niyJ2 vhyps ].
  destruct vhyps as [ nizJ2 vhyps ].
  destruct vhyps as [ niyJ3 vhyps ].
  destruct vhyps as [ nizJ3 vhyps ].
  destruct vhyps as [ nxy vhyps ].
  destruct vhyps as [ nxz nyz ].
  (* done with proving these simple facts *)

  vr_seq_true.

  rw @similarity_app in sim; exrepnd; subst; cpx.
  rw @similarity_snoc in sim5; exrepnd; subst; allsimpl; cpx.

  dands.

  - vr_seq_true in hyp2.

    generalize (hyp2
                  (snoc (snoc (snoc s1a0 (x, t1)) (y, t2)) (z, mkc_axiom) ++ s1b)
                  (snoc (snoc (snoc s2a0 (x, t1)) (y, t2)) (z, mkc_axiom) ++ s2b));
      clear hyp2; intro hyp2.

    (* First we prove the hyps_functionality part of hyp2 *)
    autodimp hyp2 hyp.
    introv simil.
    rw @similarity_app in simil; exrepnd; subst; cpx.
    apply app_split in simil0; simpl; repnd; subst; allrw length_snoc; cpx;
    try (complete (allrw @similarity_dom; repnd; allrw; sp)).
    rw @similarity_snoc in simil5; exrepnd; subst; allsimpl; cpx.
    rw @similarity_snoc in simil5; exrepnd; subst; allsimpl; cpx.
    rw @similarity_snoc in simil6; exrepnd; subst; allsimpl; cpx.
    lsubst_tac.
    allrw @equality_in_base_iff.
    allrw @equality_in_mkc_equality; repnd.
    spcast.

    rewrite substitute_hyps_snoc_sub_weak in simil1; try (complete sp).
    rewrite substitute_hyps_snoc_sub_weak in simil1; try (complete sp).

    duplicate eqh as eqh'.
    apply hyps_functionality_init_seg with (s3 := s2b0) in eqh; try (complete sp).
    generalize (@hyps_functionality_init_seg_snoc2 pp lib s1a t2 t0 G x A w p eqh);
      intro hf; autodimp hf hyp.

    rw @eq_hyps_app.
    exists (snoc (snoc (snoc s1a (x, t2)) (y, t0)) (z, mkc_axiom))
           s1b0
           (snoc (snoc (snoc s2a1 (x, t5)) (y, t4)) (z, t3))
           s2b0;
      allrw length_snoc; dands; try (complete sp).

    assert (cover_vars (mk_equality (mk_var x) (mk_var y) A)
                       (snoc (snoc s2a1 (x, t5)) (y, t4)))
           as cv2
           by (apply cover_vars_change_sub with (sub1 := snoc (snoc s1a (x, t2)) (y, t0)); sp;
               allrw @dom_csub_snoc; simpl; sp;
               apply @similarity_dom in simil7; repnd; allrw; sp).

    rw @eq_hyps_snoc; simpl.
    exists (snoc (snoc s1a (x, t2)) (y, t0))
           (snoc (snoc s2a1 (x, t5)) (y, t4))
           (@mkc_axiom pp)
           t3
           w0
           p0
           cv2; dands; try (complete sp).

    assert (cover_vars mk_base (snoc s2a1 (x, t5))) as cv3 by (apply cover_vars_base).

    rw @eq_hyps_snoc; simpl.
    exists (snoc s1a (x, t2)) (snoc s2a1 (x, t5)) t0 t4 w1 p1 cv3;
      dands;
      try (complete sp);
      try (complete (lsubst_tac; apply tequality_base)).

    assert (cover_vars mk_base s2a1) as cv4 by (apply cover_vars_base).

    rw @eq_hyps_snoc; simpl.
    exists s1a s2a1 t2 t5 w1 p2 cv4;
      dands;
      try (complete sp);
      try (complete (lsubst_tac; apply tequality_base)).
   (* end of the eq_hyps proof *)

   (* tequality it will follow from squiggle equality*)
    lsubst_tac; GC.
    assert (tequality lib (lsubstc A w s1a p) (lsubstc A w s2a1 c7))
           as teq
           by (generalize (eqh (snoc s2a1 (x,t0))); intro imp;
               autodimp imp hyp;
               try (rw @similarity_snoc; simpl);
               try (exists s1a s2a1 t2 t0 w p; sp);
               rw @eq_hyps_snoc in imp; simpl in imp; exrepnd; cpx; proof_irr; sp).
    apply @tequality_equality_if_cequivc; dands; try (complete sp); sp.
    { (* sub_eq_hyps *)
    apply sub_eq_hyps_snoc_weak; sp.
    apply sub_eq_hyps_snoc_weak; sp.

    generalize (eqh' (snoc s2a1 (x,t5) ++ s2b0)); intro imp.
    autodimp imp hyp.
    rw @similarity_app.
    exists (snoc s1a (x, t2)) s1b0 (snoc s2a1 (x, t5)) s2b0; allrw length_snoc; sp.
    rw @similarity_snoc; simpl.
    exists s1a s2a1 t2 t5 w p; sp.
    apply @equality_respects_cequivc_right with (t2 := t2); sp.
    allapply @equality_refl; sp.
    rw @eq_hyps_app in imp; exrepnd.
    apply app_split in imp0; repnd; subst; allrw length_snoc; cpx;
    try (complete (allrw @similarity_dom; repnd; allrw; sp)).
    apply app_split in imp2; repnd; subst; allrw length_snoc; cpx;
    try (complete (allrw @similarity_dom; repnd; allrw; sp)).
   }

    (* Now we prove the similarity part of hyp2 *)
    autodimp hyp2 hyp.
    rw @similarity_app; simpl.
    exists (snoc (snoc (snoc s1a0 (x, t1)) (y, t2)) (z, mkc_axiom)) s1b
           (snoc (snoc (snoc s2a0 (x, t1)) (y, t2)) (z, mkc_axiom)) s2b;
      allrw length_snoc; sp.

    assert (wf_term (mk_equality (mk_var x) (mk_var y) A))
           as wfeq by (rw <- @wf_equality_iff; sp).

    assert (cover_vars (mk_equality (mk_var x) (mk_var y) A)
                       (snoc (snoc s1a0 (x, t1)) (y, t2)))
           as cv1
           by (rw @cover_vars_equality; sp; try (apply cover_vars_var; sp);
               allrw @dom_csub_snoc; simpl; allrw in_snoc; sp;
               repeat (apply cover_vars_snoc_weak); sp).

    rw @similarity_snoc; simpl.
    exists (snoc (snoc s1a0 (x, t1)) (y, t2))
           (snoc (snoc s2a0 (x, t1)) (y, t2))
           (@mkc_axiom pp) (@mkc_axiom pp)
           wfeq cv1; sp.

    rw @similarity_snoc; simpl.
    exists (snoc s1a0 (x, t1)) (snoc s2a0 (x, t1)) t2 t2
           (@wf_base pp) (cover_vars_base (snoc s1a0 (x, t1))); sp.

    rw @similarity_snoc; simpl.
    exists s1a0 s2a0 t1 t1 (@wf_base pp) (cover_vars_base s1a0); sp.

    lsubst_tac; apply member_base.

    lsubst_tac; apply member_base.

    lsubst_tac; rw @member_eq; rw <- @member_equality_iff; sp.

    rewrite substitute_hyps_snoc_sub_weak; sp.
    rewrite substitute_hyps_snoc_sub_weak; sp.

    (* Now that we've proved hyps_functionality and similarity, we can use hyp2 *)
    exrepnd; lsubst_tac; proof_irr; GC.

    assert (cover_vars C (snoc s1a0 (x, t2) ++ s1b))
           as pC5
           by (apply cover_vars_change_sub with (sub1 := snoc s1a0 (x, t1) ++ s1b); sp;
               allrw @dom_csub_app; allrw @dom_csub_snoc; simpl;
               allapply @similarity_dom; repnd; allrw; sp).

    assert (cover_vars C (snoc s2a0 (x, t1) ++ s2b))
           as pC6
           by (apply cover_vars_change_sub with (sub1 := snoc s1a0 (x, t1) ++ s1b); sp;
               allrw @dom_csub_app; allrw @dom_csub_snoc; simpl;
               allapply @similarity_dom; repnd; allrw; sp).

    assert (cover_vars C (snoc s2a0 (x, t2) ++ s2b))
           as pC7
           by (apply cover_vars_change_sub with (sub1 := snoc s1a0 (x, t1) ++ s1b); sp;
               allrw @dom_csub_app; allrw @dom_csub_snoc; simpl;
               allapply @similarity_dom; repnd; allrw; sp).

    assert (lsubstc C wfct
                    (snoc (snoc (snoc s1a0 (x, t1)) (y, t2)) (z, mkc_axiom) ++ s1b)
                    c1
            = lsubstc C wfct (snoc s1a0 (x, t1) ++ s1b) pC1)
           as eqc1
           by (generalize (lsubstc_csubst_ex2 C (snoc s1a0 (x, t1)) s1b wfct pC1);
               intro eq; exrepnd; rw <- eq1; clear eq1;
               generalize (lsubstc_csubst_ex2 C (snoc (snoc (snoc s1a0 (x, t1)) (y, t2)) (z, mkc_axiom)) s1b wfct c1);
               intro eq; exrepnd; rw <- eq1; clear eq1;
               revert w'0 p'0;
               rewrite subset_free_vars_csub_snoc; auto;
               rewrite subset_free_vars_csub_snoc; auto; intros;
               apply lsubstc_eq; auto).
    rw eqc1 in hyp0; rw eqc1 in hyp2.

    assert (lsubstc C wfct
                    (snoc (snoc (snoc s2a0 (x, t1)) (y, t2)) (z, mkc_axiom) ++ s2b)
                    c0
            = lsubstc C wfct (snoc s2a0 (x, t1) ++ s2b) pC6)
           as eqc2
           by (generalize (lsubstc_csubst_ex2 C (snoc s2a0 (x, t1)) s2b wfct pC6);
               intro eq; exrepnd; rw <- eq1; clear eq1;
               generalize (lsubstc_csubst_ex2 C (snoc (snoc (snoc s2a0 (x, t1)) (y, t2)) (z, mkc_axiom)) s2b wfct c0);
               intro eq; exrepnd; rw <- eq1; clear eq1;
               revert w'0 p'0;
               rewrite subset_free_vars_csub_snoc; auto;
               rewrite subset_free_vars_csub_snoc; auto; intros;
               apply lsubstc_eq; auto).
    rw eqc2 in hyp0.

    assert (lsubstc (subst C x (mk_var y)) w2
                    (snoc (snoc (snoc s1a0 (x, t1)) (y, t2)) (z, mkc_axiom) ++ s1b)
                    c2
            = lsubstc C wfct (snoc s1a0 (x, t2) ++ s1b) pC5)
           as eqc3.
    (* begin proof of assert *)
    generalize (lsubstc_csubst_ex2 C (snoc s1a0 (x, t2)) s1b wfct pC5);
      intro eq; exrepnd; rw <- eq1; clear eq1;
      generalize (lsubstc_csubst_ex2 (subst C x (mk_var y)) (snoc (snoc (snoc s1a0 (x, t1)) (y, t2)) (z, mkc_axiom)) s1b w2 c2);
      intro eq; exrepnd; rw <- eq1; clear eq1;
      apply lsubstc_eq; try (complete sp);
      rewrite subset_free_vars_csub_snoc; auto;
      try (complete (generalize (eqvars_free_vars_disjoint C [(x, mk_var y)]); intro eqv;
                     rw eqvars_prop in eqv; rw eqv; rw in_app_iff; rw in_remove_nvars; simpl;
                     boolvar; simpl; sp)).
    rw @csubst_subst_snoc_eq2;
      try (complete sp);
      try (complete (rw @dom_csub_snoc; simpl; rw in_snoc;
                     allapply @similarity_dom; repnd; allrw; sp)).
    rw @csub_filter_snoc1.
    rw @csub_filter_trivial; sp.
    rw disjoint_singleton_l; allapply @similarity_dom; repnd; allrw; sp.
    (* end proof of assert *)
    rw eqc3 in hyp0; rw eqc3 in hyp2.

    assert (lsubstc (subst C x (mk_var y)) w2
                    (snoc (snoc (snoc s2a0 (x, t1)) (y, t2)) (z, mkc_axiom) ++ s2b)
                    c3
            = lsubstc C wfct (snoc s2a0 (x, t2) ++ s2b) pC7)
           as eqc4.
    (* begin proof of assert *)
    generalize (lsubstc_csubst_ex2 C (snoc s2a0 (x, t2)) s2b wfct pC7);
      intro eq; exrepnd; rw <- eq1; clear eq1;
      generalize (lsubstc_csubst_ex2 (subst C x (mk_var y)) (snoc (snoc (snoc s2a0 (x, t1)) (y, t2)) (z, mkc_axiom)) s2b w2 c3);
      intro eq; exrepnd; rw <- eq1; clear eq1;
      apply lsubstc_eq; try (complete sp);
      rewrite subset_free_vars_csub_snoc; auto;
      try (complete (generalize (eqvars_free_vars_disjoint C [(x, mk_var y)]); intro eqv;
                     rw eqvars_prop in eqv; rw eqv; rw in_app_iff; rw in_remove_nvars; simpl;
                     boolvar; simpl; sp)).
    rw @csubst_subst_snoc_eq2;
      try (complete sp);
      try (complete (rw @dom_csub_snoc; simpl; rw in_snoc;
                     allapply @similarity_dom; repnd; allrw; sp)).
    rw @csub_filter_snoc1.
    rw @csub_filter_trivial; sp.
    rw disjoint_singleton_l; allapply @similarity_dom; repnd; allrw; sp.
    (* end proof of assert *)
    rw eqc4 in hyp0.

    clear eqc1 eqc2 eqc3 eqc4.
    proof_irr; GC.

    rw <- @member_equality_iff in hyp2.
    apply tequality_mkc_equality in hyp0. repnd.
    dup hyp2 as hh. apply equality_sym in hh. apply equality_refl in hh.
    apply hyp0 in hh.
    apply equality_in_uni with (i0 := i).
    eapply equality_trans; eauto.

  - vr_seq_true in hyp1.

    generalize (hyp1
                  (snoc (snoc s1a0 (x, t1)) (z, mkc_axiom) ++ s1b)
                  (snoc (snoc s2a0 (x, t1)) (z, mkc_axiom) ++ s2b));
      clear hyp1; intro hyp1.

    (* First we prove the hyps_functionality part of hyp1 *)
    autodimp hyp1 hyp.
    introv simil.
    rw @similarity_app in simil; exrepnd; subst; cpx.
    apply app_split in simil0; simpl; repnd; subst; allrw length_snoc; cpx;
    try (complete (allrw @similarity_dom; repnd; allrw; sp)).
    rw @similarity_snoc in simil5; exrepnd; subst; allsimpl; cpx.
    rw @similarity_snoc in simil5; exrepnd; subst; allsimpl; cpx.
    lsubst_tac.
    allrw @equality_in_base_iff.
    apply @equality_refl in simil2.
    rw <- @member_member_iff in simil2.
    spcast.

    rewrite substitute_hyps_snoc_sub_weak in simil1; try (complete sp).

    duplicate eqh as eqh'.
    apply hyps_functionality_init_seg with (s3 := s2b0) in eqh; try (complete sp).
    generalize (hyps_functionality_init_seg_snoc2 lib s1a t0 t2 G x A w p eqh);
      intro hf; autodimp hf hyp.

    rw @eq_hyps_app.
    exists (snoc (snoc s1a (x, t0)) (z, mkc_axiom))
           s1b0
           (snoc (snoc s2a (x, t4)) (z, t3))
           s2b0;
      allrw length_snoc; dands; try (complete sp).

    assert (cover_vars (mk_member (mk_var x) A) (snoc s2a (x, t4)))
           as cv1
           by (apply cover_vars_change_sub with (sub1 := snoc s1a (x, t0)); sp;
               allrw @dom_csub_app; allrw @dom_csub_snoc; simpl;
               allapply @similarity_dom; repnd; allrw; sp).

    rw @eq_hyps_snoc; simpl.
    exists (snoc s1a (x,t0)) (snoc s2a (x,t4)) (@mkc_axiom pp) t3 w0 p0 cv1; sp.

    rw @eq_hyps_snoc; simpl.
    exists s1a s2a t0 t4 (@wf_base pp) (cover_vars_base s1a) (cover_vars_base s2a); sp.

    lsubst_tac; apply @tequality_base.

    lsubst_tac; proof_irr; GC.
    (* tequality it will follow from squiggle equality*)
    assert (tequality lib (lsubstc A w s1a p) (lsubstc A w s2a c))
           as eqt
           by (generalize (eqh (snoc s2a (x,t2))); intro imp;
               autodimp imp hyp;
               try (rw @similarity_snoc; simpl);
               try (exists s1a s2a t0 t2 w p; sp);
               rw @eq_hyps_snoc in imp; simpl in imp; exrepnd; cpx; proof_irr; sp).
    apply @tequality_mkc_member_if_cequivc; dands; try (complete sp); sp.

    apply sub_eq_hyps_snoc_weak; sp.
    generalize (eqh' (snoc s2a (x, t4) ++ s2b0)); intro imp.
    autodimp imp hyp.
    rw @similarity_app.
    exists (snoc s1a (x,t0)) s1b0 (snoc s2a (x,t4)) s2b0; allrw length_snoc; sp.
    rw @similarity_snoc; simpl.
    exists s1a s2a t0 t4 w p; sp.
    apply @equality_respects_cequivc_right with (t2 := t0); sp.

    rw @eq_hyps_app in imp; simpl in imp; exrepnd.
    apply app_split in imp0; simpl; repnd; subst; allrw length_snoc; cpx;
    try (complete (allrw @similarity_dom; repnd; allrw; sp)).
    apply app_split in imp2; simpl; repnd; subst; allrw length_snoc; cpx;
    try (complete (allrw @similarity_dom; repnd; allrw; sp)).

    (* First we prove the similarity part of hyp1 *)
    autodimp hyp1 hyp.

    rw @similarity_app; simpl.
    exists (snoc (snoc s1a0 (x, t1)) (z, mkc_axiom)) s1b
           (snoc (snoc s2a0 (x, t1)) (z, mkc_axiom)) s2b;
      allrw length_snoc; sp;
      try (complete (rewrite substitute_hyps_snoc_sub_weak; sp)).

    assert (wf_term (mk_member (mk_var x) A))
           as wm
           by (unfold mk_member; apply wf_equality; sp).

    assert (cover_vars (mk_member (mk_var x) A) (snoc s1a0 (x, t1)))
           as cm
           by (unfold mk_member; rw @cover_vars_equality; sp;
               try (complete (apply cover_vars_snoc_weak_r; simpl; sp));
               apply cover_vars_snoc_weak; sp).

    rw @similarity_snoc; simpl.
    exists (snoc s1a0 (x, t1)) (snoc s2a0 (x, t1)) (@mkc_axiom pp) (@mkc_axiom pp) wm cm; sp.

    rw @similarity_snoc; simpl.
    exists s1a0 s2a0 t1 t1 (@wf_base pp) (cover_vars_base s1a0); sp.

    lsubst_tac; rw @equality_in_base_iff; spcast; sp.

    lsubst_tac; rw @member_eq; rw <- @member_member_iff.
    allapply @equality_refl; sp.

    exrepnd; lsubst_tac.
    subst_app.
    revert hyp0 hyp1.
    repeat match goal with
             | [ |- context[?x] ] =>
               match type of x with
                 | cover_vars _ _ => revert x
                 | wf_term _ => revert x
               end
           end.
    lsubst_tac.
    introv.
    proof_irr; sp.
Qed.

(* begin hide *)

Lemma lsubstc_snoc_app_weak {o} :
  forall t w s1 x u s2 c,
    !LIn x (@free_vars o t)
    -> {c' : cover_vars t (s1 ++ s2)
        & lsubstc t w (snoc s1 (x,u) ++ s2) c
          = lsubstc t w (s1 ++ s2) c'}.
Proof.
  introv ni.

  assert (cover_vars t (s1 ++ s2)) as c'.
  allrw @cover_vars_eq.
  provesv.
  allrw @dom_csub_app; allrw @dom_csub_snoc; allsimpl.
  allrw in_app_iff; allrw in_snoc; sp; subst; sp.

  assert (wf_term (csubst t (snoc s1 (x, u)))) as w1.
  apply wf_term_csubst; auto.

  assert (cover_vars (csubst t (snoc s1 (x, u))) s2) as c1.
  apply cover_vars_csubst; auto.

  assert (wf_term (csubst t s1)) as w2.
  apply wf_term_csubst; auto.

  assert (cover_vars (csubst t s1) s2) as c2.
  apply cover_vars_csubst; auto.

  exists c'.
  rewrite <- @lsubstc_csubst_eq with (w := w1) (p := c1).
  rewrite <- @lsubstc_csubst_eq with (w := w2) (p := c2).
  revert w1 c1.
  rewrite @subset_free_vars_csub_snoc with (t := t) (v := x); auto; introv.
  proof_irr; auto.
Qed.

Ltac lsubstc_snoc_app :=
  match goal with
    | [ H : context[lsubstc ?t ?w (snoc ?s1 (?x,?u) ++ ?s2) ?c] |- _ ] =>
      let h := fresh "h" in
      let e := fresh "e" in
      let c' := fresh "c'" in
      assert (!LIn x (free_vars t)) as h by eauto;
        generalize (lsubstc_snoc_app_weak t w s1 x u s2 c h);
        intro e; destruct e as [c' e];
        rewrite e in H;
        clear h e
  end.

Ltac lsubstc_app :=
  match goal with
    | [ H : context[lsubstc ?t ?w (?s1 ++ ?s2) ?c] |- _ ] =>
      let e := fresh "e" in
      let w' := fresh "w'" in
      let c' := fresh "c'" in
      generalize (lsubstc_csubst_ex2 t s1 s2 w c); intro e;
      destruct e as [w' e];
      destruct e as [c' e];
      rewrite <- e in H;
      clear e

    | [ |- context[lsubstc ?t ?w (?s1 ++ ?s2) ?c] ] =>
      let e := fresh "e" in
      let w' := fresh "w'" in
      let c' := fresh "c'" in
      generalize (lsubstc_csubst_ex2 t s1 s2 w c); intro e;
      destruct e as [w' e];
      destruct e as [c' e];
      rewrite <- e;
      clear e
  end.

Ltac csubst_subst_snoc :=
  match goal with
    | [ H : context[csubst (subst ?t ?x (mk_var ?y)) (snoc ?s (?y, ?u))] |- _ ] =>
      let e := fresh "e" in
      let h := fresh "h" in
      generalize (csubst_subst_snoc_eq2 s t x y u);
        intro e;
        autodimp e h;try (complete insub);[];
        autodimp e h;try (complete insub);[];
        autodimp e h;try (complete insub);[];
        rewrite e in H;
        clear e

    | [ |- context[csubst (subst ?t ?x (mk_var ?y)) (snoc ?s (?y, ?u))] ] =>
      let e := fresh "e" in
      let h := fresh "h" in
      generalize (csubst_subst_snoc_eq2 s t x y u);
        intro e;
        autodimp e h;try (complete insub);[];
        autodimp e h;try (complete insub);[];
        autodimp e h;try (complete insub);[];
        rewrite e;
        clear e
  end.

(* end hide *)

(* [15] ============ FUNCTIONALITY FOR EQUALITY ============ *)

(**

  This is a simpler version of the functionality rule to prove equalities:
<<
   G, x : A, J |- a = b in T

     By functionalityForEquality y z

     G, x : A, J | T in U(i)
     G, x : Base, y : Base, z : x = y in A, J |- a = b[x\y] in T
>>
*)

Definition rule_functionality_for_equality {o}
           (G J     : @barehypotheses o)
           (A a b T : NTerm)
           (x y z   : NVar)
           (i       : nat) :=
  mk_rule
    (mk_baresequent (snoc G (mk_hyp x A) ++ J) (mk_conclax (mk_equality a b T)))
    [ mk_baresequent
        (snoc G (mk_hyp x A) ++ J)
        (mk_conclax (mk_member T (mk_uni i))),
      mk_baresequent
        (snoc (snoc (snoc G (mk_hyp x mk_base))
                    (mk_hyp y mk_base))
              (mk_hyp z (mk_equality (mk_var x) (mk_var y) A))
              ++ J)
        (mk_conclax (mk_equality a (subst b x (mk_var y)) T))
    ]
    [].

Lemma rule_functionaliy_for_equality_true {o} :
  forall lib (G J     : @barehypotheses o)
         (A a b T : NTerm)
         (x y z   : NVar)
         (i       : nat)
         (bc      : !LIn y (bound_vars b)),
    rule_true lib (rule_functionality_for_equality G J A a b T x y z i).
Proof.
  unfold rule_functionality_for_equality, rule_true, closed_type_baresequent, closed_extract_baresequent; simpl.
  intros.
  clear cargs.

  (* We prove the well-formedness of things *)
  destseq; allsimpl.
  dLin_hyp.
  destruct Hyp  as [ws1 hyp1].
  destruct Hyp0 as [ws2 hyp2].
  destseq; allsimpl; proof_irr; GC.

  allunfold @closed_type; allunfold @closed_extract; allsimpl.

  exists (@covered_axiom o (nh_vars_hyps (snoc G (mk_hyp x A) ++ J))).

  (* We prove some simple facts on our sequents *)
  assert (!LIn x (vars_hyps G)
          # !LIn x (vars_hyps J)
          # !LIn y (vars_hyps G)
          # !LIn y (vars_hyps J)
          # !LIn z (vars_hyps G)
          # !LIn z (vars_hyps J)
          # !LIn x (free_vars A)
          # !LIn y (free_vars A)
          # !LIn z (free_vars A)
          # !LIn y (free_vars T)
          # !LIn z (free_vars T)
          # !LIn y (free_vars a)
          # !LIn z (free_vars a)
          # !LIn y (free_vars b)
          # !LIn z (free_vars b)
          # !LIn y (free_vars_hyps J)
          # !LIn z (free_vars_hyps J)
          # !LIn y (hyps_free_vars J)
          # !LIn z (hyps_free_vars J)
          # x <> y
          # x <> z
          # y <> z) as vhyps.

  clear hyp1 hyp2.
  dwfseq.
  sp; try (complete (discover; allrw in_app_iff; allrw in_snoc; sp;
                     generalize (subvars_hs_vars_hyps G); intro k1; rw subvars_prop in k1;
                     generalize (subvars_hs_vars_hyps J); intro k2; rw subvars_prop in k2;
                     discover; sp)).

  destruct vhyps as [ nixG vhyps ].
  destruct vhyps as [ nixJ vhyps ].
  destruct vhyps as [ niyG vhyps ].
  destruct vhyps as [ niyJ vhyps ].
  destruct vhyps as [ nizG vhyps ].
  destruct vhyps as [ nizJ vhyps ].
  destruct vhyps as [ nixA vhyps ].
  destruct vhyps as [ niyA vhyps ].
  destruct vhyps as [ nizA vhyps ].
  destruct vhyps as [ niyT vhyps ].
  destruct vhyps as [ nizT vhyps ].
  destruct vhyps as [ niya vhyps ].
  destruct vhyps as [ niza vhyps ].
  destruct vhyps as [ niyb vhyps ].
  destruct vhyps as [ nizb vhyps ].
  destruct vhyps as [ niyJ2 vhyps ].
  destruct vhyps as [ nizJ2 vhyps ].
  destruct vhyps as [ niyJ3 vhyps ].
  destruct vhyps as [ nizJ3 vhyps ].
  destruct vhyps as [ nxy vhyps ].
  destruct vhyps as [ nxz nyz ].
  (* done with proving these simple facts *)

  vr_seq_true.
  lsubst_tac.
  allrw @member_eq.
  allrw <- @member_equality_iff.

  apply teq_and_eq_if_equality with (H := snoc G (mk_hyp x A) ++ J); auto.

  - vr_seq_true in hyp1.
    generalize (hyp1 s1 s2 eqh sim); clear hyp1; intro hyp1; exrepnd.
    lsubst_tac.
     apply tequality_in_uni_implies_tequality in hyp0; auto.

    allrw @member_eq.
    allrw <- @member_member_iff.
    auto.

  - clear dependent s1.
    clear dependent s2.
    introv hf sim.

    clear hyp1.

    rw @similarity_app in sim; simpl in sim; exrepnd; subst; cpx.
    rw @similarity_snoc in sim5; simpl in sim5; exrepnd; subst; cpx.

    vr_seq_true in hyp2.
    generalize (hyp2
                  (snoc (snoc (snoc s1a0 (x,t1)) (y,t2)) (z,mkc_axiom) ++ s1b)
                  (snoc (snoc (snoc s2a0 (x,t1)) (y,t2)) (z,mkc_axiom) ++ s2b)).
    clear hyp2; intro hyp2.

    autodimp hyp2 hyp.

    (* -- We start proving the hyps_functionality -- *)
    introv sim'.
    rw @similarity_app in sim'; simpl in sim'; exrepnd; subst; cpx.
    apply app_split in sim'0; simpl; repnd; subst; allrw length_snoc; cpx;
    try (complete (allrw @similarity_dom; repnd; allrw; sp)).
    rw @similarity_snoc in sim'5; simpl in sim'5; exrepnd; subst; cpx.
    rw @similarity_snoc in sim'5; simpl in sim'5; exrepnd; subst; cpx.
    rw @similarity_snoc in sim'6; simpl in sim'6; exrepnd; subst; cpx.
    lsubst_tac.
    allrw @equality_in_base_iff.
    allrw @equality_in_mkc_equality; repnd.
    spcast; GC.

    rewrite substitute_hyps_snoc_sub_weak in sim'1; try (complete sp).
    rewrite substitute_hyps_snoc_sub_weak in sim'1; try (complete sp).

    duplicate hf as hf1.
    apply hyps_functionality_init_seg with (s3 := s2b0) in hf1; try (complete sp).
    generalize (hyps_functionality_init_seg_snoc2 lib s1a t2 t0 G x A w p hf1 sim2);
      intro hf2.

    rw @eq_hyps_app; simpl.
    eexists; eexists; eexists; eexists; dands; auto; allrw length_snoc; auto.

    rw @eq_hyps_snoc; simpl.
    eexists; eexists; eexists; eexists; eexists; eexists; eexists; dands; auto.

    rw @eq_hyps_snoc; simpl.
    eexists; eexists; eexists; eexists; eexists; eexists; eexists; dands; auto;
    try (complete (lsubst_tac; apply @tequality_base)).

    rw @eq_hyps_snoc; simpl.
    eexists; eexists; eexists; eexists; eexists; eexists; eexists; dands; auto;
    try (complete (lsubst_tac; apply @tequality_base)).

    lsubst_tac.
    apply @tequality_equality_if_cequivc; auto.
    generalize (hf1 (snoc s2a1 (x,t0))); intro k.
    autodimp k hyp.
    rw @similarity_snoc; simpl.
    eexists; eexists; eexists; eexists; eexists; eexists; eexists; dands; auto.
    exact sim2.
    rw @eq_hyps_snoc in k; simpl in k; exrepnd; cpx; proof_irr; auto.

    apply sub_eq_hyps_snoc_weak; auto.
    apply sub_eq_hyps_snoc_weak; auto.
    generalize (hf (snoc s2a1 (x,t5) ++ s2b0)); intro k.
    autodimp k hyp.
    rw @similarity_app; simpl.
    eexists; eexists; eexists; eexists; dands; auto; allrw length_snoc; auto.
    rw @similarity_snoc; simpl.
    eexists; eexists; eexists; eexists; eexists; eexists; eexists; dands; auto.
    apply @equality_respects_cequivc; auto.
    apply @equality_refl in sim2; exact sim2.
    rw @eq_hyps_app in k; simpl in k; exrepnd; cpx.
    apply app_split in k0; repnd; subst; allrw length_snoc; cpx;
    try (complete (allrw @similarity_dom; repnd; allrw; sp)).
    apply app_split in k2; repnd; subst; allrw length_snoc; cpx;
    try (complete (allrw @similarity_dom; repnd; allrw; sp)).

    (* -- We now prove the similarity hyp -- *)
    autodimp hyp2 hyp.
    rw @similarity_app; simpl.
    eexists; eexists; eexists; eexists; dands; auto; allrw length_snoc; auto.

    rw @similarity_snoc; simpl.
    eexists; eexists; eexists; eexists; eexists; eexists; dands; auto; allrw length_snoc; auto.

    rw @similarity_snoc; simpl.
    eexists; eexists; eexists; eexists; eexists; eexists; dands; auto; allrw length_snoc; auto.

    rw @similarity_snoc; simpl.
    eexists; eexists; eexists; eexists; eexists; eexists; dands; auto; allrw length_snoc; auto.

    lsubst_tac.
    apply @equality_in_base_iff; spcast; auto.

    lsubst_tac.
    apply @equality_in_base_iff; spcast; auto.

    lsubst_tac.
    rw <- @member_equality_iff; auto.

    rewrite substitute_hyps_snoc_sub_weak; sp.
    rewrite substitute_hyps_snoc_sub_weak; sp.

    (* -- We can now use our hypothesis -- *)
    exrepnd; lsubst_tac; proof_irr; GC.
    allrw @member_eq.
    allrw <- @member_equality_iff.

    assert (!LIn z (free_vars (subst b x (mk_var y)))) as nizs.
    generalize (eqvars_free_vars_disjoint b [(x,mk_var y)]); simpl; boolvar; simpl;
    rw @fold_subst; introv eqv iz;
    rw eqvars_prop in eqv; apply eqv in iz;
    rw in_app_iff in iz; rw in_remove_nvars in iz; repeat (rw in_single_iff in iz); sp.

    repeat lsubstc_snoc_app; proof_irr; GC.
    revert dependent w3.
    revert dependent c'6.
    revert dependent c'11.
    lsubst_tac.
    introv tequ equ.
    repeat lsubstc_app; proof_irr.
    revert dependent w'3.
    revert dependent c'3.
    revert dependent w'6.
    revert dependent c'14.
    repeat csubst_subst_snoc.
    repeat (rw @csub_filter_snoc; boolvar; allrw not_over_or; try (complete sp)).
    repeat (rw @csub_filter_trivial; try (complete (rw disjoint_singleton_l; insub))).
    introv tequ equ; proof_irr.
    eapply @equality_commutes4 in tequ; eauto.

    Grab Existential Variables.
    auto.
    auto.
    auto.
    auto.
    apply cover_vars_equality; dands;
    try (apply cover_vars_var); repeat (rw @dom_csub_snoc); simpl;
    repeat (rw in_snoc); sp;
    repeat (apply cover_vars_snoc_weak); auto.
    apply wf_equality; auto.
    auto.
    auto.
    auto.
    auto.
    auto.
    auto.
    apply cover_vars_equality; dands;
    try (apply cover_vars_var); repeat (rw @dom_csub_snoc); simpl;
    repeat (rw in_snoc); sp;
    repeat (apply cover_vars_snoc_weak); auto;
    apply cover_vars_change_sub with (sub1 := s1a); auto;
    allapply @similarity_dom; sp; allrw; sp.
    apply cover_vars_equality; dands;
    try (apply cover_vars_var); repeat (rw @dom_csub_snoc); simpl;
    repeat (rw in_snoc); sp;
    repeat (apply cover_vars_snoc_weak); auto.
    apply wf_equality; auto.
Qed.

(*
*** Local Variables:
*** coq-load-path: ("." "../util/" "../terms/" "../computation/" "../cequiv/" "../per/" "../close/")
*** End:
*)


Require Import Coq.Lists.List.
Require Import MirrorShard.Expr MirrorShard.Env.
Require Import MirrorShard.Prover.

Set Implicit Arguments.
Set Strict Implicit.

Local Notation "[ x , .. , y ]" := (cons x .. (cons y nil) ..).

(** * The Reflexivity Prover **)

Section ReflexivityProver.
  Context {types : list type}.
  Variable fs : functions types.

  Definition reflexivityValid (_ _ : env types) (_ : unit) := True.

  Definition reflexivitySummarize (_ : list (expr types)) := tt.

  Definition reflexivityProve (_ : unit) (goal : expr types) :=
    match goal with
      | Equal _ x y => if expr_seq_dec x y then true else false
      | _ => false
    end.

  Definition reflexivityLearn (sum : unit) (hyps : list (expr types)) := sum.

  Lemma reflexivitySummarizeCorrect : forall uvars vars hyps,
    AllProvable fs uvars vars hyps ->
    reflexivityValid uvars vars (reflexivitySummarize hyps).
  Proof.
    unfold reflexivityValid; auto.
  Qed.

  Lemma reflexivityLearnCorrect : forall uvars vars sum,
    reflexivityValid uvars vars sum -> forall hyps,
    AllProvable fs uvars vars hyps ->
    reflexivityValid uvars vars (reflexivityLearn sum hyps).
  Proof.
    unfold reflexivityValid; auto.
  Qed.

  Theorem reflexivityProverCorrect : ProverCorrect fs reflexivityValid reflexivityProve.
    apply ProverCorrect_ProverCorrect'.
    unfold reflexivityProve; t.
  Qed.

  Definition reflexivityProver : ProverT types :=
  {| Facts := unit
   ; Summarize := fun _ => tt
   ; Learn := fun x _ => x
   ; Prove := reflexivityProve
   |}.
  Definition reflexivityProver_correct : ProverT_correct reflexivityProver fs.
  eapply Build_ProverT_correct with (Valid := reflexivityValid);
    eauto using reflexivitySummarizeCorrect, reflexivityLearnCorrect, reflexivityProverCorrect.
  Qed.

End ReflexivityProver.

Definition ReflexivityProver : ProverPackage :=
{| ProverTypes := nil_Repr EmptySet_type
 ; ProverFuncs := fun ts => nil_Repr (Default_signature ts)
 ; Prover_correct := fun ts fs => reflexivityProver_correct fs
|}.

Ltac unfold_reflexivityProver H :=
  match H with
    | tt =>
      cbv delta [
        reflexivityProver
        reflexivitySummarize reflexivityLearn reflexivityProve
        expr_seq_dec
      ]
    | _ =>
      cbv delta [
        reflexivityProver
        reflexivitySummarize reflexivityLearn reflexivityProve
        expr_seq_dec
      ] in H
  end.


(*

  Copyright 2014 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/>.

  Website: http://nuprl.org/html/verification/
  Authors: Abhishek Anand & Vincent Rahli

*)

Require Import type_sys_useful.
Require Import dest_close.

Lemma close_type_system_w {p} :
  forall lib (ts : cts(p))
         T T'
         (eq : per)
         A A' v v' B B' eqa eqb,
    type_system lib ts
    -> defines_only_universes lib ts
    -> computes_to_valc lib T (mkc_w A v B)
    -> computes_to_valc lib T' (mkc_w A' v' B')
    -> close lib ts A A' eqa
    -> (forall (a a' : CTerm) (e : eqa a a'),
          close lib ts (substc a v B) (substc a' v' B') (eqb a a' e))
    -> (forall (a a' : CTerm) (e : eqa a a'),
          type_system lib ts ->
          defines_only_universes lib ts ->
          type_sys_props lib (close lib ts) (substc a v B) (substc a' v' B')
                         (eqb a a' e))
    -> (forall t t' : CTerm, eq t t' <=> weq lib eqa eqb t t')
    -> per_w lib (close lib ts) T T' eq
    -> type_sys_props lib (close lib ts) A A' eqa
    -> type_sys_props lib (close lib ts) T T' eq.
Proof.
  introv X X0 c1 c2 X1 clb recb eqiff per IHX1.

  rw @type_sys_props_iff_type_sys_props3.
  prove_type_sys_props3 SCase; intros.

  + SCase "uniquely_valued".
    dclose_lr.

    SSCase "CL_w".
    allunfold @per_w; exrepd.
    generalize (eq_term_equals_type_family lib T T3 eqa0 eqa eqb0 eqb (close lib ts) A v B A' v' B' mkc_w); intro i.
    repeat (autodimp i hyp; try (complete (introv eqw; eqconstr eqw; sp))); repnd.

    unfold eq_term_equals; sp.
    rw e; rw eqiff; split; sp.

    apply @weq_eq_term_equals with (eqa1 := eqa) (eqb1 := eqb); sp.
    generalize (i1 a1 a2 e2 e1); sp; apply eq_term_equals_sym; sp.

    apply @weq_eq_term_equals with (eqa1 := eqa0) (eqb1 := eqb0); sp.
    apply eq_term_equals_sym; sp.

  + SCase "type_symmetric"; repdors; subst; dclose_lr;
    apply CL_w;
    clear per;
    allunfold @per_w; exrepd;
    unfold per_w;
    exists eqa0 eqb0; sp;
    allrw <-; sp;
    apply eq_term_equals_trans with (eq2 := eq); sp;
    try (complete (apply eq_term_equals_sym; auto)).

  + SCase "type_value_respecting"; repdors; subst;
    apply CL_w; unfold per_w; exists eqa eqb; sp.

    duplicate c1 as ct.
    apply @cequivc_mkc_w with (T' := T3) in ct; sp.

    apply @type_family_cequivc
          with
          (A1 := A)
          (v1 := v)
          (B1 := B)
          (A2 := A'0)
          (v2 := v'0)
          (B2 := B'0)
          (A := A')
          (v := v')
          (B := B'); sp.

    duplicate c2 as ct.
    apply @cequivc_mkc_w with (T' := T3) in ct; sp.

    apply @type_family_cequivc2
          with
          (A1 := A')
          (v1 := v')
          (B1 := B')
          (A2 := A'0)
          (v2 := v'0)
          (B2 := B'0)
          (A := A)
          (v := v)
          (B := B); sp.

  + SCase "term_symmetric".
    unfold term_equality_symmetric; sp.
    onedtsp e pp p0 p1 c t t0 t3 tygs tygt dum.
    apply eqiff; sp.
    assert (eq t1 t2) as eq12 by auto.
    apply eqiff in eq12.

    apply @weq_sym with (v1 := v) (v2 := v') (B1 := B) (B2 := B') (ts := close lib ts); sp.

  + SCase "term_transitive".
    unfold term_equality_transitive; sp.
    apply eqiff; sp.
    assert (eq t1 t2) as eq12 by auto.
    assert (eq t2 t3) as eq23 by auto.
    apply eqiff in eq12.
    apply eqiff in eq23.
    onedtsp uv1 tys1 tyt1 tyst1 tyvr1 tes1 tet1 tevr1 tygs1 tygt1 dum1; sp.
    apply @weq_trans with (t2 := t2) (ts := close lib ts) (v1 := v) (B1 := B) (v2 := v') (B2 := B'); sp.

  + SCase "term_value_respecting".
    unfold term_equality_respecting; sp.
    apply eqiff; sp.
    assert (eq t t) as eqtt by auto.
    apply eqiff in eqtt.
    onedtsp uv tys tyt tyst tyvr tes tet tevr tygs tygt dum.

    spcast; apply @weq_cequivc with (t1 := t) (ts := close lib ts) (v1 := v) (B1 := B) (v2 := v') (B2 := B'); sp.

  + SCase "type_gsymmetric".
    repdors; subst; split; sp; dclose_lr;
    apply CL_w;
    clear per;
    allunfold @per_w; exrepd.

    (* 1 *)
    generalize (eq_term_equals_type_family
                  lib T T3 eqa0 eqa eqb0 eqb (close lib ts)
                  A v B A' v' B' mkc_w); intro i.
    repeat (autodimp i hyp; try (complete (introv eqw; eqconstr eqw; sp))).
    repnd.

    unfold per_w.
    exists eqa eqb; sp.

    apply eq_term_equals_trans with (eq2 := weq lib eqa0 eqb0);
      try (complete sp); split; sp.

    apply weq_eq_term_equals with (eqa1 := eqa0) (eqb1 := eqb0); sp.
    apply eq_term_equals_sym; sp.

    apply weq_eq_term_equals with (eqa1 := eqa) (eqb1 := eqb); sp.
    apply eq_term_equals_sym; sp.

    (* 2 *)
    generalize (eq_term_equals_type_family2
                  lib T3 T eqa0 eqa eqb0 eqb (close lib ts)
                  A v B A' v' B' mkc_w); intro i;
    repeat (autodimp i hyp; try (complete (introv eqw; eqconstr eqw; sp)));
    repnd.

    unfold per_w.
    exists eqa eqb; sp.

    apply eq_term_equals_trans with (eq2 := weq lib eqa0 eqb0);
      try (complete sp); split; sp.

    apply weq_eq_term_equals with (eqa1 := eqa0) (eqb1 := eqb0); sp.
    apply eq_term_equals_sym; sp.

    apply weq_eq_term_equals with (eqa1 := eqa) (eqb1 := eqb); sp.
    apply eq_term_equals_sym; sp.

  + SCase "type_gtransitive"; sp.

  + SCase "type_mtransitive".
    repdors; subst; dclose_lr;
    try (move_term_to_top (per_w lib (close lib ts) T T4 eq2));
    try (move_term_to_top (per_w lib (close lib ts) T' T4 eq2)).

    (* 1 *)
    clear per.
    allunfold @per_w; exrepd.

    generalize (eq_term_equals_type_family2
                  lib T3 T eqa1 eqa eqb1 eqb (close lib ts)
                  A v B A' v' B' mkc_w); intro i.
    repeat (autodimp i hyp; try (complete (introv eqw; eqconstr eqw; sp))).
    repnd.

    generalize (type_family_trans2
                  lib mkc_w (close lib ts) T3 T T4 eqa eqb eqa0 eqb0 A v B A' v' B');
      intro j.
    repeat (autodimp j hyp; try (complete (introv eqw; eqconstr eqw; sp))).
    repnd.

    dands; apply CL_w; unfold per_w; exists eqa eqb; unfold eq_term_equals; sp; allrw.

    split; sp.

    apply @weq_eq_term_equals with (eqa1 := eqa1) (eqb1 := eqb1); sp.
    apply eq_term_equals_sym; sp.

    apply @weq_eq_term_equals with (eqa1 := eqa) (eqb1 := eqb); sp.
    apply eq_term_equals_sym; sp; try (complete (allrw <-; sp)).

    split; sp.

    apply @weq_eq_term_equals with (eqa1 := eqa0) (eqb1 := eqb0); sp.
    apply eq_term_equals_sym; sp.
    apply eq_term_equals_sym; sp.

    apply @weq_eq_term_equals with (eqa1 := eqa) (eqb1 := eqb); sp.

    (* 2 *)
    clear per.
    allunfold @per_w; exrepd.

    generalize (eq_term_equals_type_family2
                  lib T3 T' eqa1 eqa eqb1 eqb (close lib ts)
                  A' v' B' A v B mkc_w); intro i.
    repeat (autodimp i hyp;
            try (complete (introv eqw; eqconstr eqw; sp));
            try (complete (apply type_sys_props_sym; sp))).
    onedtsp uv tys tyt tyst tyvr tes tet tevr tygs tygt dum.
    intros.
    apply type_sys_props_sym.
    apply type_sys_props_eqb_comm; sp.
    apply tet with (t2 := a'); sp.
    apply tet with (t2 := a); sp.
    repnd.

    generalize (type_family_trans2
                  lib mkc_w (close lib ts) T3 T' T4 eqa eqb eqa0 eqb0 A' v' B' A v B); intro j.
    repeat (autodimp j hyp;
            try (complete (introv eqw; eqconstr eqw; sp));
            try (complete (apply type_sys_props_sym; sp))).
    onedtsp uv tys tyt tyst tyvr tes tet tevr tygs tygt dum.
    intros.
    apply type_sys_props_sym.
    apply type_sys_props_eqb_comm; sp.
    apply tet with (t2 := a'); sp.
    apply tet with (t2 := a); sp.
    repnd.

    dands; apply CL_w; unfold per_w; exists eqa eqb; unfold eq_term_equals; sp; allrw.

    split; sp.

    apply @weq_eq_term_equals with (eqa1 := eqa1) (eqb1 := eqb1); sp.
    apply eq_term_equals_sym; sp.

    apply @weq_eq_term_equals with (eqa1 := eqa) (eqb1 := eqb); sp.
    apply eq_term_equals_sym; sp.

    split; sp.

    apply @weq_eq_term_equals with (eqa1 := eqa0) (eqb1 := eqb0); sp.
    apply eq_term_equals_sym; sp.
    apply eq_term_equals_sym; sp.

    apply @weq_eq_term_equals with (eqa1 := eqa) (eqb1 := eqb); sp.
Qed.


Require Import Coq.ZArith.ZArith.
Require Import Coq.Lists.List.
Require Import Coq.Strings.String.
Require Import Crypto.Bedrock.Field.Common.Types.
Require Import Crypto.Bedrock.Field.Translation.Expr.
Require Import Crypto.Language.API.
Require Import Crypto.Util.Option.
Require Import Crypto.Util.Notations.
Import ListNotations. Local Open Scope Z_scope.

(* for [eauto with lia] *)
Require Import Crypto.BoundsPipeline.

Import API.Compilers.
Import Types.Notations.

Section Cmd.
  Context {p : Types.parameters}.
  Existing Instance Types.rep.Z.
  Existing Instance Types.rep.listZ_local. (* local list representation *)

  Fixpoint assign_list (nextn : nat) (xs : base_rtype base_listZ)
    : nat * base_ltype base_listZ * Syntax.cmd.cmd :=
    match xs with
      | [] => (0%nat, [], Syntax.cmd.skip)
      | x :: xs' =>
        let rec := assign_list (S nextn) xs' in
        (S (fst (fst rec)), varname_gen nextn :: snd (fst rec),
         Syntax.cmd.seq (Syntax.cmd.set (varname_gen nextn) x) (snd rec))
    end.

  Fixpoint assign_base {t : base.type} (nextn : nat)
    : base_rtype t -> (nat * base_ltype t * Syntax.cmd.cmd) :=
    match t with
    | base.type.prod a b =>
      fun rhs =>
        let assign1 := assign_base nextn (fst rhs) in
        let assign2 := assign_base (nextn + fst (fst assign1)) (snd rhs) in
        ((fst (fst assign1) + fst (fst assign2))%nat,
         (snd (fst assign1), snd (fst assign2)),
         Syntax.cmd.seq (snd assign1) (snd assign2))
    | base.type.list (base.type.type_base base.type.Z) =>
      assign_list nextn
    | base.type.list _ | base.type.option _ | base.type.unit
    | base.type.type_base _ =>
      fun rhs =>
        let v := varname_gen nextn in
        (1%nat, v, Syntax.cmd.set v rhs)
    end.

  Definition assign {t} (nextn : nat)
    : rtype t -> (nat * ltype t * Syntax.cmd.cmd) :=
    match t as t0 return
          rtype t0 -> nat * ltype t0 * _ with
    | type.base b => assign_base (t:=b) nextn
    | _ =>
      fun _ =>
        (0%nat, dummy_ltype _, Syntax.cmd.skip)
    end.

  Definition translate_ident2_for_cmd {a b c} (i : ident (a -> b -> c))
    : ltype a -> ltype b -> option (ltype c)
    := match i in ident t return ltype (type.domain t) -> ltype (type.domain (type.codomain t)) -> option (ltype (type.codomain (type.codomain t))) with
       | ident.cons base_Z => fun x xs => Some (x :: xs)
       | ident.pair _ _ => fun x y => Some (x, y)
       | _ => fun _ _ => None
       end.

  Fixpoint translate_cmd
           {t} (e : @API.expr ltype t) (nextn : nat)
    : nat (* number of variable names used *)
      * ltype t (* variables in which return values are stored *)
      * Syntax.cmd.cmd (* actual program *) :=
    match e in expr.expr t0
          return (nat * ltype t0 * Syntax.cmd.cmd) with
    | expr.LetIn (type.base t1) (type.base t2) x f =>
      let trx := assign nextn (translate_expr true x) in
      let trf := translate_cmd (f (snd (fst trx))) (nextn + fst (fst trx)) in
      ((fst (fst trx) + fst (fst trf))%nat,
       snd (fst trf),
       Syntax.cmd.seq (snd trx) (snd trf))
    | expr.App _ _ _ _ as e
      => let result_if_ident2
             := (ixy <- invert_expr.invert_AppIdent2_cps e (@translate_cmd) (@translate_cmd);
                let '(existT _ (i, translate_cmd_x, translate_cmd_y)) := ixy in
                let trx := translate_cmd_x nextn in
                let try := translate_cmd_y (fst (fst trx) + nextn)%nat in
                vars <- translate_ident2_for_cmd i (snd (fst trx)) (snd (fst try));
                Some ((fst (fst trx) + fst (fst try))%nat,
                      vars,
                      Syntax.cmd.seq (snd trx) (snd try)))%option in
         match result_if_ident2 with
         | Some res => res
         | None =>
           let v := translate_expr true e in
           assign nextn v
         end
    | expr.Ident type_listZ (ident.nil _) =>
      (0%nat, [], Syntax.cmd.skip)
    | expr.Ident _ i =>
      let v := translate_expr true (expr.Ident i) in
      assign nextn v
    | expr.Var _ v =>
      let v := translate_expr true (expr.Var v) in
      assign nextn v
    | _ => (0%nat, dummy_ltype _, Syntax.cmd.skip)
    end.
End Cmd.


Require Import Crypto.Specific.Framework.RawCurveParameters.
Require Import Crypto.Util.LetIn.

(***
Modulus : 2^140 - 27
Base: 23 + 1/3
***)

Definition curve : CurveParameters :=
  {|
    sz := 6%nat;
    base := 23 + 1/3;
    bitwidth := 32;
    s := 2^140;
    c := [(1, 27)];
    carry_chains := Some [seq 0 (pred 6); [0; 1]]%nat;

    a24 := None;
    coef_div_modulus := Some 2%nat;

    goldilocks := None;
    karatsuba := None;
    montgomery := false;
    freeze := Some true;
    ladderstep := false;

    mul_code := None;

    square_code := None;

    upper_bound_of_exponent_loose := None;
    upper_bound_of_exponent_tight := None;
    allowable_bit_widths := None;
    freeze_extra_allowable_bit_widths := None;
    modinv_fuel := None
  |}.

Ltac extra_prove_mul_eq _ := idtac.
Ltac extra_prove_square_eq _ := idtac.


Require Import Coq.Program.Utils.
Require Import Coq.Logic.Eqdep_dec.
Require Import Lists.ListSet.
Require Import List.
Require Import Coq.Classes.EquivDec.

Require Export Evaluation.

Open Scope prg.

Section unch.
  Context `{C : redCFG}.

  Notation "p --> q" := (edge p q = true) (at level 55,right associativity).

  Definition Unch := Lab -> Var -> set Lab.

  Lemma Lab_dec' `{redCFG} : forall (l l' : Lab), { l = l' } + { l <> l'}.
  Proof.
    apply Lab_dec.
  Qed.

  (** * RD-Concretizer **)
  (** ** Definition **)

  Definition unch_concr (unch : Unch) : Traces :=
    fun t => forall to i s u x, In (to, i, s) (`t) ->
                        set_In u (unch to x) ->
                        exists j r, Precedes' (`t) (u, j, r) (to, i, s) /\
                               r x = s x.

  Definition unch_meet (u1 u2 : Unch) : Unch
    := fun (p : Lab) (x : Var) => set_union Lab_dec' (u1 p x) (u2 p x).

  Infix "⊓" := unch_meet (at level 70).

  (** * Meet-preserving **)

  Lemma unch_concr_meet_preserve (u1 u2 : Unch) (t : trace)
    : unch_concr (u1 ⊓ u2) t <-> unch_concr u1 t /\ unch_concr u2 t.
  Proof.
    split;intros H.
    - unfold unch_concr in *. split;intros.
      1,2: specialize (H to i s u x H0); exploit H;eauto.
      1,2: unfold unch_meet.
      + eapply set_union_intro1;eauto.
      + eapply set_union_intro2;eauto.
    - destruct H.
      unfold unch_concr in *.
      intros.
      eapply set_union_elim in H2. destruct H2.
      + eapply H;eauto.
      + eapply H0;eauto.
  Qed.

  (** * RD-transformer **)

  (** ** Definition **)

  Definition unch_join_ptw (d d' : set Lab) := set_inter Lab_dec' d d'.

  Definition unch_join (u u' : Unch) : Unch :=
    fun l x => unch_join_ptw (u l x) (u' l x).

  Definition unch_trans_local (unch : Unch) (q p : Lab) (x : Var) : set Lab :=
    set_add Lab_dec' p (if is_def x q p then empty_set Lab else unch q x).

  Definition unch_trans_ptw (unch : Unch) l x : set Lab :=
    match preds l with
    | nil => set_add Lab_dec' l (empty_set Lab)
    | p :: ps => let t := fun q => unch_trans_local unch q l x in
               fold_right (set_inter Lab_dec') (elem Lab) (map t (p :: ps))
    end.

  Definition unch_trans (unch : Unch) : Unch :=
    fun l x => unch_trans_ptw unch l x.

  Lemma in_preds p q : q ∈ preds p <-> q --> p.
  Proof.
    unfold preds; rewrite in_filter_iff; firstorder; cbn in *.
    - destruct (edge q p);eauto.
    - rewrite H;eauto.
  Qed.

  Lemma unch_trans_root : forall unch x, unch_trans unch root x = set_add Lab_dec' root (empty_set Lab).
  Proof.
    intros.
    cut (preds root = nil); intros.
    + unfold unch_trans, unch_trans_ptw.
      rewrite H. reflexivity.
    + cut (forall q, ~ List.In q (preds root)); intros; eauto using list_emp_in, root_no_pred.
      rewrite in_preds. intros H. eapply root_no_pred; eauto.
  Qed.

  Lemma unch_trans_lem u to x unch :
    set_In u (unch_trans unch to x) ->
    u = to \/ (forall q, List.In q (preds to) -> (is_def x q to = false /\ set_In u (unch q x))).
  Proof.
    intros.
    unfold unch_trans, unch_trans_ptw, unch_join_ptw, unch_trans_local in H.
    induction (preds to); simpl in *.
    - right. intros. inject H0.
    - eapply set_inter_elim in H.
      destruct H as [Hin Hother].
      destruct l.
      + simpl in Hother.
        destruct (is_def x a) eqn:Hdef; simpl in Hin.
        inject Hin; intuition.
        destruct (Lab_dec' u to); [ eauto | ].
        right. intros.
        inject H.
        * split; eauto using set_add_elim2.
        * inject H0.
      + eapply IHl in Hother. clear IHl.
        inject Hother; [ eauto |].
        destruct (Lab_dec' u to); subst; eauto.
        right.
        intros.
        inject H0; [ subst | eauto].
        destruct (is_def x q to).
        * simpl in Hin. firstorder auto with *.
        * eauto using set_add_elim2.
  Qed.

  Definition unch_concr' (unch : Unch) (l : list Conf) :=
    forall (to : Lab) (i : Tag) (s : State) (u : Lab) (x : Var),
      (to,i,s) ∈ l ->
      u ∈ unch to x ->
      exists (j : Tag) (r : State), Precedes' l (u,j,r) (to,i,s) /\ r x = s x.

  Lemma prefix_trans_NoDup (A : Type) `{EqDec A eq} (a : A) (l l1 l2 : list A)
        (Hpre1 : Prefix (a :: l1) l)
        (Hpre2 : Prefix l2 l)
        (Hnd : NoDup l)
        (Hin : a ∈ l2)
    : Prefix (a :: l1) l2.
  Proof.
    induction l;cbn.
    - eapply prefix_incl in Hin;eauto. cbn in Hin. contradiction.
    - inversion_clear Hnd;subst. decide' (a == a0).
      + inversion Hpre1;subst.
        * inversion Hpre2; subst; [econstructor|].
          eapply prefix_incl in Hin; eauto. congruence.
        * exfalso. eapply prefix_incl in H4. firstorder.
      + eapply prefix_incl in Hin;eauto. destruct Hin;[congruence|].
        inversion Hpre1;subst;[congruence|].
        inversion Hpre2; subst.
        * econstructor;eauto.
        * eapply IHl;eauto.
  Qed.

  Lemma Tr_NoDup t
        (Htr : Tr t)
    : NoDup t.
  Proof.
    destruct t;[inversion Htr|].
    destruct (c) eqn:E. destruct c0 eqn:E'.
    eapply Tr_EPath in Htr. destructH.
    - eapply EPath_TPath in Htr. eapply tpath_NoDup in Htr. eapply NoDup_map_inv. eauto.
    - cbn. reflexivity.
  Qed.

  Lemma precedes_prefix l' p q i j r s (t : list Conf)
        (Hprec : Precedes' t (q,j,r) (p,i,s))
        (Hpre  : Prefix l' t)
        (Hin : (p,i,s) ∈ l')
        (Htr : Tr t)
    : Precedes' l' (q,j,r) (p,i,s).
  Proof.
    unfold Precedes' in *.
    destructH. exists l'0. split;eauto.
    eapply prefix_trans_NoDup;eauto.
    eapply Tr_NoDup;eauto.
  Qed.

  Lemma unch_concr'_pre unch t l
        (HCunch : unch_concr unch t)
        (Hpre : Prefix l (`t))
    : unch_concr' unch l.
  Proof.
    unfold unch_concr,unch_concr' in *.
    intros. specialize (HCunch to i s u x). exploit HCunch; [eapply prefix_incl;eauto|].
    destructH. eexists; eexists; split; [|eauto].
    eapply precedes_prefix;eauto. destruct t; cbn; eauto.
  Qed.

  (** ** Dominance **)

  Definition path := { π : list Lab | exists e, Path edge__P root e π }.
  Definition Paths := path -> Prop.

  Definition unch_concr_dom (unch : Unch) (π : path) :=
    forall (to : Lab) (u : Lab) (x : Var),
      u ∈ unch to x ->
      to ∈ `π ->
      u ∈ `π.

  Definition sem_path (ps : Paths) : Paths :=
    fun π' => exists l π, ps π /\ `π' = (l :: `π).

  Lemma pred_in_path (π : path) (π' : path) l to
        (Hpath : `π = l :: `π')
        (Hin : to ∈ `π)
        (Hnoroot : to <> root)
    : exists pred, pred ∈ preds to /\ pred ∈ `π'.
  Proof.
    unfold path in π.
    destruct π as [ π [ e He ] ].
    simpl in *.
    eapply path_to_elem with (r := to) in He; try assumption.
    destruct He as [ϕ [Hp Hprefix]].
    clear Hin e.
    inversion Hp; subst.
    - firstorder eauto with *.
    - exists b. split.
      + unfold preds. rewrite in_filter_iff. split.
        * eauto.
        * simpl. rewrite H0. trivial.
      + eapply path_contains_front in H.
        dependent destruction Hprefix.
        * assumption.
        * eapply prefix_incl in Hprefix. eapply Hprefix. right. assumption.
  Qed.

  Lemma preds_root_nil
    : preds root = [].
  Proof.
    unfold preds.
    induction (elem Lab); simpl; [ reflexivity |].
    decide (if edge a root then True else False) as [H|H]; [|assumption].
    - destruct (edge a root) eqn:Hedge; [|tauto].
      exfalso. eapply root_no_pred. eassumption.
  Qed.

  Lemma unch_correct_dom :
        forall unch π, sem_path (unch_concr_dom unch) π -> unch_concr_dom (unch_trans unch) π.
  Proof.
    intros.
    unfold sem_path in H.
    unfold unch_concr_dom.
    intros to u x Hunch Htoin.
    destruct H as [l [π' [Hconcr Heq]]].
    unfold unch_trans, unch_trans_ptw in Hunch.
    unfold unch_concr_dom in Hconcr.

    destruct (Lab_dec' to root). {
      subst to. rewrite preds_root_nil in Hunch. simpl in Hunch.
      inject Hunch; [ assumption | inject H ].
    }

    assert (Hpred : exists pred, pred ∈ preds to /\ pred ∈ `π'). {
      eapply pred_in_path; try eassumption.
    }

    destruct Hpred as [pred [Hpred Hpredin]].
    induction (preds to) as [ | p ps ]; simpl in Hunch.
    - contradiction Hpred.
    - eapply set_inter_elim in Hunch.
      destruct (Lab_dec' pred p).
      + subst. clear Hpred.
        destruct Hunch as [Hunch _]. clear IHps.
        unfold unch_trans_local in Hunch.
        unfold path in π'.
        eapply set_add_elim in Hunch.
        inversion_clear Hunch.
        * subst. eassumption.
        * destruct (is_def x p to); [ firstorder |].
          rewrite Heq. right. eauto.
      + destruct Hunch as [_ Hunch].
        inversion Hpred; [ subst; tauto |].
        destruct ps; [ inject H | eapply IHps; try eassumption ].
  Qed.

  Lemma unch_concr_dom_monotone unch2 unch1
    (Hless : forall p x, unch2 p x ⊆ unch1 p x)
    : forall π, unch_concr_dom unch1 π -> unch_concr_dom unch2 π.
  Proof.
    intros.
    unfold unch_concr_dom in *.
    intros to u x Hunch Hinto.
    unfold incl in Hless.
    eauto.
  Qed.

  Lemma path_begin_no_preds π p
        (Hπ : Path edge__P root p π)
    : preds (last π root) = [].
  Proof.
    dependent induction π.
    - simpl. eapply preds_root_nil.
    - enough (a = p).
      + subst. simpl.
        destruct π.
        * enough (Heq : forall a b, Path edge__P a b [b] -> a = b).
          -- apply Heq in Hπ. subst p. eapply preds_root_nil.
          -- intros. inversion H; [ reflexivity |].
             subst. inversion H1.
        * inversion Hπ. eapply IHπ. eapply H0.
      + symmetry. eapply path_front. eassumption.
  Qed.

  Lemma unch_postfix_implies_dom unch p x u
        (Hfix: forall p x, unch p x ⊆ unch_trans unch p x)
    : u ∈ unch p x -> Dom edge__P root u p.
  Proof.
    unfold Dom.
    intros Hunch π Hπ.
    specialize (path_begin_no_preds Hπ); intros Hpred.
    induction Hπ.
    - simpl in Hpred. eapply Hfix in Hunch.
      unfold unch_trans, unch_trans_ptw in Hunch.
      rewrite Hpred in Hunch. simpl in Hunch; inject Hunch; intuition.
    - subst. eapply Hfix in Hunch.
      unfold unch_trans, unch_trans_ptw in Hunch.
      assert (Hin : b ∈ preds c). {
        unfold preds.
        eapply in_filter_iff. simpl. rewrite H. intuition.
      }
      induction (preds c) as [| p ps]; [ inject Hin | ].
      simpl in Hunch.
      eapply set_inter_elim in Hunch.
      destruct Hunch as [Hlocal Hother].
      unfold unch_trans_local in Hlocal.
      destruct Hin.
      * subst p.
        destruct (is_def x b c).
        -- simpl in Hlocal. inject Hlocal; intuition.
        -- eapply set_add_elim in Hlocal. inject Hlocal; [ intuition |].
           right. eapply IHHπ. assumption. simpl in Hpred.
           inversion Hπ; subst; assumption.
      * eapply IHps; try eassumption.
        destruct ps; [ contradiction | eassumption].
  Qed.

  (** ** Correctness **)

  Lemma unch_correct :
    forall unch t,
      sem_trace (unch_concr unch) t -> unch_concr (unch_trans unch) t.
  Proof.
    intros unch t Hred.
    unfold sem_trace in Hred.
    destruct Hred as [t' [k' [Hred H]]].
    unfold unch_concr in *.
    intros to i s u x.
    intros Hin Hunch.
    destruct (Lab_dec' to root); subst.
    - unfold unch_trans, unch_trans_ptw in Hunch. destruct (Lab_dec' root root); [ | firstorder ].
      simpl in Hunch. rewrite preds_root_nil in Hunch. destruct Hunch; [ subst | firstorder ].
      exists i, s. split; eauto. exists nil. split; [|econstructor].
      apply root_start_tag in Hin as rst. subst i.
      assert (rp := root_prefix t). destruct rp as [s' rp].
      apply prefix_cons_in in rp as rp'. eapply tag_inj with (s0:=s) in rp'.
      subst s'. 1,2:assumption.
    - assert (Hpred := Hin).
      rewrite H in Hpred.
      eapply in_exists_pred in Hpred; try eassumption.
      + destruct Hpred as [q [j [r [Hpredin Hpred]]]].
        assert (Hedge: q --> to) by (eauto using step_conf_implies_edge).
        eapply unch_trans_lem in Hunch; try eassumption.
        destruct (Lab_dec to u) as [ | Hneq ]; subst.
        * exists i, s. split; [ | reflexivity ]. rewrite <-e. eapply precedes_self;eauto.
        * destruct Hunch; [ firstorder eauto with * |].
          setoid_rewrite in_preds in H0.
          eapply H0 in Hedge. destruct Hedge as [Hndef Huin].
          edestruct Hred as [j' [r' [Hprec Heq]]]; eauto.
          exists j', r'. rewrite Heq.
          split; [|eauto using no_def_untouched]. rewrite H. eapply precedes_succ; eauto.
          rewrite <-H. destruct t; eauto.
      + clear - H. destruct t; cbn in H; inversion t; subst x.
        * destruct t' as [t' Ht]. destruct t';[inversion Ht|]. cbn in *.
          inversion t. subst. eauto.
        * inversion H2. subst; eauto.
  Qed.
End unch.


(* Construction of a PDM for a free monad *)

From Coq Require Import Utf8 RelationClasses.
From PDM Require Import util structures guarded PURE PDM.

Set Default Goal Selector "!".
Set Printing Projections.
Set Universe Polymorphism.
Unset Universe Minimization ToSet.

Section Free.

  Context (action : Type).
  Context (dom : action → Type) (cod : ∀ a (x : dom a), Type).

  Inductive M (A : Type) :=
  | retᴹ (x : A)
  | actᴹ (a : action) (v : dom a) (k : cod a v → M A)
  | reqᴹ (p : Prop) (k : p → M A).

  Arguments retᴹ [_].
  Arguments actᴹ [_].
  Arguments reqᴹ [_].

  Fixpoint bindᴹ [A B] (c : M A) (f : A → M B) : M B :=
    match c with
    | retᴹ x => f x
    | actᴹ a v k => actᴹ a v (λ x, bindᴹ (k x) f)
    | reqᴹ p k => reqᴹ p (λ x, bindᴹ (k x) f)
    end.

  Instance Monad_M : Monad M := {|
    ret := retᴹ ;
    bind := bindᴹ
  |}.

  Instance ReqMonad_M : ReqMonad M := {|
    req p := reqᴹ p (λ h, retᴹ h)
  |}.

  (* For the specification monad, we take any one that has assertions.
    Given that it is easy to construct for those we are interested in in
    practice this is feature. The user will want to choose the shape of the
    specification monad.

    That said, this ends up being a lot of requirements on W, it would be good
    to package them and maybe see if we should always define reqᵂ in terms of
    liftᵂ.
  *)

  Context {W} `{ReqMonad W} {Word : Order W} (hmono : MonoSpec W).
  Context {Wlaws : MonadLaws W}.
  Context (actionᵂ : ∀ (a : action) (v : dom a), W (cod a v)).

  Fixpoint θ [A] (c : M A) : W A :=
    match c with
    | retᴹ x => ret x
    | actᴹ a v k => bind (actionᵂ a v) (λ x, θ (k x))
    | reqᴹ p k => bind (req p) (λ x, θ (k x))
    end.

  Context {hr : ∀ A, Reflexive (wle (A := A))}.

  Instance θ_lax : LaxMorphism θ.
  Proof.
    constructor.
    - intros A x.
      cbn. reflexivity.
    - intros A B c f.
      induction c as [| ??? ih | ?? ih] in B, f |- *.
      + cbn. rewrite structures.left_id. reflexivity.
      + cbn. rewrite structures.assoc.
        apply bind_mono. 1: reflexivity.
        intro x. apply ih.
      + cbn. rewrite structures.assoc.
        apply bind_mono. 1: reflexivity.
        intro x. apply ih.
  Qed.

  Instance θ_reqlax : ReqLaxMorphism _ θ.
  Proof.
    constructor.
    intros p. cbn.
    rewrite structures.right_id. reflexivity.
  Qed.

  Definition D A w : Type :=
    PDM.D (θ := θ) A w.

  Instance DijkstraMonad_D : DijkstraMonad D :=
    PDM.DijkstraMonad_D hmono θ_lax.

  (* Lift from PURE *)

  Context (liftᵂ : spec_lift_pure W).
  Context (hlift : PureSpec W Word liftᵂ).

  Definition liftᴾ :=
    liftᴾ (M := M) (W := W) hmono θ_lax θ_reqlax hlift.

  (* TODO missing actions *)

End Free.