From Coq Require Import ssreflect ssrfun ssrbool.

From Coq Require Import Strings.String.
From Coq Require Import Logic.PropExtensionality Logic.Eqdep_dec.
From Equations Require Import Equations.

From stdpp Require Export base gmap fin_sets sets list countable.
From MatchingLogic Require Import Syntax Semantics StringSignature ProofSystem ProofMode.MLPM.
From MatchingLogicProver Require Import Named NamedProofSystem NMatchers.

From stdpp Require Import base finite gmap mapset listset_nodup numbers propset list.

(* TODO: move this near to the definition of Pattern *)
Derive NoConfusion for Pattern.
Derive Subterm for Pattern.

Ltac invert_tuples :=
  repeat (match goal with
          | [H: (?x1,?y1)=(?x2,?y2) |- _] => inversion H; clear H; subst
          end).

Ltac do_rewrites_everywhere :=
  repeat (match goal with
  | [H: ?l = ?r , H' : _ |- _] => rewrite H in H'; simpl in H'
  end).

Ltac case_match_in_hyp H :=
  lazymatch type of H with
  | context [ match ?x with _ => _ end ] => destruct x eqn:?
  end.

(* In an empty context, this rewrites: *)
(* ∃ (x.x) /\ (∃ y.y) ~> (∃ x.x) /\ (∃ x.x) *)
(* But in some other context C, it might rewrite *)
(* C[∃ (x.x) /\ (∃ y.y)] ~> C[(∃ z.z) /\ (∃ z.z)] *)
(* because we might see some ∃ z.z in the context C. *)

(* TODO we have to implement the two-phase approach to proof system translation.
   The cache-based on was too complicated, so I removed the proofs from this file.
*)
(*
Record AlphaConversion {Σ : Signature} :=
  {
    ac_list : list evar ;
  }.

Definition AlphaConversion_valid {Σ : Signature}
  (ac : AlphaConversion) (nϕ : NamedPattern)
  := (ac_list ac) ## elements (named_free_evars nϕ).

Print NamedPattern.
*)

(*
Definition head_or_id {Σ : Signature}
  (l : list evar) (p : NamedPattern) : NamedPattern
  match l with
  | [] => p
  | (x::xs) =>
*)

Fixpoint number_of_exists
  {Σ : Signature} (ϕ : NamedPattern) : nat :=
  match ϕ with
  | npatt_app phi1 phi2
    => number_of_exists phi1 + number_of_exists phi2
  | npatt_imp phi1 phi2
    => number_of_exists phi1 + number_of_exists phi2
  | npatt_exists _ phi
    => S (number_of_exists phi)
  | npatt_mu _ phi
    => number_of_exists phi
  | _ => 0
  end.

  Fixpoint number_of_mus
  {Σ : Signature} (ϕ : NamedPattern) : nat :=
  match ϕ with
  | npatt_app phi1 phi2
    => number_of_mus phi1 + number_of_mus phi2
  | npatt_imp phi1 phi2
    => number_of_mus phi1 + number_of_mus phi2
  | npatt_exists _ phi
    => (number_of_mus phi)
  | npatt_mu _ phi
    => S ( number_of_mus phi)
  | _ => 0
  end.

Fixpoint rename {Σ : Signature}
  (bevs : list evar)
  (bsvs : list svar)
  (fevs : gmap evar evar)
  (fsvs : gmap svar svar)
  (nϕ : NamedPattern)
  : NamedPattern :=
  match nϕ with
  | npatt_evar x
    => match (fevs !! x) with
       | None => npatt_evar x
       | Some y => npatt_evar y
       end
  | npatt_svar X
       => match (fsvs !! X) with
          | None => npatt_svar X
          | Some Y => npatt_svar Y
          end
  | npatt_sym s => npatt_sym s
  | npatt_bott => npatt_bott
  | npatt_imp phi1 phi2 =>
    npatt_imp
      (rename bevs bsvs fevs fsvs phi1)
      (rename (drop (number_of_exists phi1) bevs)
              (drop (number_of_mus phi1) bsvs)
              fevs fsvs phi2)
  | npatt_app phi1 phi2 =>
    npatt_app
      (rename bevs bsvs fevs fsvs phi1)
      (rename (drop (number_of_exists phi1) bevs)
      (drop (number_of_exists phi1) bsvs)
              fevs fsvs phi2)
  | npatt_exists x phi =>
    match bevs with
    | [] => npatt_exists x phi
    | (y::ys)
      => npatt_exists y
          (rename ys bsvs (<[x:=y]>fevs) fsvs phi)
    end
  | npatt_mu X phi =>
    match bsvs with
    | [] => npatt_mu X phi
    | (Y::Ys)
      => npatt_mu Y
          (rename bevs Ys fevs (<[X:=Y]>fsvs) phi)
    end
  end.

  Record PartialBijection (A : Type)
    {_eqd : EqDecision A}
    {_cnt : Countable A}
     :=
  mkPartialBijection
  {
    pbr : gset (prod A A) ;
    pb1 : forall (x y1 y2 : A),
      (x,y1) ∈ pbr -> (x,y2) ∈ pbr -> y1 = y2 ;
    pb2 : forall (x1 x2 y : A),
      (x1,y) ∈ pbr -> (x2,y) ∈ pbr -> x1 = x2 ;
  }.

  Lemma pb_eq_dep (A : Type)
    {_eqd : EqDecision A}
    {_cnt : Countable A}
    (s s' : gset (prod A A))
    pf1 pf1' pf2 pf2'
    : s = s' ->
      @mkPartialBijection A _eqd _cnt s pf1 pf2 = @mkPartialBijection A _eqd _cnt s' pf1' pf2'.
    Proof.
      intros H.
      subst s'.
      f_equal; apply proof_irrelevance.
    Qed.

  Arguments pbr {A%type_scope} {_eqd _cnt} p.

  Definition myswap {A : Type} (p : prod A A) : prod A A := (p.2, p.1).

  Program Definition pbr_converse {A : Type}
    {_eqd : EqDecision A}
    {_cnt : Countable A}
    (R : PartialBijection A) : PartialBijection A
  := {|
    pbr := (set_map myswap (pbr R))  ;
  |}.
  Next Obligation.
    intros ??????? H1 H2.
    rewrite elem_of_map in H1.
    rewrite elem_of_map in H2.
    destruct H1 as [[x11 x12] [H11 H12] ].
    destruct H2 as [[x21 x22] [H21 H22] ].
    simpl in *.
    inversion H11; clear H11; inversion H21; clear H21; subst.
    destruct R as [r pf1 pf2]; simpl in *.
    naive_solver.
  Qed.
  Next Obligation.
    intros ??????? H1 H2.
    rewrite elem_of_map in H1.
    rewrite elem_of_map in H2.
    destruct H1 as [[x11 x12] [H11 H12] ].
    destruct H2 as [[x21 x22] [H21 H22] ].
    simpl in *.
    inversion H11; clear H11; inversion H21; clear H21; subst.
    destruct R as [r pf1 pf2]; simpl in *.
    naive_solver.
  Qed.

  Lemma pbr_converse_sym (A : Type)
    {_eqd : EqDecision A}
    {_cnt : Countable A}
    (R : PartialBijection A)
    : forall (x y : A), ((x,y) ∈ (pbr (pbr_converse R))) <-> ((y,x) ∈ (pbr R)).
  Proof.
    intros x y.
    destruct R as [r pf1 pf2]; simpl.
    rewrite elem_of_map.
    unfold myswap.
    split; intros H.
    {
      destruct H as [[a1 a2] [H1 H2] ].
      simpl in *.
      naive_solver.
    }
    {
      exists (y,x).
      split;[reflexivity|assumption].
    }
  Qed.

  Definition related {A : Type} (u v : prod A A) : Prop
  := u.1 = v.1 \/ u.2 = v.2.

  Definition unrelated {A : Type} (u v : prod A A) : Prop
  := ~ (related u v).

  #[global]
  Instance related_dec (A : Type)
    {eq_dec : EqDecision A}
  : RelDecision (@unrelated A).
  Proof.
    solve_decision.
  Defined.

  Program Definition pb_update
  {A : Type}
  {_eqd : EqDecision A}
  {_cnt : Countable A}
  (pb : PartialBijection A)
  (x y : A)
  : PartialBijection A := {|
    pbr := (filter (unrelated (x,y)) (pbr pb) ) ∪ {[ (x,y) ]} ;
  |}.
  Next Obligation.
    intros ???? ????? H1 H2.
    rewrite elem_of_union in H1.
    rewrite elem_of_union in H2.
    rewrite elem_of_singleton in H1.
    rewrite elem_of_singleton in H2.
    rewrite elem_of_filter in H1.
    rewrite elem_of_filter in H2.
    destruct pb.
    unfold unrelated,related in *.
    simpl in *.
    naive_solver.
  Qed.
 Next Obligation.
  intros ???? ????? H1 H2.
  rewrite elem_of_union in H1.
  rewrite elem_of_union in H2.
  rewrite elem_of_singleton in H1.
  rewrite elem_of_singleton in H2.
  rewrite elem_of_filter in H1.
  rewrite elem_of_filter in H2.
  destruct pb.
  unfold unrelated,related in *.
  simpl in *.
  naive_solver.
 Qed.

 Lemma pbr_update_converse
  {A : Type}
  {_eqd : EqDecision A}
  {_cnt : Countable A}
  (R : PartialBijection A)
  : forall x y, pbr_converse (pb_update R x y) = pb_update (pbr_converse R) y x.
  Proof.
    intros x y.
    destruct R as [r pf1 pf2]; simpl in *.
    unfold pb_update,pbr_converse; simpl.
    apply pb_eq_dep.
    rewrite set_map_union_L.
    rewrite set_map_singleton_L.
    simpl.

    cut ((@set_map (A * A) (gset (A * A)) _ (A * A) (gset (A * A)) _ _ _ myswap (filter (unrelated (x, y)) r)) = (filter (unrelated (y, x)) (set_map myswap r))).
    {
      intros H. rewrite H. reflexivity.
    }
    apply anti_symm with (S := @subseteq (gset (prod A A)) _).
    { apply _. }
    1,2: rewrite elem_of_subseteq; intros x0 Hx0.
    {
      rewrite elem_of_map in Hx0.
      destruct Hx0 as [[x' y'] [Hx'y'1 Hx'y'2] ].
      rewrite elem_of_filter in Hx'y'2.
      rewrite elem_of_filter.
      rewrite elem_of_map.
      unfold unrelated,related,myswap in *.
      simpl in *.
      subst.
      naive_solver.
    }
    {
      rewrite elem_of_filter in Hx0.
      rewrite elem_of_map in Hx0.
      rewrite elem_of_map.
      unfold unrelated,related,myswap in *.
      simpl in *.
      exists (x0.2, x0.1). simpl.
      rewrite -surjective_pairing.
      rewrite elem_of_filter. simpl.
      naive_solver.
    }
  Qed.

  Inductive alpha_equiv'
    {Σ : Signature}
    (R : PartialBijection evar)
    (R' : PartialBijection svar)
    : relation NamedPattern
    :=
    | ae_evar (x y : evar) (pf : (x, y) ∈ (pbr R))
      : alpha_equiv' R R' (npatt_evar x) (npatt_evar y)
    | ae_svar (X Y : svar) (pf : (X, Y) ∈ (pbr R'))
      : alpha_equiv' R R' (npatt_svar X) (npatt_svar Y)
    | ae_app
      (t t' u u' : NamedPattern)
      (tEt' : alpha_equiv' R R' t t')
      (uEu' : alpha_equiv' R R' u u')
      : alpha_equiv' R R' (npatt_app t u) (npatt_app t' u')
    | ae_imp
      (t t' u u' : NamedPattern)
      (tEt' : alpha_equiv' R R' t t')
      (uEu' : alpha_equiv' R R' u u')
      : alpha_equiv' R R' (npatt_imp t u) (npatt_imp t' u')
    | ae_bott : alpha_equiv' R R' npatt_bott npatt_bott
    | ae_sym (s : symbols) : alpha_equiv' R R' (npatt_sym s) (npatt_sym s)
    | ae_ex (x y : evar) (t u : NamedPattern)
      (tEu : alpha_equiv'
        (pb_update R x y) R' t u)
      : alpha_equiv' R R'
        (npatt_exists x t)
        (npatt_exists y u)
    | ae_mu (X Y : svar) (t u : NamedPattern)
      (tEu : alpha_equiv'
        R (pb_update R' X Y) t u)
      : alpha_equiv' R R'
        (npatt_mu X t)
        (npatt_mu Y u)
  .

  #[global]
  Instance myswap_involutive
    (A : Type) :
    Involutive (=) (@myswap A).
  Proof.
    unfold Involutive.
    intros p.
    destruct p.
    unfold myswap.
    reflexivity.
  Qed.

  #[global]
  Instance myswap_inj (A : Type) : Inj (=) (=) (@myswap A).
  Proof.
    intros p1 p2 Hp1p2.
    unfold myswap in Hp1p2.
    destruct p1,p2.
    simpl in *.
    inversion Hp1p2.
    subst.
    reflexivity.
  Qed.

  Check @set_map.

  #[global]
  Instance set_map_involutive (A C : Type)
    {_eoAC : ElemOf A C}
    {_eleAC : Elements A C}
    {_singAC : Singleton A C}
    {_emptyC : Empty C}
    {_uniC : Union C}
    {_interC : Intersection C}
    {_difC : Difference C}
    {_eqdecA : EqDecision A}
    {_finac : FinSet A C}
    (f : A -> A)
    {_injF : Inj (=) (=) f}
    {_invF : Involutive (=) f}
    {_lC : LeibnizEquiv C}
    :
    Involutive (=) (@set_map A C _eleAC A C _singAC _emptyC _uniC f).
  Proof.
    intros x.
    unfold set_map.
    Search list_to_set elements.
    rewrite -[x in _ = x]list_to_set_elements_L.
    rewrite elements_list_to_set.
    {
      rewrite NoDup_fmap.
      apply NoDup_elements.
    }
    rewrite -list_fmap_compose.
    unfold compose.
    under [fun x0 => _]functional_extensionality => x0.
    {
      rewrite _invF.
      over.
    }
    fold (@Coq.Init.Datatypes.id A).
    rewrite list_fmap_id.
    reflexivity.
  Qed.

  #[global]
  Instance pbr_converse_involutive
    (A : Type)
    {_eqd : EqDecision A}
    {_cnt : Countable A}
     : Involutive (=) (@pbr_converse A _eqd _cnt).
  Proof.
    unfold Involutive.
    intros R.
    destruct R.
    apply pb_eq_dep.
    simpl.
    rewrite cancel.
    reflexivity.
  Qed.

  Lemma alpha_equiv_converse'
    {Σ : Signature}
    (R : PartialBijection evar)
    (R' : PartialBijection svar)
    : forall x y,
      alpha_equiv' R R' x y ->
      alpha_equiv' (pbr_converse R) (pbr_converse R') y x.
  Proof.
    intros x y H.
    induction H; try (solve [constructor; auto]).
      { constructor. rewrite pbr_converse_sym; assumption. }
      { constructor. rewrite pbr_converse_sym; assumption. }
      { constructor. rewrite pbr_update_converse in IHalpha_equiv'. assumption. }
      { constructor. rewrite pbr_update_converse in IHalpha_equiv'. assumption. }
  Qed.

  Lemma alpha'_sym
    {Σ : Signature}
    (R : PartialBijection evar)
    (R' : PartialBijection svar)
    : forall x y,
      alpha_equiv' R R' x y <->
      alpha_equiv' (pbr_converse R) (pbr_converse R') y x.
  Proof.
    intros x y; split; intros H.
    {
      apply alpha_equiv_converse'.
      apply H.
    }
    {
      rewrite -[R](@cancel (PartialBijection evar) _ eq (@pbr_converse evar _ _)).
      rewrite -[R'](@cancel (PartialBijection svar) _ eq (@pbr_converse svar _ _)).
      apply alpha_equiv_converse'.
      apply H.
    }
  Qed.

  #[global]
  Instance alpha'_dec
    {Σ : Signature}
    (R : PartialBijection evar)
    (R' : PartialBijection svar)
    : RelDecision (alpha_equiv' R R').
  Proof.
    unfold RelDecision.
    intros x y.
    unfold Decision.
    move: R R' y.
    (*remember (size' x) as szx.*)
    induction x; intros R R' y; destruct y; try (solve [repeat constructor]);
      try (solve [right; intros HH; inversion HH]).
    {
      destruct (decide ((x, x0) ∈ pbr R)).
      {
        left. constructor. assumption.
      }
      {
        right. intros HContra. inversion HContra.
        contradiction.
      }
    }
    {
      destruct (decide ((X, X0) ∈ pbr R')).
      {
        left. constructor. assumption.
      }
      {
        right. intros HContra. inversion HContra.
        contradiction.
      }
    }
    {
      destruct (decide (sigma = sigma0)).
      {
        left. subst. constructor.
      }
      {
        right. intros HContra. inversion HContra.
        contradiction.
      }
    }
    {
      specialize (IHx1 R R' y1).
      specialize (IHx2 R R' y2).
      destruct IHx1, IHx2.
      {
        left. constructor; assumption.
      }
      all: right; intros HContra; inversion HContra; contradiction.
    }
    {
      specialize (IHx1 R R' y1).
      specialize (IHx2 R R' y2).
      destruct IHx1, IHx2.
      {
        left. constructor; assumption.
      }
      all: right; intros HContra; inversion HContra; contradiction.
    }
    {
      pose proof (IH' := IHx (pb_update R x x1) R' y).
      destruct IH'.
      {
        left. constructor. assumption.
      }
      {
        right. intros HContra. inversion HContra. clear HContra.
        subst.
        contradiction.
      }
    }
    {
      pose proof (IH' := IHx R (pb_update R' X X0) y).
      destruct IH'.
      {
        left. constructor. assumption.
      }
      {
        right. intros HContra. inversion HContra. clear HContra.
        subst.
        contradiction.
      }
    }
  Defined.

  Definition twice {A : Type} (x : A) : prod A A := (x, x).

  #[global]
  Instance twice_inj {A : Type} : Inj (=) (=) (@twice A).
  Proof.
    intros x y H.
    inversion H.
    reflexivity.
  Qed.

  Program Definition diagonal
    {A : Type}
    {_eqd : EqDecision A}
    {_cnt : Countable A}
    (S : gset A)
     : PartialBijection A :=
    {|
      pbr := set_map twice S ;
    |}.
  Next Obligation.
    intros ??????? H1 H2.
    rewrite elem_of_map in H1.
    rewrite elem_of_map in H2.
    destruct H1 as [w1 [Hw1 H'w1] ].
    destruct H2 as [w2 [Hw2 H'w2] ].
    inversion Hw1; clear Hw1; subst.
    inversion Hw2; clear Hw2; subst.
    reflexivity.
  Qed.
  Next Obligation.
    intros ??????? H1 H2.
    rewrite elem_of_map in H1.
    rewrite elem_of_map in H2.
    destruct H1 as [w1 [Hw1 H'w1] ].
    destruct H2 as [w2 [Hw2 H'w2] ].
    inversion Hw1; clear Hw1; subst.
    inversion Hw2; clear Hw2; subst.
    reflexivity.
  Qed.

  Definition alpha_equiv {Σ : Signature} (phi psi : NamedPattern) : Prop :=
    alpha_equiv'
      (diagonal (named_free_evars phi ∪ named_free_evars psi))
      (diagonal (named_free_svars phi ∪ named_free_svars psi))
      phi psi
  .

  #[global]
  Instance alpha_dec
    {Σ : Signature}
    : RelDecision alpha_equiv.
  Proof.
    intros x y.
    apply alpha'_dec.
  Defined.

  Lemma myswap_twice (A : Type) : myswap ∘ (@twice A) = twice.
  Proof.
    apply functional_extensionality.
    intros x. reflexivity.
  Qed.

  Lemma pbr_converse_diagonal (A : Type) {_eqd : EqDecision A} {_cnt : Countable A} (S : gset A):
    pbr_converse (diagonal S) = diagonal S.
  Proof.
    unfold diagonal,pbr_converse.
    apply pb_eq_dep.
    simpl.
    unfold set_map.
    apply anti_symm with (S := @subseteq (gset (prod A A)) _).
    { apply _. }
    1,2: rewrite elem_of_subseteq; intros x Hx.
    {
      rewrite elem_of_list_to_set in Hx.
      rewrite elem_of_list_to_set.
      rewrite elements_list_to_set in Hx.
      { apply NoDup_fmap.
        { apply _. }
        { apply NoDup_elements. }
      }
      rewrite -list_fmap_compose in Hx.
      rewrite myswap_twice in Hx.
      exact Hx.
    }
    {
      rewrite elem_of_list_to_set.
      rewrite elem_of_list_to_set in Hx.
      rewrite elements_list_to_set.
      { apply NoDup_fmap.
        { apply _. }
        { apply NoDup_elements. }
      }
      rewrite -list_fmap_compose.
      rewrite myswap_twice.
      exact Hx.
    }
  Qed.

  Lemma alpha_equiv_sym
  {Σ : Signature}
  : forall x y,
    alpha_equiv x y <->
    alpha_equiv y x.
  Proof.
    intros x y.
    unfold alpha_equiv.
    rewrite alpha'_sym.
    rewrite !pbr_converse_diagonal.
    rewrite [named_free_evars y ∪ named_free_evars x]union_comm_L.
    rewrite [named_free_svars y ∪ named_free_svars x]union_comm_L.
    apply reflexivity.
  Qed.

  Lemma alpha_equiv_refl {Σ : Signature} :
    forall p, alpha_equiv p p.
  Proof.
    intros p.
    unfold alpha_equiv.
    do 2 rewrite union_idemp_L.
    cut (forall R R', pbr (diagonal (named_free_evars p)) ⊆ (pbr R) ->
      pbr (diagonal (named_free_svars p)) ⊆ (pbr R')
     -> alpha_equiv' R R' p p).
    {
      intros H. apply H; apply reflexivity.
    }

    induction p; intros H1 H2; constructor; try set_solver.
    {
      simpl in *.
      apply IHp.
      {
        simpl in *.
        rewrite elem_of_subseteq.
        intros x0 Hx0.
        rewrite elem_of_map in Hx0.
        destruct Hx0 as [x' [Hx'1 Hx'2] ].
        subst.
        rewrite elem_of_union.
        rewrite elem_of_singleton.
        unfold twice.
        destruct (decide (x = x')).
        {
          subst. right. reflexivity.
        }
        {
          left.
          rewrite elem_of_filter.
          unfold unrelated,related.
          simpl.
          set_solver.
        }
      }
      {
        assumption.
      }
    }
    {
      apply IHp.
      {
        assumption.
      }
      {
        simpl in *.
        rewrite elem_of_subseteq.
        intros [X1 X2] HX1X2.
        rewrite elem_of_map in HX1X2.
        destruct HX1X2 as [X3 [HX3 HX4] ].
        unfold twice in *.
        simpl in *.
        inversion HX3. clear HX3. subst.
        rewrite elem_of_union.
        destruct (decide (X3 = X)).
        {
          subst. right. rewrite elem_of_singleton. reflexivity.
        }
        {
          left.
          rewrite elem_of_filter.
          unfold unrelated,related.
          simpl.
          set_solver.
        }
      }
    }
  Qed.

  Fixpoint npfoldtopdown {Σ : Signature} {State : Type}
    (f : State -> NamedPattern -> State)
    (state : State) (nϕ : NamedPattern)
    : (State)%type
  :=
    match nϕ with
    | npatt_evar x => f state (npatt_evar x)
    | npatt_svar X => f state (npatt_svar X)
    | npatt_sym s => f state (npatt_sym s)
    | npatt_bott => f state npatt_bott
    | npatt_imp nϕ1 nϕ2 =>
      let state' := f state (npatt_imp nϕ1 nϕ2) in
      let state'' := npfoldtopdown f state' nϕ1 in
      let state''' := npfoldtopdown f state' nϕ2 in
      state'''
    | npatt_app nϕ1 nϕ2 =>
      let state' := f state (npatt_app nϕ1 nϕ2) in
      let state'' := npfoldtopdown f state' nϕ1 in
      let state''' := npfoldtopdown f state' nϕ2 in
      state'''
    | npatt_exists x nϕ' =>
      let state' := f state (npatt_exists x nϕ') in
      let state'' := npfoldtopdown f state' nϕ' in
      state''
    | npatt_mu X nϕ' =>
      let state' := f state (npatt_mu X nϕ') in
      let state'' := npfoldtopdown f state' nϕ' in
      state''
    end.

  Record CollapseState {Σ : Signature} := mkCollapseState {
    cs_history : list NamedPattern;
  }.

  Definition lookup_or
    {Σ : Signature}
    (state : CollapseState)
    (nϕ : NamedPattern)
    (owise : (CollapseState * NamedPattern)%type)
    : (CollapseState * NamedPattern)%type
    := match (list_find (alpha_equiv nϕ) (cs_history state)) with
    | Some (_, nϕ') => (state, nϕ')
    | None => owise
    end.

  Definition lookup_or_node
    {Σ : Signature}
    (state : CollapseState)
    (nϕ : NamedPattern)
    (owise : (CollapseState * NamedPattern)%type)
    : (CollapseState * NamedPattern)%type
    := lookup_or state nϕ (mkCollapseState Σ ((owise.2)::(cs_history owise.1)), (owise.2)).

  Definition lookup_or_leaf
    {Σ : Signature}
    (state : CollapseState)
    (nϕ : NamedPattern)
    : (CollapseState * NamedPattern)%type
    := lookup_or_node state nϕ (state, nϕ).

  Program Fixpoint collapse_aux
    {Σ : Signature}
    (state : CollapseState)
    (nϕ : NamedPattern)
    : (CollapseState * NamedPattern)%type
  :=
    match nϕ with
    | npatt_evar x
      => lookup_or_leaf state nϕ
    | npatt_svar X
      => lookup_or_leaf state nϕ
    | npatt_bott
      => lookup_or_leaf state nϕ
    | npatt_sym s
      => lookup_or_leaf state nϕ
    | npatt_imp nϕ1 nϕ2
      => lookup_or_node state nϕ
        ( let res := collapse_aux state nϕ1 in
          let res' := collapse_aux (res.1) nϕ2 in
          (res'.1, (npatt_imp res.2 res'.2))
        )
    | npatt_app nϕ1 nϕ2
        => lookup_or_node state nϕ
          ( let res := collapse_aux state nϕ1 in
            let res' := collapse_aux (res.1) nϕ2 in
            (res'.1, (npatt_app res.2 res'.2))
          )
    | npatt_exists x nϕ'
      => lookup_or_node state nϕ
        (
          let res := collapse_aux state nϕ' in
          (res.1, (npatt_exists x res.2))
        )
    | npatt_mu X nϕ'
        => lookup_or_node state nϕ
          (
            let res := collapse_aux state nϕ' in
            (res.1, (npatt_mu X res.2))
          )
    end.

    (* (exists x. x) ---> (exists y. (y ---> exists z. z)) *)

    Lemma lookup_or_leaf_alpha
      {Σ : Signature}
      (state : CollapseState)
      (nϕ : NamedPattern)
      : alpha_equiv (lookup_or_leaf state nϕ).2 nϕ.
    Proof.
      unfold lookup_or_leaf, lookup_or_node, lookup_or.
      simpl.
      destruct (list_find (alpha_equiv nϕ) (cs_history state)) as [[n phi] |] eqn:Heq; simpl.
      {
        rewrite list_find_Some in Heq.
        destruct Heq as [H1 [H2 H3] ].
        apply alpha_equiv_sym.
        assumption.
      }
      {
        apply alpha_equiv_refl.
      }
    Qed.

    Lemma alpha_equiv'_impl_almost_same_evars {Σ : Signature} R R' nϕ1 nϕ2:
      alpha_equiv' R R' nϕ1 nϕ2 ->
      forall x1, x1 ∈ (named_free_evars nϕ1) ->
        exists x2, x2 ∈ (named_free_evars nϕ2) /\
          (x1, x2) ∈ pbr R.
    Proof.
      intros Halpha x1 Hx1.
      induction Halpha; simpl in *.
      {
        rewrite elem_of_singleton in Hx1.
        subst.
        exists y.
        rewrite elem_of_singleton.
        split;[reflexivity|assumption].
      }
      { exfalso. set_solver. }
      {
        rewrite elem_of_union in Hx1.
        destruct Hx1 as [Hx1|Hx1].
        {
          specialize (IHHalpha1 Hx1).
          destruct IHHalpha1 as [x2 [Hx21 Hx22] ].
          exists x2.
          rewrite elem_of_union.
          naive_solver.
        }
        {
          specialize (IHHalpha2 Hx1).
          destruct IHHalpha2 as [x2 [Hx21 Hx22] ].
          exists x2.
          rewrite elem_of_union.
          naive_solver.
        }
      }
      {
        rewrite elem_of_union in Hx1.
        destruct Hx1 as [Hx1|Hx1].
        {
          specialize (IHHalpha1 Hx1).
          destruct IHHalpha1 as [x2 [Hx21 Hx22] ].
          exists x2.
          rewrite elem_of_union.
          naive_solver.
        }
        {
          specialize (IHHalpha2 Hx1).
          destruct IHHalpha2 as [x2 [Hx21 Hx22] ].
          exists x2.
          rewrite elem_of_union.
          naive_solver.
        }
      }
      { exfalso. set_solver. }
      { exfalso. set_solver. }
      {
        destruct (decide (x1 = x)).
        {
          subst. clear -Hx1. exfalso. set_solver.
        }
        {
          feed specialize IHHalpha.
          {
            set_solver.
          }
          destruct IHHalpha as [x2 [Hx21 Hx22] ].
          rewrite elem_of_union in Hx22.
          rewrite elem_of_filter in Hx22.
          unfold unrelated,related in Hx22.
          rewrite elem_of_singleton in Hx22.
          simpl in Hx22.
          destruct Hx22; try naive_solver.
          exists x2. set_solver.
        }
      }
      {
        specialize (IHHalpha Hx1).
        exact IHHalpha.
      }
    Qed.

    Lemma alpha_equiv'_impl_almost_same_svars {Σ : Signature} R R' nϕ1 nϕ2:
      alpha_equiv' R R' nϕ1 nϕ2 ->
      forall X1, X1 ∈ (named_free_svars nϕ1) ->
        exists X2, X2 ∈ (named_free_svars nϕ2) /\
          (X1, X2) ∈ pbr R'.
    Proof.
      intros Halpha X1 HX1.
      induction Halpha; simpl in *.
      { exfalso. set_solver. }
      {
        rewrite elem_of_singleton in HX1.
        subst.
        exists Y.
        rewrite elem_of_singleton.
        split;[reflexivity|assumption].
      }
      {
        rewrite elem_of_union in HX1.
        destruct HX1 as [HX1|HX1].
        {
          specialize (IHHalpha1 HX1).
          destruct IHHalpha1 as [X2 [HX21 HX22] ].
          exists X2.
          rewrite elem_of_union.
          naive_solver.
        }
        {
          specialize (IHHalpha2 HX1).
          destruct IHHalpha2 as [X2 [HX21 HX22] ].
          exists X2.
          rewrite elem_of_union.
          naive_solver.
        }
      }
      {
        rewrite elem_of_union in HX1.
        destruct HX1 as [HX1|HX1].
        {
          specialize (IHHalpha1 HX1).
          destruct IHHalpha1 as [X2 [HX21 HX22] ].
          exists X2.
          rewrite elem_of_union.
          naive_solver.
        }
        {
          specialize (IHHalpha2 HX1).
          destruct IHHalpha2 as [X2 [HX21 HX22] ].
          exists X2.
          rewrite elem_of_union.
          naive_solver.
        }
      }
      { exfalso. set_solver. }
      { exfalso. set_solver. }
      {
        specialize (IHHalpha HX1).
        exact IHHalpha.
      }
      {
        destruct (decide (X1 = X)).
        {
          subst. clear -HX1. exfalso. set_solver.
        }
        {
          feed specialize IHHalpha.
          {
            set_solver.
          }
          destruct IHHalpha as [X2 [HX21 HX22] ].
          rewrite elem_of_union in HX22.
          rewrite elem_of_filter in HX22.
          unfold unrelated,related in HX22.
          rewrite elem_of_singleton in HX22.
          simpl in HX22.
          destruct HX22; try naive_solver.
          exists X2. set_solver.
        }
      }
    Qed.

    Lemma alpha_equiv_impl_same_evars {Σ : Signature} nϕ1 nϕ2:
      alpha_equiv nϕ1 nϕ2 ->
      (named_free_evars nϕ1) = (named_free_evars nϕ2).
    Proof.
      intros Halpha.
      unfold alpha_equiv in Halpha.
      pose proof (H1 := alpha_equiv'_impl_almost_same_evars _ _ nϕ1 nϕ2 Halpha).
      pose proof (H2 := alpha_equiv'_impl_almost_same_evars _ _ nϕ2 nϕ1 (proj1 (alpha_equiv_sym nϕ1 nϕ2) Halpha)).
      simpl in *. unfold twice in *.
      apply anti_symm with (S := @subseteq (gset (evar)) _).
      { apply _. }
      {
        rewrite elem_of_subseteq.
        intros x Hx.
        specialize (H1 _ Hx).
        destruct H1 as [x2 [Hx21 Hx22] ].
        rewrite elem_of_map in Hx22.
        destruct Hx22 as [x0 [Hx01 Hx02] ].
        inversion Hx01; clear Hx01; subst.
        assumption.
      }
      {
        rewrite elem_of_subseteq.
        intros x Hx.
        specialize (H2 _ Hx).
        destruct H2 as [x2 [Hx21 Hx22] ].
        rewrite elem_of_map in Hx22.
        destruct Hx22 as [x0 [Hx01 Hx02] ].
        inversion Hx01; clear Hx01; subst.
        assumption.
      }
    Qed.

    Lemma alpha_equiv_impl_same_svars {Σ : Signature} nϕ1 nϕ2:
      alpha_equiv nϕ1 nϕ2 ->
      (named_free_svars nϕ1) = (named_free_svars nϕ2).
    Proof.
      intros Halpha.
      unfold alpha_equiv in Halpha.
      pose proof (H1 := alpha_equiv'_impl_almost_same_svars _ _ nϕ1 nϕ2 Halpha).
      pose proof (H2 := alpha_equiv'_impl_almost_same_svars _ _ nϕ2 nϕ1 (proj1 (alpha_equiv_sym nϕ1 nϕ2) Halpha)).
      simpl in *. unfold twice in *.
      apply anti_symm with (S := @subseteq (gset (svar)) _).
      { apply _. }
      {
        rewrite elem_of_subseteq.
        intros x Hx.
        specialize (H1 _ Hx).
        destruct H1 as [x2 [Hx21 Hx22] ].
        rewrite elem_of_map in Hx22.
        destruct Hx22 as [x0 [Hx01 Hx02] ].
        inversion Hx01; clear Hx01; subst.
        assumption.
      }
      {
        rewrite elem_of_subseteq.
        intros x Hx.
        specialize (H2 _ Hx).
        destruct H2 as [x2 [Hx21 Hx22] ].
        rewrite elem_of_map in Hx22.
        destruct Hx22 as [x0 [Hx01 Hx02] ].
        inversion Hx01; clear Hx01; subst.
        assumption.
      }
    Qed.

    Lemma alpha_equiv_same_size {Σ : Signature}
      (nϕ1 nϕ2 : NamedPattern) R R'
      : alpha_equiv' R R' nϕ1 nϕ2 ->
        nsize' nϕ1 = nsize' nϕ2.
    Proof.
      intros H.
      induction H; simpl; lia.
    Qed.

    Lemma collapse_aux_nsize' {Σ : Signature}
      (state : CollapseState)
      (nϕ : NamedPattern)
      : nsize' (collapse_aux state nϕ).2 = nsize' nϕ.
    Proof.
      move: state.
      induction nϕ; intros state; simpl;
        unfold lookup_or_leaf,lookup_or_node,lookup_or,alpha_equiv;
        repeat case_match; subst; simpl; try lia;
      match goal with
      | [H' : list_find _ _ = Some _ |- _] =>
        rewrite list_find_Some in H';
        destruct_and!;
        match goal with
        | [ Ha: alpha_equiv' _ _ _ _ |- _] => apply alpha'_sym in Ha
        end;
        erewrite alpha_equiv_same_size;[|eassumption];reflexivity
      | _ => congruence
      end.
    Qed.

    Definition list_of_pairs_apply {A B : Type}
    {_eqdA : EqDecision A}
    {_eqdB : EqDecision B}
    (x : A) (s : list (prod A B))
     : list B
   := fmap snd (filter (fun p => p.1 = x) s).

   Definition list_of_pairs_compose {A B C : Type}
      {_eqdA : EqDecision A}
      {_eqdB : EqDecision B}
      {_eqdC : EqDecision C}
      (s1 : list (prod A B))
      (s2 : list (prod B C))
      : list (prod A C)
    := foldr (fun (p : prod A B) (g' : list (prod A C)) =>
        let a := p.1 in
        let b := p.2 in
        g' ++ (fmap (fun (c : C) => (a,c))  (list_of_pairs_apply b s2))
    ) [] s1.

    Lemma list_of_pairs_compose_correct {A B C : Type}
    {_eqdA : EqDecision A}
    {_eqdB : EqDecision B}
    {_eqdC : EqDecision C}
    (s1 : list (prod A B))
    (s2 : list (prod B C))
    : forall (a : A) (c : C),
      (a, c) ∈ (list_of_pairs_compose s1 s2)
      <-> exists (b : B), (a, b) ∈ s1 /\ (b, c) ∈ s2.
    Proof.
      intros a c.
      unfold list_of_pairs_compose.
      split; intros H'.
      {
        induction s1; simpl in *.
        {
          inversion H'.
        }
        {
          rewrite elem_of_app in H'.
          destruct H' as [H'|H'].
          {
            specialize (IHs1 H').
            destruct IHs1 as [b [Hb1 Hb2] ].
            exists b.
            split.
            {
              right. exact Hb1.
            }
            {
              exact Hb2.
            }
          }
          {
            unfold fmap in H'.
            rewrite elem_of_list_fmap in H'.
            destruct H' as [y [Hy1 Hy2] ].
            inversion Hy1; clear Hy1; subst.
            unfold list_of_pairs_apply in Hy2.
            unfold fmap in Hy2.
            rewrite elem_of_list_fmap in Hy2.
            destruct Hy2 as [[b c][Hc1 Hc2] ].
            simpl in Hc1. subst y.
            unfold filter in Hc2.
            rewrite elem_of_list_filter in Hc2.
            destruct a0 as [a0 b0]. simpl in *.
            destruct Hc2 as [Hc2 Hc3].
            simpl in Hc2. subst b.
            exists b0.
            split.
            {
              left.
            }
            {
              exact Hc3.
            }
          }
        }
      }
      {
        move: a c H'.
        induction s1; intros a' c' H'; simpl.
        {
          destruct H' as [b [Hb1 Hb2] ].
          inversion Hb1.
        }
        {
          destruct H' as [b [Hb1 Hb2] ].
          rewrite elem_of_app.
          destruct a as [a'' b'']. simpl in *.
          inversion Hb1; clear Hb1; subst.
          {
            specialize (IHs1 a'' c').
            destruct (decide ((a'',b'') ∈ s1)).
            {
              feed specialize IHs1.
              {
                exists b''. split; assumption.
              }
              left. apply IHs1.
            }
            {
              right.
              unfold fmap.
              rewrite elem_of_list_fmap.
              exists c'.
              split;[reflexivity|].
              unfold list_of_pairs_apply.
              unfold filter.
              rewrite elem_of_list_fmap.
              exists (b'', c').
              split;[reflexivity|].
              rewrite elem_of_list_filter.
              simpl.
              split;[reflexivity|assumption].
            }
          }
          {
            specialize (IHs1 a' c').
            feed specialize IHs1.
            {
              exists b.
              split; assumption.
            }
            left. apply IHs1.
          }
        }
      }
    Qed.

    Program Definition pb_compose {A : Type}
      {_eqd : EqDecision A }
      {_cnd : Countable A }
      (pb1 pb2 : PartialBijection A)
      : PartialBijection A
    := {|
      pbr := list_to_set (list_of_pairs_compose (elements (pbr pb1)) (elements (pbr pb2))) ;
    |}.
    Next Obligation.
      intros A _eqd _cnt pb1 pb2 x y1 y2 H1 H2.
      rewrite elem_of_list_to_set in H1.
      rewrite elem_of_list_to_set in H2.
      rewrite list_of_pairs_compose_correct in H1.
      rewrite list_of_pairs_compose_correct in H2.
      destruct H1 as [B1 [HB11 HB12] ].
      destruct H2 as [B2 [HB21 HB22] ].
      rewrite elem_of_elements in HB11.
      rewrite elem_of_elements in HB22.
      rewrite elem_of_elements in HB12.
      rewrite elem_of_elements in HB21.

      destruct pb1 as [pbA pbApf1 pbApf2], pb2 as [pbB pbBpf1 pbBpf2].
      simpl in *.
      pose proof (pbApf1 _ _ _ HB11 HB21).
      subst B2.
      pose proof (pbBpf1 _ _ _ HB22 HB12).
      subst y2.
      reflexivity.
    Qed.
    Next Obligation.
    intros A _eqd _cnt pb1 pb2 x y1 y2 H1 H2.
    rewrite elem_of_list_to_set in H1.
    rewrite elem_of_list_to_set in H2.
    rewrite list_of_pairs_compose_correct in H1.
    rewrite list_of_pairs_compose_correct in H2.
    destruct H1 as [B1 [HB11 HB12] ].
    destruct H2 as [B2 [HB21 HB22] ].
    rewrite elem_of_elements in HB11.
    rewrite elem_of_elements in HB22.
    rewrite elem_of_elements in HB12.
    rewrite elem_of_elements in HB21.

    destruct pb1 as [pbA pbApf1 pbApf2], pb2 as [pbB pbBpf1 pbBpf2].
    simpl in *.
    pose proof (pbBpf2 _ _ _ HB22 HB12).
    subst B2.
    pose proof (pbApf2 _ _ _ HB11 HB21).
    subst y1.
    reflexivity.
  Qed.

  Lemma compose_update {A : Type} {_eqd : EqDecision A} {_cnt : Countable A}
    (R1 R2 : PartialBijection A) (x y z : A) :
  pbr (pb_compose (pb_update R1 x y) (pb_update R2 y z))
  ⊆ pbr (pb_update (pb_compose R1 R2) x z).
  Proof.
    destruct R1, R2.
    simpl.
      rewrite elem_of_subseteq.
      intros [e1 e2] H.
      rewrite elem_of_list_to_set in H.
      rewrite list_of_pairs_compose_correct in H.
      destruct H as [e' [He'1 He'2] ].
      rewrite elem_of_elements in He'1.
      rewrite elem_of_elements in He'2.
      rewrite elem_of_union in He'1.
      rewrite elem_of_union in He'2.
      rewrite elem_of_filter in He'1.
      rewrite elem_of_filter in He'2.
      rewrite elem_of_singleton in He'1.
      rewrite elem_of_singleton in He'2.
      rewrite elem_of_union.
      rewrite elem_of_filter.
      rewrite elem_of_singleton.
      rewrite elem_of_list_to_set.
      rewrite list_of_pairs_compose_correct.
      setoid_rewrite elem_of_elements.
      unfold unrelated, related in *.
      naive_solver.
  Qed.

  Lemma pb_update_mono {A : Type}
    {_eqd : EqDecision A }
    {_cnd : Countable A }
    (R1 R2 : PartialBijection A)
    (x y : A) :
    pbr R1 ⊆ pbr R2 ->
    pbr (pb_update R1 x y) ⊆ pbr (pb_update R2 x y).
  Proof.
    intros H.
    unfold pb_update. simpl.
    apply union_mono.
    {
      unfold filter.
      rewrite elem_of_subseteq.
      intros aa Haa.
      rewrite elem_of_filter in Haa.
      rewrite elem_of_filter.
      destruct Haa as [H1 H2].
      split;[assumption|].
      set_solver.
    }
    {
      apply reflexivity.
    }
  Qed.

  Lemma alpha'_mono {Σ : Signature}
    (R1 R2 : PartialBijection evar)
    (R'1 R'2 : PartialBijection svar)
    (t u : NamedPattern)
    :
      pbr R1 ⊆ pbr R2 ->
      pbr R'1 ⊆ pbr R'2 ->
      alpha_equiv' R1 R'1 t u ->
      alpha_equiv' R2 R'2 t u.
  Proof.
    intros H1 H2 Ha.
    move: R2 R'2 H1 H2.
    induction Ha; intros R2 R'2 H1 H2; constructor; auto.
    {
      apply IHHa.
      {
        apply pb_update_mono.
        exact H1.
      }
      {
        apply H2.
      }
    }
    {
      apply IHHa.
      { apply H1. }
      {
        apply pb_update_mono.
        exact H2.
      }
    }
  Qed.

  Lemma compose_alpha' {Σ : Signature}
    (R1 R2 : PartialBijection evar)
    (R'1 R'2 : PartialBijection svar)
    (t u v : NamedPattern):
    alpha_equiv' R1 R'1 t u ->
    alpha_equiv' R2 R'2 u v ->
    alpha_equiv' (pb_compose R1 R2) (pb_compose R'1 R'2) t v.
  Proof.
    intros Htu Huv.
    move : R1 R2 R'1 R'2 t v Htu Huv.
    induction u; intros R1 R2 R'1 R'2 t v Htu Huv; inversion Htu; inversion Huv; clear Htu; clear Huv; subst;
      constructor.
    {
      unfold pb_compose. simpl.
      rewrite elem_of_list_to_set.
      rewrite list_of_pairs_compose_correct.
      exists x.
      do 2 rewrite elem_of_elements.
      split; assumption.
    }
    {
      unfold pb_compose. simpl.
      rewrite elem_of_list_to_set.
      rewrite list_of_pairs_compose_correct.
      exists X.
      do 2 rewrite elem_of_elements.
      split; assumption.
    }
    { naive_solver. }
    { naive_solver. }
    { naive_solver. }
    { naive_solver. }
    {
      pose proof (H'' := IHu _ _ _ _ _ _ tEu tEu0).
      eapply alpha'_mono;[apply compose_update|idtac|].
      2: apply H''.
      apply reflexivity.
    }
    {
      eapply alpha'_mono;[|apply compose_update|idtac].
      2: apply IHu.
      3: apply tEu0.
      2: apply tEu.
      apply reflexivity.
    }
  Qed.

  Lemma diagonal_mono {A : Type}
  {_eqd : EqDecision A }
  {_cnd : Countable A }
  ( R1 R2 : gset A)
  : R1 ⊆ R2 -> pbr (diagonal R1) ⊆ pbr (diagonal R2).
  Proof.
    intros H.
    unfold diagonal. simpl.
    apply set_map_mono;[|assumption].
    unfold pointwise_relation.
    intros a. reflexivity.
  Qed.

    Lemma collapse_aux_alpha'
      {Σ : Signature}
      (state : CollapseState)
      (nϕ : NamedPattern)
      : alpha_equiv (collapse_aux state nϕ).2 nϕ.
    Proof.
      remember (nsize' nϕ) as sz.
      assert (Hsz: nsize' nϕ <= sz) by lia.
      clear Heqsz.

      move: nϕ Hsz state.
      induction sz; intros nϕ Hsz state; destruct nϕ;
        simpl in *; try lia; try apply lookup_or_leaf_alpha.
      {
        unfold lookup_or_node,lookup_or. simpl.
        repeat case_match.
        {
          subst. simpl.
          rewrite list_find_Some in H.
          destruct H as [H1 [H2 H3] ].
          apply alpha_equiv_sym.
          apply H2.
        }
        {
          simpl.
          clear H.

          constructor; simpl; unfold alpha_equiv in *.
          {
            pose proof (IH1 := (IHsz nϕ1 ltac:(lia) state)).
            pose proof (IH2 := (IHsz nϕ2 ltac:(lia) state)).
            pose proof (H1e := alpha_equiv_impl_same_evars _ _ IH1).
            pose proof (H1s := alpha_equiv_impl_same_svars _ _ IH1).

            rewrite H1e H1s.

            eapply alpha'_mono;[idtac|idtac|apply IH1].
            {
              apply diagonal_mono.
              rewrite H1e. clear. set_solver.
            }
            {
              apply diagonal_mono.
              rewrite H1s. clear. set_solver.
            }
          }
          {
            erewrite alpha_equiv_impl_same_evars.
            2: apply IHsz; lia.
            erewrite alpha_equiv_impl_same_svars.
            2: apply IHsz; lia.

            eapply alpha'_mono.
            3: { eapply IHsz. lia. }
            { apply diagonal_mono. clear. set_solver. }
            { apply diagonal_mono. clear. set_solver. }
          }
        }
      }
      {
        unfold lookup_or_node,lookup_or. simpl.
        repeat case_match.
        {
          subst. simpl.
          rewrite list_find_Some in H.
          destruct H as [H1 [H2 H3] ].
          apply alpha_equiv_sym.
          apply H2.
        }
        {
          simpl.
          clear H.

          constructor; simpl; unfold alpha_equiv in *.
          {
            pose proof (IH1 := (IHsz nϕ1 ltac:(lia) state)).
            pose proof (IH2 := (IHsz nϕ2 ltac:(lia) state)).
            pose proof (H1e := alpha_equiv_impl_same_evars _ _ IH1).
            pose proof (H1s := alpha_equiv_impl_same_svars _ _ IH1).

            rewrite H1e H1s.

            eapply alpha'_mono;[idtac|idtac|apply IH1].
            {
              apply diagonal_mono.
              rewrite H1e. clear. set_solver.
            }
            {
              apply diagonal_mono.
              rewrite H1s. clear. set_solver.
            }
          }
          {
            erewrite alpha_equiv_impl_same_evars.
            2: apply IHsz; lia.
            erewrite alpha_equiv_impl_same_svars.
            2: apply IHsz; lia.

            eapply alpha'_mono.
            3: { eapply IHsz. lia. }
            { apply diagonal_mono. clear. set_solver. }
            { apply diagonal_mono. clear. set_solver. }
          }
        }
      }
      {
        unfold lookup_or_node,lookup_or. simpl.
        repeat case_match; simpl.
        {
          rewrite list_find_Some in H.
          destruct H as [H1 [H2 H3] ].
          apply alpha_equiv_sym.
          apply H2.
        }
        {
          clear H.
          constructor.
          eapply alpha'_mono.
          3: apply IHsz; lia.
          {
            eapply transitivity.
            {
              eapply diagonal_mono.
              erewrite alpha_equiv_impl_same_evars.
              2: apply IHsz; lia.
              rewrite union_idemp_L.
              apply reflexivity.
            }
            simpl.
            rewrite elem_of_subseteq.
            intros [e1 e2] He1e2.
            rewrite elem_of_map in He1e2.
            destruct He1e2 as [x' [H1 H2] ].
            unfold twice in H1. inversion H1. subst. clear H1.
            rewrite elem_of_union.
            rewrite elem_of_singleton.
            destruct (decide (x = x')).
            {
              subst. right. reflexivity.
            }
            {
              rewrite elem_of_filter.
              unfold unrelated,related.
              simpl.
              left.
              split;[naive_solver|].
              rewrite elem_of_map.
              exists x'.
              split;[reflexivity|].
              rewrite elem_of_union.
              left.
              rewrite elem_of_difference.
              rewrite elem_of_singleton.
              split;[|congruence].
              erewrite alpha_equiv_impl_same_evars.
              { exact H2. }
              apply IHsz.
              lia.
            }
          }
          {
            eapply transitivity.
            {
              eapply diagonal_mono.
              erewrite alpha_equiv_impl_same_svars.
              2: apply IHsz; lia.
              rewrite union_idemp_L.
              apply reflexivity.
            }
            simpl.
            rewrite elem_of_subseteq.
            intros [e1 e2] He1e2.
            rewrite elem_of_map in He1e2.
            destruct He1e2 as [x' [H1 H2] ].
            unfold twice in H1. inversion H1. subst. clear H1.
            rewrite elem_of_map.
            exists x'.
            split;[reflexivity|].
            rewrite elem_of_union.
            right. assumption.
          }
        }
      }
      {
        unfold lookup_or_node,lookup_or. simpl.
        repeat case_match; simpl.
        {
          rewrite list_find_Some in H.
          destruct H as [H1 [H2 H3] ].
          apply alpha_equiv_sym.
          apply H2.
        }
        {
          clear H.
          constructor.
          eapply alpha'_mono.
          3: apply IHsz; lia.
          {
            eapply transitivity.
            {
              eapply diagonal_mono.
              erewrite alpha_equiv_impl_same_evars.
              2: apply IHsz; lia.
              rewrite union_idemp_L.
              apply reflexivity.
            }
            simpl.
            rewrite elem_of_subseteq.
            intros [e1 e2] He1e2.
            rewrite elem_of_map in He1e2.
            destruct He1e2 as [x' [H1 H2] ].
            unfold twice in H1. inversion H1. subst. clear H1.

            rewrite elem_of_map.
            exists x'.
            split;[reflexivity|].
            rewrite elem_of_union.
            right. assumption.
          }
          {
            eapply transitivity.
            {
              eapply diagonal_mono.
              erewrite alpha_equiv_impl_same_svars.
              2: apply IHsz; lia.
              rewrite union_idemp_L.
              apply reflexivity.
            }
            simpl.
            rewrite elem_of_subseteq.
            intros [e1 e2] He1e2.
            rewrite elem_of_map in He1e2.
            destruct He1e2 as [X' [H1 H2] ].
            unfold twice in H1. inversion H1. subst. clear H1.

            rewrite elem_of_union.
            rewrite elem_of_singleton.
            destruct (decide (X = X')).
            {
              subst. right. reflexivity.
            }
            {
              rewrite elem_of_filter.
              unfold unrelated,related.
              simpl.
              left.
              split;[naive_solver|].
              rewrite elem_of_map.
              exists X'.
              split;[reflexivity|].
              rewrite elem_of_union.
              left.
              rewrite elem_of_difference.
              rewrite elem_of_singleton.
              split;[|congruence].
              erewrite alpha_equiv_impl_same_svars.
              { exact H2. }
              apply IHsz.
              lia.
            }
          }
        }
      }
    Qed.

  (*
  (* TESTS *)
From MatchingLogic Require Import StringSignature.

Definition Σ : Signature :=
  {|
   |}
#[local]
Example ex_rename {Σ : Signature} :
  rename  = patt_bott.
*)


From CoreErlang.FrameStack Require Export CIU.

Import ListNotations.

Ltac scope_solver_step :=
  match goal with
  | |- EXP _ ⊢ _ => constructor; simpl; auto
  | |- VAL _ ⊢ _ => constructor; simpl; auto
  | |- RED _ ⊢ _ => constructor; simpl; auto
  | |- NVAL _ ⊢ _ => constructor; simpl; auto
  | |- forall i, i < _ -> _ => simpl; intros
  | [H : ?i < _ |- _] => inv H; simpl in *; auto; try lia
  | [H : ?i <= _ |- _] => inv H; simpl in *; auto; try lia
  | [H : EXP ?n1 ⊢ ?e |- EXP ?n2 ⊢ ?e] => try now (eapply (loosen_scope_exp n2 n1 ltac:(lia)) in H)
  | [H : VAL ?n1 ⊢ ?e |- VAL ?n2 ⊢ ?e] => try now (eapply (loosen_scope_val n2 n1 ltac:(lia)) in H)
  | [H : NVAL ?n1 ⊢ ?e |- NVAL ?n2 ⊢ ?e] => try now (eapply (loosen_scope_nonval n2 n1 ltac:(lia)) in H)
  end.

Ltac scope_solver := repeat scope_solver_step; try lia.

Ltac deriv :=
  match goal with
  | [H : ?i < length _ |- _] => simpl in *; inv H; auto; try lia
  | [H : ?i <= length _ |- _] => simpl in *; inv H;  auto; try lia
  | [H : | _, _ | ↓ |- _] => inv H; try inv_val
  | [H : | _ :: _, RValSeq _ | _ ↓ |- _] => inv H; try inv_val
  | [H : | _ :: _, RExc _ | _ ↓ |- _] => inv H; try inv_val
  | [H : | _, RExp (EExp _) | _ ↓ |- _] => inv H; try inv_val
  | [H : | _, RExp (VVal _) | _ ↓ |- _] => inv H; try inv_val
  | [H : | _, RBox | _ ↓ |- _] => inv H; try inv_val
  end.

Ltac extract_meta_eval H :=
  let r := fresh "r" in
  let k := fresh "k" in
  let Hr := fresh "Hr" in
  let Hd := fresh "Hd" in
  let Hd' := fresh "Hd'" in
  let Hk := fresh "Hk" in
  let H' := fresh "H'" in
  eapply term_eval_both in H as H'; destruct H' as [r [k [Hr [Hd [Hd' Hk]]]]];
  eapply term_step_term in Hd'; [|eassumption]; inv Hr.

Ltac unfold_list :=
  match goal with
  | [H : length ?l = 0 |- _] => destruct l; try inv H
  | [H : 0 = length ?l |- _] => destruct l; try inv H
  | [H : length ?l = S ?n |- _] => destruct l; try inv H; unfold_list
  | [H : S ?n = length ?l |- _] => destruct l; try inv H; unfold_list
  end.

Tactic Notation "replace" "counter" "with" constr(num) :=
  match goal with
  | |- | _, _ | ?k ↓ => replace k with num by lia
  end.

Section case_if_equiv.

  Open Scope string_scope.
  Variables (e1 e2 e3 : Exp) (Γ : nat).
  Hypotheses (He1 : EXP Γ ⊢ e1)
             (He2 : EXP Γ ⊢ e2)
             (He3 : EXP Γ ⊢ e3).

  Local Definition nonidiomatic :=
    ELet 1 e1
      (ECase (`VVar 0)
              [([PLit (Atom "true")], `VLit "true", e2);
              ([PVar], `VLit "true", e3.[ren (fun n => 2 + n) ])]).

  Local Definition idiomatic :=
    ELet 1 e1
      (ECase (EValues [])
          [([], °ECall "erlang" "=:=" [`VVar 0;`VLit "true"], e2);
          ([], `VLit "true", e3.[ren (fun n => 1 + n) ])]).

  Local Proposition nonidiomatic_scope :
    EXP Γ ⊢ nonidiomatic.
  Proof.
    unfold nonidiomatic.
    scope_solver.
    apply -> subst_preserves_scope_exp. exact He3.
    intro. intros. simpl. lia.
  Qed.

  Local Proposition idiomatic_scope :
    EXP Γ ⊢ idiomatic.
  Proof.
    unfold idiomatic.
    scope_solver.
    apply -> subst_preserves_scope_exp. exact He3.
    intro. intros. simpl. lia.
  Qed.

  Local Theorem equivalence_part1 :
    CIU_open Γ nonidiomatic idiomatic.
  Proof.
    split. 2: split.
    constructor. apply -> subst_preserves_scope_exp; try apply nonidiomatic_scope; auto.
    constructor. apply -> subst_preserves_scope_exp; try apply idiomatic_scope; auto.
    {
      intros. unfold nonidiomatic in H1. simpl in H1.
      repeat deriv.
      extract_meta_eval H7; clear H7.
      { (* e1 evaluates to an exception *)
        inv Hd'. clear H5.
        unfold idiomatic.
        exists (S (S k1 + k0)). simpl. econstructor.
        eapply frame_indep_nil in Hd.
        eapply step_term_term. eassumption. 2: lia.
        replace (S (k1 + k0) - k0) with (S k1) by lia. constructor. congruence.
        eassumption.
      }
      { (* e1 evaluates correctly *)
        deriv. unfold_list. simpl in H7.
        do 3 deriv.
        { (* v is true *)
          simpl in H10. destruct v; try congruence. break_match_hyp; try congruence.
          break_match_hyp; try congruence. destruct l; simpl in Heqb; try congruence.
          break_match_hyp; try congruence. inv Heqo. simpl in H10. inv H10.
          simpl in H11. do 2 deriv.
          cbn in H9. inv H9.
          unfold idiomatic.
          exists (S (12 + k2 + k0)). simpl. econstructor.
          eapply frame_indep_nil in Hd.
          eapply step_term_term. eassumption. 2: lia.
          replace counter with (12 + k2).
          constructor. reflexivity.
          simpl. constructor.
          constructor. econstructor. congruence. simpl. reflexivity.
          econstructor. reflexivity.
          simpl. constructor. econstructor. congruence.
          constructor. constructor. constructor. simpl. econstructor. cbn. reflexivity.
          econstructor. reflexivity. eassumption.
        }
        { (* v is not true *)
          deriv.
          2: { (* no more cases *)
            inv H9.
          }
          simpl in H12. do 2 deriv. rewrite H11 in H9. inv H9.
          unfold idiomatic.
          exists (S (15 + k1 + k0)). simpl. econstructor.
          eapply frame_indep_nil in Hd.
          eapply step_term_term. eassumption. 2: lia.
          replace counter with (15 + k1).
          constructor. reflexivity.
          simpl. constructor.
          constructor. econstructor. congruence. simpl. reflexivity.
          econstructor. reflexivity.
          simpl. constructor. econstructor. congruence.
          constructor. constructor. constructor. simpl. econstructor.
          { (* v is not true *)
            cbn. clear Hd H11 H12 H6. destruct v; simpl; try reflexivity.
            2: destruct n; reflexivity.
            destruct l; try reflexivity. simpl.
            destruct string_dec; try reflexivity. subst. simpl in H10. congruence.
          }
          constructor. econstructor. reflexivity. constructor. econstructor.
          reflexivity.
          simpl in H11. inv H11.
          do 2 rewrite subst_comp_exp in *.
          clear Hd H10. cbn in *.
          rewrite substcomp_id_r.
          rewrite subst_extend in H12.
          rewrite substcomp_scons_core, subst_extend in H12.
          rewrite subst_extend.
          rewrite subst_comp_exp in *.
          rewrite ren_scons in *.
          rewrite ren_scons in H12. assumption.
        }
      }
    }
  Qed.

  Local Theorem equivalence_part2 :
    CIU_open Γ idiomatic nonidiomatic.
  Proof.
    apply Rrel_implies_CIU.
    apply Rrel_exp_compat. apply Erel_Let_compat; auto.
    apply Rrel_exp_compat_reverse. apply CIU_implies_Rrel.
    pose proof (nonidiomatic_scope).
    pose proof (idiomatic_scope).
    unfold idiomatic, nonidiomatic in *. inv H. inv H0. inv H3. inv H2.
    split. 2: split.
    1-2: constructor; apply -> subst_preserves_scope_exp; eauto.
    clear H6 H3 H7. intros. simpl in H1.
    do 4 deriv. simpl in H9. deriv. 2: { inv H11. }
    inv H11.
    simpl in H12. rewrite idsubst_is_id_val in H12. do 3 deriv.
    break_match_hyp.
    2: { (* technical, Q: should this be possible? Evaluation of variables shouldn't just fail? -> variables are values or expressions? *)
      do 3 deriv. cbn in H11.
      do 2 deriv. 2: { deriv. inv H12. }
      simpl in H13. do 2 deriv. inv H11. inv H12.
      exists (6 + k0). simpl.
      econstructor. rewrite Heqs. do 2 constructor. reflexivity.
      econstructor. reflexivity. simpl. constructor. econstructor.
      reflexivity. simpl.
      rewrite subst_comp_exp in *. simpl in *.
      rewrite subst_extend, subst_comp_exp in *.
      rewrite substcomp_id_r, ren_scons in *. assumption.
    }
    do 3 deriv. cbn in H11.
    break_match_hyp.
    { (* e1 is true *)
      deriv. inv H9. simpl in H12. rewrite idsubst_is_id_exp in H12.
      exists (5 + k). simpl.
      econstructor. rewrite Heqs.
      destruct v; simpl in Heqb; try congruence.
      destruct l; simpl in Heqb; try congruence.
      break_match_hyp; try congruence. subst.
      econstructor. econstructor. reflexivity.
      constructor. econstructor. reflexivity.
      simpl. now rewrite idsubst_is_id_exp.
    }
    { (* e1 is false *)
      do 2 deriv. 2: { inv H12. }
      simpl in H13. do 2 deriv. inv H12. inv H11.
      exists (6 + k0). simpl.
      econstructor. rewrite Heqs. do 2 constructor.
      {
        destruct v; simpl in Heqb; try reflexivity.
        destruct l; simpl in Heqb; try reflexivity.
        break_match_hyp; subst; try congruence.
        cbn. destruct string_dec; auto. congruence.
      }
      econstructor. reflexivity. simpl. constructor. econstructor.
      reflexivity. simpl.
      rewrite subst_comp_exp in *. simpl in *.
      rewrite subst_extend, subst_comp_exp in *.
      rewrite substcomp_id_r, ren_scons in *. assumption.
    }
  Qed.
End case_if_equiv.

Section length_0.

  Open Scope string_scope.
  Variables (e1 e2 : Exp) (Γ : nat).
  Hypotheses (He1 : EXP Γ ⊢ e1)
             (He2 : EXP Γ ⊢ e2).

  Local Definition nonidiomatic2 :=
    ECase e1
    [([PVar],
      °ETry
      (
        ELet 1 (ECall "erlang" "length" [`VVar 0])
          (ECall "erlang" "==" [`VVar 0;`VLit 0%Z])
      )
      1 (`VVar 0)
      3 (`VLit "false")
      , e2.[ren (fun n => 1 + n)])
    ;
    ([PVar], `VLit "true", °EPrimOp "match_fail" [°ETuple [`VLit "function_clause";`VVar 0]])].

  Local Definition idiomatic2 :=
    ECase e1 [(
      [PNil], `VLit "true", e2);
      ([PVar], `VLit "true", °EPrimOp "match_fail" [°ETuple [`VLit "function_clause"; `VVar 0]])].

  Local Proposition nonidiomatic2_scope :
    EXP Γ ⊢ nonidiomatic2.
  Proof.
    unfold nonidiomatic2.
    scope_solver.
    apply -> subst_preserves_scope_exp. exact He2.
    intro. intros. simpl. lia.
  Qed.

  Local Proposition idiomatic2_scope :
    EXP Γ ⊢ idiomatic2.
  Proof.
    unfold idiomatic2.
    scope_solver.
  Qed.

  Local Theorem equivalence2_part1 :
    CIU_open Γ nonidiomatic2 idiomatic2.
  Proof.
    (* we cannot use compatibility lemmas here, because
       the patterns are different in the clauses *)
    pose proof idiomatic2_scope as Sc1.
    pose proof nonidiomatic2_scope as Sc2.
    split. 2: split.
    1-2: constructor; apply -> subst_preserves_scope_exp; eauto.
    intros. simpl in H1. destruct H1 as [k D].
    deriv. extract_meta_eval H5; clear H5.
    { (* e1 evaluates to an exception *)
      inv Hd'. exists (2 + k + k1). simpl.
      econstructor. eapply step_term_term.
      eapply frame_indep_nil in Hd. exact Hd. 2: lia.
      replace counter with (S k1). econstructor; auto. congruence.
    }
    { (* e1 evaluates correctly *)
      deriv.
      { (* pattern matching succeeds *)
        destruct vs. inv H3. destruct vs. 2: inv H3.
        simpl in H3. inv H3.
        inv H9. inv H10. repeat deriv.
        simpl in H10. destruct (eval_length [v]) eqn:EQ.
        {
          simpl in EQ. break_match_hyp; try congruence.
        }
        { (* v is a list *)
          apply eval_length_number in EQ as EQ'. intuition; repeat destruct_hyps.
          { (* v = VNil *)
            inv H1. inv H3. clear H2. simpl in EQ. rewrite EQ in H10.
            inv H10. simpl in H7. repeat deriv. cbn in H12. inv EQ.
            simpl in H12. inv H12. simpl in H14.
            repeat deriv. inv H12. simpl in H14.
            rewrite subst_comp_exp, subst_extend, subst_comp_exp in H14.
            rewrite ren_scons, substcomp_id_l in H14.
            (* evaluation *)
            exists (4 + k + k1). simpl.
            econstructor. eapply step_term_term.
            eapply frame_indep_nil in Hd; exact Hd. 2: lia.
            replace counter with (3 + k1). econstructor. reflexivity.
            constructor. econstructor. reflexivity. simpl.
            now rewrite idsubst_is_id_exp.
          }
          { (* v = VCons v1 v2 *)
            inv H1. inv H2. clear H3.
            pose proof EQ as EQ'. simpl in EQ. rewrite EQ in H10. clear EQ.
            simpl in H10. repeat deriv.
            simpl in H7. repeat deriv. cbn in H12.
            break_match_hyp. {
              pose proof (eval_length_positive _ _ _ EQ').
              lia.
            }
            repeat deriv. simpl in H14.
            repeat deriv. 2: inv H14. inv H14.
            simpl in H15. repeat deriv.
            inv H12. simpl in H14. repeat deriv. simpl in H15.
            repeat deriv. simpl in H10.
            (* evaluation *)
            simpl. exists (14 + k + k1). simpl.
            econstructor. eapply step_term_term.
            eapply frame_indep_nil in Hd; exact Hd. 2: lia.
            replace counter with (13 + k1). constructor. reflexivity.
            econstructor. reflexivity. simpl.
            do 2 econstructor. reflexivity. simpl.
            do 2 econstructor. congruence.
            do 2 econstructor. congruence.
            do 4 econstructor. reflexivity. simpl.
            econstructor. reflexivity. simpl. assumption.
          }
        }
        { (* exception *)
          simpl in EQ. rewrite EQ in H10. inv H10. inv H6. 2: {
            specialize (H5 _ _ _ _ eq_refl). contradiction.
          }
          simpl in H11. repeat deriv. 2: inv H12.
          simpl in H13. repeat deriv.
          inv H12. inv H11. simpl in H13. repeat deriv.
          simpl in H13. inv H13. simpl in H10.
          (* evaluation *)
          simpl. exists (14 + k + k1). simpl.
          econstructor. eapply step_term_term.
          eapply frame_indep_nil in Hd; exact Hd. 2: lia.
          replace counter with (13 + k1). constructor.
          destruct v; auto. inv EQ. clear H4 H8.
          econstructor. reflexivity. constructor.
          econstructor. reflexivity. simpl.
          constructor. constructor. congruence.
          do 2 constructor. congruence. do 4 econstructor.
          reflexivity. simpl. econstructor. reflexivity. simpl.
          assumption.
        }
        {
          simpl in EQ. break_match_hyp; inv EQ.
        }
      }
      { (* pattern matching fails due to the degree of `vs` - in the concrete Core Erlang implementation this cannot happen, because such programs are filtered out by the compiler *)
        repeat deriv. congruence.
        (* evaluation *)
        simpl. exists (4 + k + k1). simpl.
        econstructor. eapply step_term_term.
        eapply frame_indep_nil in Hd; exact Hd. 2: lia.
        replace counter with (3 + k1). constructor.
        {
          destruct vs; auto. destruct vs; simpl; destruct v; auto.
          inv H11.
        }
        constructor. assumption. constructor. assumption.
      }
    }
  Qed.

  Local Theorem equivalence2_part2 :
    CIU_open Γ idiomatic2 nonidiomatic2.
  Proof.
    (* the beginning of this proof is the same as before *)
    (* we cannot use compatibility lemmas here, because
    the patterns are different in the clauses *)
    pose proof idiomatic2_scope as Sc1.
    pose proof nonidiomatic2_scope as Sc2.
    split. 2: split.
    1-2: constructor; apply -> subst_preserves_scope_exp; eauto.
    intros. simpl in H1. destruct H1 as [k D].
    deriv. extract_meta_eval H5; clear H5.
    { (* e1 evaluates to an exception *)
      inv Hd'. exists (2 + k + k1). simpl.
      econstructor. eapply step_term_term.
      eapply frame_indep_nil in Hd. exact Hd. 2: lia.
      replace counter with (S k1). econstructor; auto. congruence.
    }
    (* new stuff *)
    { (* e1 evaluates correctly *)
      inv Hd'.
      { (* vs = [VNil] *)
        simpl in H9. destruct vs. 2: destruct vs. all: inv H3.
        all: destruct v; inv H2.
        repeat deriv. inv H9. simpl in H10.
        rewrite idsubst_is_id_exp in H10.
        (* evaluation *)
        simpl. exists (18 + k + k1). simpl.
        econstructor. eapply step_term_term.
        eapply frame_indep_nil in Hd. exact Hd. 2: lia.
        replace counter with (17 + k1).
        econstructor. reflexivity. simpl.
        repeat econstructor. 1-2: congruence. simpl.
        rewrite subst_comp_exp, subst_extend, subst_comp_exp.
        rewrite ren_scons, substcomp_id_l.
        assumption.
      }
      inv H9.
      { (* vs == [v] /\ v <> VNil *)
        destruct vs. 2: destruct vs.
        all: inv H11.
        simpl in H12. repeat deriv. inv H10.
        simpl in H11. repeat deriv.
        simpl in H12. repeat deriv.
        simpl in H9.
        (* evaluation *)
        simpl.
        simpl. destruct (eval_length [v]) eqn:EQ.
        {
          simpl in EQ. break_match_hyp; try congruence.
        }
        {
          exists (30 + k + k1). simpl.
          econstructor. eapply step_term_term.
          eapply frame_indep_nil in Hd. exact Hd. 2: lia.
          replace counter with (29 + k1).
          econstructor. reflexivity.
          simpl. econstructor. constructor.
          do 2 constructor. congruence.
          constructor. econstructor. reflexivity.
          apply eval_length_number in EQ as EQ'.
          intuition; repeat destruct_hyps. inv H1. inv H4. clear H2.
          inv EQ.
          { (* v = VNil*)
            inv H3.
          }
          (* boiler plate so that we can see the individual steps
             of the evaluation *)
          { (* v = VCons v1 v2 *)
            inv H2.
            apply eval_length_positive in EQ as EQ'.
            Opaque eval_length. simpl. rewrite EQ.
            econstructor. reflexivity. simpl.
            econstructor. econstructor. congruence.
            econstructor. econstructor. econstructor.
            econstructor. reflexivity. cbn. break_match_goal. lia.
            econstructor. reflexivity. simpl.
            econstructor. econstructor.
            econstructor. reflexivity.
            econstructor. econstructor. reflexivity. simpl.
            econstructor. constructor. congruence.
            econstructor. constructor. congruence.
            econstructor. econstructor. simpl.
            econstructor. econstructor. reflexivity.
            econstructor. reflexivity. simpl.
            assumption.
          }
        }
        {
          (* boiler plate so that we can see the individual steps
             of the evaluation *)
          exists (24 + k + k1). simpl.
          econstructor. eapply step_term_term.
          eapply frame_indep_nil in Hd. exact Hd. 2: lia.
          replace counter with (23 + k1).
          econstructor. reflexivity.
          simpl. econstructor. constructor.
          do 2 constructor. congruence.
          constructor. econstructor. reflexivity. cbn.
          rewrite EQ.
          Transparent eval_length.
          econstructor. congruence.
          destruct e, p. apply cool_try_err.
          econstructor. econstructor. econstructor. reflexivity.
          econstructor. econstructor. reflexivity. cbn.
          econstructor. econstructor. congruence.
          econstructor. econstructor. congruence.
          econstructor. econstructor. simpl.
          econstructor. econstructor. reflexivity.
          econstructor. reflexivity. simpl.
          assumption.
        }
        {
          simpl in EQ. break_match_hyp; inv EQ.
        }
      }
      { (* pattern matching fails due to the degree of `vs` - in the concrete Core Erlang implementation this cannot happen, because such programs are filtered out by the compiler *)
        inv H12. simpl.
        (* evaluation *)
        exists (4 + k1 + k). simpl.
        econstructor. eapply step_term_term.
        eapply frame_indep_nil in Hd. exact Hd. 2: lia.
        replace counter with (3 + k1).
        constructor. assumption.
        constructor. assumption.
        constructor. assumption.
      }
    }
  Qed.

End length_0.


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

(*****************************************************************************)
(*          Projet Formel - Calculus of Inductive Constructions V5.10        *)
(*****************************************************************************)
(*									     *)
(*	                      Comma Category (x|G)            		     *)
(*									     *)
(*****************************************************************************)
(*									     *)
(*                     A. SAIBI	  May 95                  		     *)
(*									     *)
(*****************************************************************************)

Require Export Functor.

Set Implicit Arguments.
Unset Strict Implicit.

(* (x|G) *)

Section comma_def.

Variables (A X : Category) (G : Functor A X) (x : X).

Structure Com_ob : Type :=  {Ob_com_ob : A; Mor_com_ob : x --> G Ob_com_ob}.

 Section com_arrow_def.

 Variable axf bxg : Com_ob.

 Definition Com_law (h : Ob_com_ob axf --> Ob_com_ob bxg) :=
   Mor_com_ob bxg =_S Mor_com_ob axf o FMor G h.

 Structure > Com_arrow : Type :=
   {Mor_com_arrow : Ob_com_ob axf --> Ob_com_ob bxg;
    Prf_com_law :> Com_law Mor_com_arrow}.

 (*** rewrite rules ***)

 (* *)

 Definition Equal_com_arrow (h h' : Com_arrow) :=
   Mor_com_arrow h =_S Mor_com_arrow h'.

 Lemma Equal_com_arrow_equiv : Equivalence Equal_com_arrow.
 Proof.
 apply Build_Equivalence; unfold Equal_com_arrow in |- *.
 unfold Reflexive in |- *; intro f.
 apply Refl.
 apply Build_Partial_equivalence.
 unfold Transitive in |- *; intros f g h H1 H2.
 (* *) apply Trans with (Mor_com_arrow g); assumption.
 unfold Symmetric in |- *; intros f g H.
 apply Sym; assumption.
 Qed.

 Canonical Structure Com_arrow_setoid : Setoid := Equal_com_arrow_equiv.

 End com_arrow_def.

(* composition of two arrows in comma *)

 Section comp_com_def.

 Variables (axf bxg cxh : Com_ob) (f : Com_arrow axf bxg)
   (g : Com_arrow bxg cxh).

 Definition Comp_com_mor := Mor_com_arrow f o Mor_com_arrow g.

 Lemma Comp_com_law : Com_law Comp_com_mor.
 Proof.
 unfold Com_law, Comp_com_mor in |- *.
 (* *) apply Trans with (Mor_com_ob bxg o FMor G (Mor_com_arrow g)).
 apply (Prf_com_law g).
 (* *) apply
        Trans
         with
           (Mor_com_ob axf
            o FMor G (Mor_com_arrow f) o FMor G (Mor_com_arrow g)).
 (* *) apply
        Trans
         with
           ((Mor_com_ob axf o FMor G (Mor_com_arrow f))
            o FMor G (Mor_com_arrow g)).
 apply Comp_r; apply (Prf_com_law f).
 apply Ass1.
 apply Comp_l; apply FComp1.
 Qed.

 Canonical Structure Comp_com_arrow := Build_Com_arrow Comp_com_law.

 End comp_com_def.

(* composition operator *)

Lemma Comp_com_congl : Congl_law Comp_com_arrow.
Proof.
unfold Congl_law in |- *; simpl in |- *.
intros a b c f1; elim f1; intros h e f2.
elim f2; intros h' e' f3; elim f3; intros h'' e''.
unfold Equal_com_arrow in |- *; simpl in |- *.
unfold Comp_com_mor in |- *; simpl in |- *.
intro H; apply Comp_l; trivial.
Qed.

Lemma Comp_com_congr : Congr_law Comp_com_arrow.
Proof.
unfold Congr_law in |- *; simpl in |- *.
intros a b c f1; elim f1; intros h e f2.
elim f2; intros h' e' f3; elim f3; intros h'' e''.
unfold Equal_com_arrow in |- *; simpl in |- *.
unfold Comp_com_mor in |- *; simpl in |- *.
intro H; apply Comp_r; trivial.
Qed.

Definition Comp_Comma := Build_Comp Comp_com_congl Comp_com_congr.

Lemma Assoc_Comma : Assoc_law Comp_Comma.
Proof.
unfold Assoc_law in |- *; intros a b c d f1; elim f1.
intros h1 e1 f2; elim f2; intros h2 e2 f3.
elim f3; intros h3 e3.
simpl in |- *; unfold Equal_com_arrow in |- *; simpl in |- *.
unfold Comp_com_mor in |- *; simpl in |- *.
unfold Comp_com_mor in |- *; simpl in |- *.
apply Ass.
Qed.

(* Id *)

Lemma Id_com_law : forall axf : Com_ob, Com_law (Id (Ob_com_ob axf)).
Proof.
intro axf; unfold Com_law in |- *.
(* *) apply Trans with (Mor_com_ob axf o Id (G (Ob_com_ob axf))).
apply Idr.
apply Comp_l; apply FId1.
Qed.

Canonical Structure Id_Comma (axf : Com_ob) :=
  Build_Com_arrow (Id_com_law axf).

Lemma Idl_Comma : Idl_law Comp_Comma Id_Comma.
Proof.
unfold Idl_law in |- *; intros a b f1; elim f1; intros h e.
simpl in |- *; unfold Equal_com_arrow in |- *; simpl in |- *.
unfold Comp_com_mor in |- *; simpl in |- *.
apply Idl.
Qed.

Lemma Idr_Comma : Idr_law Comp_Comma Id_Comma.
Proof.
unfold Idr_law in |- *; intros a b f1; elim f1; intros h e.
simpl in |- *; unfold Equal_com_arrow in |- *; simpl in |- *.
unfold Comp_com_mor in |- *; simpl in |- *.
apply Idr.
Qed.

Canonical Structure Comma := Build_Category Assoc_Comma Idl_Comma Idr_Comma.

End comma_def.


Require Export SpathIncl.
Require Import Lia.

Section disj.

  Infix "-->" := edge__P.

  Context `(D : DiamondPaths).
  Hypothesis (Hjle : j1 ⊴ j2).

  Lemma split_node
        (Hnempty : r1 <> nil \/ r2 <> nil)
    : hd (s,k) (rev r1) <> hd (s,k) (rev r2).
  Proof.
    destruct Hnempty.
    - destr_r' r1;subst;[contradiction|].
      destruct D.
      rewrite rev_rcons. cbn.
      destr_r' r2;subst;cbn in Dqj2.
      + inv Dqj2. cbn. intro N. subst x. eapply path_rcons in Dsk1;eauto.
        eapply tcfg_enroot in Dsk1;eauto. destructH.
        eapply tpath_NoDup in Dsk1.
        eapply NoDup_app with (a:=(q2,j2)).
        * rewrite <-app_assoc in Dsk1. eapply Dsk1.
        * rewrite app_comm_cons. eapply In_rcons. left. auto.
        * cbn. left. auto.
      + cbn. rewrite rev_rcons. cbn.
        eapply disjoint2;eauto.
    - destr_r' r2;subst;[contradiction|].
      destruct D.
      rewrite rev_rcons. cbn.
      destr_r' r1;subst;cbn in Dqj1.
      + inv Dqj2. cbn. intro N. subst x. eapply path_rcons in Dsk2;eauto.
        eapply tcfg_enroot in Dsk2;eauto. destructH.
        eapply tpath_NoDup in Dsk2.
        eapply NoDup_app with (a:=(q1,j1)).
        * rewrite <-app_assoc in Dsk2. eapply Dsk2.
        * rewrite app_comm_cons. eapply In_rcons. left. auto.
        * cbn. left. auto.
      + cbn. rewrite rev_rcons. cbn.
        eapply disjoint2;eauto.
  Qed.

  Lemma s_deq_q
    : deq_loop s q1.
  Proof.
    clear Hjle.
    eapply diamond_split in D. eapply spath_s_deq_q;eauto.
  Qed.

  Lemma no_head_inst (h : Lab) (l : Tag)
        (Hcont : innermost_loop h q1)
        (Hel : (h,l) ∈ r1)
    : False.
  Proof.
    eapply diamond_split in D. eapply spath_no_head_inst;eauto.
  Qed.

  Lemma no_back : forall x : Lab, x ∈ (map fst r1) -> ~ loop_contains x q1.
  Proof. (* Hjle needed *)
    eapply diamond_split in D. eapply spath_no_back;eauto.
  Qed.

End disj.

Lemma r1_incl_head_q `(D : DiamondPaths)
  : forall x, x ∈ map fst r1 -> deq_loop x q1.
Proof.
  eapply diamond_split in D.
  eapply spath_r1_incl_head_q. eassumption.
Qed.

Lemma r2_incl_head_q `(D : DiamondPaths)
  : forall x, x ∈ map fst r2 -> deq_loop x q1.
Proof.
  eapply diamond_split in D.
  eapply spath_r2_incl_head_q. eassumption.
Qed.

Lemma tag_eq1 `(D : DiamondPaths)
      (Hjle : j1 ⊴ j2)
  : forall j, j ∈ map snd r1 -> take_r (depth q1) j = j1.
Proof.
  eapply diamond_split in D.
  eapply spath_tag_eq1;eauto.
Qed.

  Lemma tag_eq_kj1 `(D : DiamondPaths)
        (Hjle : j1 ⊴ j2)
    : take_r (depth q1) k = j1.
  Proof.
    destruct r1;inv_Dpaths D.
    - rewrite take_r_geq;eauto. rewrite Dlen. eauto.
    - assert (l1 ∈ map snd ((q1,j1) :: r1)) as Hin.
      {
        destruct D. inv_path Dpath1. eapply path_contains_back in H.
        eapply in_map with (f:=snd) in H. unfold snd in H at 1. eauto.
      }
      assert (depth q1 <= | k |) as Hdep.
      {
        erewrite Dlen. eapply deq_loop_depth. eapply s_deq_q;eauto.
      }
      specialize (tcfg_edge_destruct' Dsk1) as Dsk1.
      destruct Dsk1 as [H|[H|[H|H]]].
      all: destruct H as [Htag Hedge].
      + rewrite <-Htag. eapply tag_eq1;eauto.
      + destruct l1;[congruence|]. inv Htag.
        setoid_rewrite <-tag_eq1 at 3. 2,3,4:eauto.
        rewrite take_r_cons_drop;eauto.
      + decide (loop_contains u1 q1).
        * exfalso.
          eapply no_back;eauto.
          destruct D. inv_path Dpath1. eapply path_contains_back in H.
          eapply in_map with (f:=fst) in H. cbn in H. cbn. eauto.
        * setoid_rewrite <-tag_eq1 at 3. 2,3,4:eauto.
          destruct k;[exfalso|].
          {
            cbn in *. eapply loop_contains_ledge in Hedge. eapply loop_contains_depth_lt in Hedge.
            destruct D. cbn in Dlen. lia.
          }
          assert (depth q1 < depth u1) as Hlt.
          {
            eapply le_lt_or_eq in Hdep.
            destruct Hdep.
            - cbn in H. cbn in Htag. eapply u_len1 in D. rewrite Htag in D. cbn in D. lia.
            - exfalso. eapply n. cbn in *. eapply u_len1 in D as Hlen. rewrite Htag in Hlen.
              cbn in Hlen.
              eapply deq_loop_head_loop_contains.
              + eapply deq_loop_depth_eq. eapply r1_incl_head_q;eauto. 2:lia.
                destruct D. inv_path Dpath1. eapply path_contains_back in H0.
                eapply in_map with (f:=fst) in H0. cbn in *. eauto.
              + eexists;eauto.
          }
          destruct l1;[cbn in *;congruence|]. inv Htag.
          erewrite take_r_cons_replace;eauto.
          eapply back_edge_eq_loop in Hedge. rewrite <-Hedge in Hlt. cbn in Hdep.
          destruct D. cbn in Dlen. lia.
      + setoid_rewrite <-tag_eq1 at 3. 2-4:eauto.
        destruct k;[exfalso|].
        * destruct D. cbn in Dlen. eapply depth_exit in Hedge. lia.
        * cbn. cbn in Htag.
          erewrite take_r_cons_drop.
          -- subst. reflexivity.
          -- eapply u_len1 in D as Hlen. subst k. rewrite Hlen. eapply deq_loop_depth.
             eapply r1_incl_head_q;eauto.
             destruct D. inv_path Dpath1. eapply path_contains_back in H.
             eapply in_map with (f:=fst) in H. cbn in *. eauto.
  Qed.

  Lemma k_eq_j `(D : DiamondPaths)
        (Hdeq : deq_loop q1 s)
        (Hjle : j1 ⊴ j2)
    : k = j1.
  Proof.
    rewrite <-take_r_geq at 1. eapply tag_eq_kj1;eauto. erewrite Dlen.
    eapply deq_loop_depth. eauto.
  Qed.

  Section disj_eqdep.
    Context `(C : redCFG).
    Variables (s u1 u2 p1 p2 q1 q2 : Lab)
              (k i l1 l2 j1 j2 : Tag)
              (r1 r2 : list (Lab * Tag)).
    Hypothesis (Hdeq : deq_loop q1 s).
    Hypothesis (Hjle : j1 ⊴ j2).

    Lemma lj_eq1 (D : DiamondPaths s u1 u2 p1 p2 q1 q2 k i l1 l2 j1 j2 ((q1,j1) :: r1) r2)
      : l1 = j1 \/ (l1 = 0 :: j1 /\ loop_head u1).
    Proof. (* Hjle needed *)
      specialize (tcfg_edge_destruct' Dsk1) as Dsk1.
      destruct Dsk1 as [Dsk1|[Dsk1|[Dsk1|Dsk1]]].
      all: destruct Dsk1 as [Htag Hedge].
      - left. rewrite Htag. eapply k_eq_j;eauto.
      - right. rewrite Htag. split.
        + f_equal. eapply k_eq_j;eauto.
        + destruct Hedge. eauto.
      - exfalso. eapply no_back;eauto;cycle 1.
        + eapply loop_contains_ledge in Hedge. eapply Hdeq in Hedge. eauto.
        + destruct D. inv_path Dpath1. eapply path_contains_back in H.
          eapply in_map with (f:=fst) in H. unfold fst in H at 1. eauto.
      - exfalso. destruct Hedge. eapply exit_not_deq in H;eauto.
        eapply eq_loop_exiting in H. rewrite H. transitivity q1;eauto.
        eapply r1_incl_head_q;eauto.
        destruct D. inv_path Dpath1. eapply path_contains_back in H0.
        eapply in_map with (f:=fst) in H0. unfold fst in H0 at 1. eauto.
    Qed.

    Lemma lj_eq2 (D : DiamondPaths s u1 u2 p1 p2 q1 q2 k i l1 l2 j1 j2 r1 ((q2,j2) :: r2))
      : l2 = j1 \/ (l2 = 0 :: j1 /\ loop_head u2) \/ loop_contains u2 q1.
    Proof. (* Hjle needed *)
      specialize (tcfg_edge_destruct' Dsk2) as Dsk2.
      destruct Dsk2 as [Dsk1|[Dsk1|[Dsk1|Dsk1]]].
      all: destruct Dsk1 as [Htag Hedge].
      - left. rewrite Htag. eapply k_eq_j;eauto.
      - right. left. rewrite Htag. split.
        + f_equal. eapply k_eq_j;eauto.
        + destruct Hedge. eauto.
      - right. right. eapply loop_contains_ledge in Hedge. eapply Hdeq;eauto.
      - exfalso. destruct Hedge. eapply exit_not_deq in H;eauto.
        eapply eq_loop_exiting in H. rewrite H. transitivity q1;eauto.
        eapply r2_incl_head_q;eauto.
        destruct D. inv_path Dpath2. eapply path_contains_back in H0.
        eapply in_map with (f:=fst) in H0. unfold fst in H0 at 1. eauto.
    Qed.

  End disj_eqdep.

Lemma no_back2 `(D : DiamondPaths)
      (Htageq : j1 = j2)
  : forall x : Lab, x ∈ (map fst r2) -> ~ loop_contains x q1.
Proof.
  setoid_rewrite Dloop.
  eapply no_back.
  - eapply DiamondPaths_sym;eauto.
  - subst. reflexivity.
Qed.

Lemma u1_deq_q `(D : DiamondPaths)
      (Hnnil : r1 <> [])
  : deq_loop u1 q1.
Proof.
  eapply r1_incl_head_q;eauto.
  destruct r1;[contradiction|].
  destruct D.
  inv_path Dpath1.
  eapply path_contains_back in H.
  fold (fst (u1,l1)).
  eapply in_map;eauto.
Qed.

Lemma u2_deq_q `(D : DiamondPaths)
      (Hnnil : r2 <> [])
  : deq_loop u2 q1.
Proof.
  rewrite Dloop.
  eapply u1_deq_q;eauto using DiamondPaths_sym.
Qed.

Lemma diamond_teq `(C : redCFG)
      (s u1 u2 p1 p2 q1 q2 : Lab) (k i l1 l2 j1 j2 : Tag) r1 r2
      (Hdeq : deq_loop q1 s)
      (Hjle : j1 ⊴ j2)
      (D : DiamondPaths s u1 u2 p1 p2 q1 q2 k i l1 l2 j1 j2 ((q1,j1) :: r1) ((q2,j2) :: r2))
  : TeqPaths u1 u2 q1 q2 l1 l2 j1 j2 (r1) (r2).
Proof.
  copy D D'.
  destruct D.
  inv_path Dpath1. inv_path Dpath2.
  econstructor; eauto using tl_eq, lj_eq1, lj_eq2, jj_len, j_len1.
  eapply diamond_split in D'. do 4 eexists.
  split_conj;eauto.
  1,2: econstructor.
Qed.

Lemma diamond_qj_eq1 `(C : redCFG) s u1 u2 p1 p2 q1 q2 k i l1 l2 j1 j2 qj1 r1 r2
      (D : DiamondPaths s u1 u2 p1 p2 q1 q2 k i l1 l2 j1 j2 (qj1 :: r1) r2)
  : qj1 = (q1,j1).
Proof.
  destruct D. cbn in Dqj1. auto.
Qed.

Lemma diamond_qj_eq2 `(C : redCFG) s u1 u2 p1 p2 q1 q2 k i l1 l2 j1 j2 qj2 r1 r2
      (D : DiamondPaths s u1 u2 p1 p2 q1 q2 k i l1 l2 j1 j2 r1 (qj2 :: r2))
  : qj2 = (q2,j2).
Proof.
  destruct D. cbn in Dqj2. auto.
Qed.


From Hammer Require Import Hammer.

From compcert Require Import Coqlib.
From compcert Require Import Maps.
From compcert Require Import AST.
From compcert Require Import Values.
From compcert Require Import Memory.
From compcert Require Import Op.
From compcert Require Import Registers.
From compcert Require Import RTL.

Definition valnum := positive.

Inductive rhs : Type :=
| Op: operation -> list valnum -> rhs
| Load: memory_chunk -> addressing -> list valnum -> rhs.

Inductive equation : Type :=
| Eq (v: valnum) (strict: bool) (r: rhs).

Definition eq_valnum: forall (x y: valnum), {x=y}+{x<>y} := peq.

Definition eq_list_valnum: forall (x y: list valnum), {x=y}+{x<>y} := list_eq_dec peq.

Definition eq_rhs (x y: rhs) : {x=y}+{x<>y}.
Proof. hammer_hook "CSEdomain" "CSEdomain.eq_rhs".
generalize chunk_eq eq_operation eq_addressing eq_valnum eq_list_valnum.
decide equality.
Defined.

Record numbering : Type := mknumbering {
num_next: valnum;
num_eqs: list equation;
num_reg: PTree.t valnum;
num_val: PMap.t (list reg)
}.

Definition empty_numbering :=
{| num_next := 1%positive;
num_eqs  := nil;
num_reg  := PTree.empty _;
num_val  := PMap.init nil |}.

Definition valnums_rhs (r: rhs): list valnum :=
match r with
| Op op vl => vl
| Load chunk addr vl => vl
end.

Definition wf_rhs (next: valnum) (r: rhs) : Prop :=
forall v, In v (valnums_rhs r) -> Plt v next.

Definition wf_equation (next: valnum) (e: equation) : Prop :=
match e with Eq l str r => Plt l next /\ wf_rhs next r end.

Record wf_numbering (n: numbering) : Prop := {
wf_num_eqs: forall e,
In e n.(num_eqs) -> wf_equation n.(num_next) e;
wf_num_reg: forall r v,
PTree.get r n.(num_reg) = Some v -> Plt v n.(num_next);
wf_num_val: forall r v,
In r (PMap.get v n.(num_val)) -> PTree.get r n.(num_reg) = Some v
}.

Hint Resolve wf_num_eqs wf_num_reg wf_num_val: cse.

Definition valuation := valnum -> val.

Inductive rhs_eval_to (valu: valuation) (ge: genv) (sp: val) (m: mem):
rhs -> val -> Prop :=
| op_eval_to: forall op vl v,
eval_operation ge sp op (map valu vl) m = Some v ->
rhs_eval_to valu ge sp m (Op op vl) v
| load_eval_to: forall chunk addr vl a v,
eval_addressing ge sp addr (map valu vl) = Some a ->
Mem.loadv chunk m a = Some v ->
rhs_eval_to valu ge sp m (Load chunk addr vl) v.

Inductive equation_holds (valu: valuation) (ge: genv) (sp: val) (m: mem):
equation -> Prop :=
| eq_holds_strict: forall l r,
rhs_eval_to valu ge sp m r (valu l) ->
equation_holds valu ge sp m (Eq l true r)
| eq_holds_lessdef: forall l r v,
rhs_eval_to valu ge sp m r v -> Val.lessdef v (valu l) ->
equation_holds valu ge sp m (Eq l false r).

Record numbering_holds (valu: valuation) (ge: genv) (sp: val)
(rs: regset) (m: mem) (n: numbering) : Prop := {
num_holds_wf:
wf_numbering n;
num_holds_eq: forall eq,
In eq n.(num_eqs) -> equation_holds valu ge sp m eq;
num_holds_reg: forall r v,
n.(num_reg)!r = Some v -> rs#r = valu v
}.

Hint Resolve num_holds_wf num_holds_eq num_holds_reg: cse.

Lemma empty_numbering_holds:
forall valu ge sp rs m,
numbering_holds valu ge sp rs m empty_numbering.
Proof. hammer_hook "CSEdomain" "CSEdomain.empty_numbering_holds".
intros; split; simpl; intros.
- split; simpl; intros.
+ contradiction.
+ rewrite PTree.gempty in H; discriminate.
+ rewrite PMap.gi in H; contradiction.
- contradiction.
- rewrite PTree.gempty in H; discriminate.
Qed.


Require Export Qual.metalib.
Require Export Qual.grade.
Require Export Qual.geq.

Set Implicit Arguments.
Open Scope grade_scope.

Lemma CDefEq_DefEq_Grade :
  (forall P psi phi a b, CDefEq P psi phi a b -> CGrade P psi phi a /\ CGrade P psi phi b) /\
  (forall P psi a b, DefEq P psi a b -> Grade P psi a /\ Grade P psi b).
Proof.
  apply CDefEq_DefEq_mutual.
  all: intros; split; split_hyp; eauto.
  all: try solve [eauto using leq_join_r ].
  all: try solve [repeat invert_Grade; subst; eauto].
  all: try solve [fresh_apply_Grade x; auto;
    repeat spec x; split_hyp; eauto].
  all: try solve [repeat invert_Grade; subst;
    pick fresh x; repeat spec x;
    eapply Grade_open; eauto using leq_join_r].

  all: try solve [pick fresh x;
  repeat spec x;
  split_hyp;
  eapply Grade_open_irrel with (y := x); eauto].

Qed.

Lemma DefEq_Grade : forall P psi a b, DefEq P psi a b -> Grade P psi a /\ Grade P psi b.
Proof. apply  CDefEq_DefEq_Grade. Qed.

Lemma DefEq_Grade1 : forall {W psi a b}, DefEq W psi a b -> Grade W psi a.
eapply DefEq_Grade; auto. Qed.
Lemma DefEq_Grade2 : forall {W psi a b}, DefEq W psi a b -> Grade W psi b.
eapply DefEq_Grade; auto. Qed.

Lemma CEqGEq_DefEq :
  (forall P phi phi0 a b, CEq P phi phi0 a b -> CDefEq P phi phi0 a b) /\
  (forall P phi a b, GEq P phi a b -> DefEq P phi a b).
Proof.
  eapply CEq_GEq_mutual.
  all: intros; eauto 3.
Qed.

Lemma CDefEq_substitution1 : forall P2 x psi0 P1 psi a a1 a2,
  Grade (P2 ++ [(x, psi0)] ++ P1) psi a ->
  CDefEq P1 psi psi0 a1 a2 ->
  Grade (P2 ++ P1) psi (subst_tm_tm a1 x a).
Proof.
  intros.
  inversion H0; subst.
  eapply Grade_substitution_same; eauto using DefEq_Grade1.
  eapply Grade_substitution_irrel; eauto using DefEq_lc1.
Qed.

Lemma CDefEq_substitution2 : forall P2 x psi0 P1 psi a a1 a2,
  Grade (P2 ++ [(x, psi0)] ++ P1) psi a ->
  CDefEq P1 psi psi0 a1 a2 ->
  Grade (P2 ++ P1) psi (subst_tm_tm a2 x a).
Proof.
  intros.
  inversion H0; subst.
  eapply Grade_substitution_same; eauto using DefEq_Grade2.
  eapply Grade_substitution_irrel; eauto using DefEq_lc2.
Qed.

Parameter star : sort.

Lemma DefEq_equality_substitution : (forall P phi b1 b2,
  DefEq P phi b1 b2 -> forall P1 x psi,
        P = [(x,psi)] ++ P1
       -> forall a1 a2, DefEq P1 phi a1 a2
       -> psi <= phi
       -> DefEq P1 phi (subst_tm_tm a1 x b1) (subst_tm_tm a2 x b2)).
Proof.
  intros.
  subst.
  move: (DefEq_uniq H) => h. destruct_uniq.
  have RE: DefEq P1 phi (a_Pi psi (a_Type star) (close_tm_wrt_tm x b1))
                        (a_Pi psi (a_Type star) (close_tm_wrt_tm x b2)).
  + pick fresh y and apply Eq_Pi. eapply Eq_Refl; eauto.
    rewrite <- subst_tm_tm_spec.
    rewrite <- subst_tm_tm_spec.
    eapply DefEq_substitution_same with (P2 := nil) (P1 := [(y,phi)] ++ P1).
    2: { simpl_env; eauto. }
    eapply DefEq_weakening_middle; eauto.
    eapply G_Var with (psi0:=phi); auto. reflexivity.
  + rewrite subst_tm_tm_spec.
    rewrite subst_tm_tm_spec.
    eapply Eq_PiSnd; eauto.
Qed.

Lemma DefEq_substitution_irrel2 : (forall P phi b1 b2,
  DefEq P phi b1 b2 -> forall P1 x psi,
        P = [(x,psi)] ++ P1
       -> not (psi <= phi)
       -> forall a1 a2, lc_tm a1 -> lc_tm a2
       -> DefEq P1 phi (subst_tm_tm a1 x b1) (subst_tm_tm a2 x b2)).
Proof.
  intros. subst.
  move: (DefEq_uniq H) => u. destruct_uniq.
  rewrite subst_tm_tm_spec.
  rewrite subst_tm_tm_spec.
  pick fresh y and apply Eq_SubstIrrel; eauto 2.
  eapply (@DefEq_renaming x). repeat rewrite fv_tm_tm_close_tm_wrt_tm. fsetdec.
  repeat rewrite fv_tm_tm_close_tm_wrt_tm. fsetdec.
  rewrite open_tm_wrt_tm_close_tm_wrt_tm.
  rewrite open_tm_wrt_tm_close_tm_wrt_tm.
  auto.
Qed.


From Coq Require Import List FinFun.

From CasperCBC
  Require Import
    Lib.Preamble
    Lib.Traces
    Lib.Measurable
    VLSM.Common
    VLSM.Decisions
    VLSM.Composition
    VLSM.Equivocation. (* for has_been_sent *)

(** * VLSM Liveness *)

(**
 A composite VLSM is live if every complete trace reaches a [decision].
*)

(**
   This module defines liveness, and contains basic defintiions
   that will be used for proving liveness properties,
   constructing protocols designed for liveness, and
   stating the assumptions under which those protocols are live.
 *)

(** ** Liveness definitions *)

Section Liveness.

  Context
    {CV : consensus_values}
    {message : Type}
    {index : Type}
    {Heqd : EqDecision index}
    (IM : index -> VLSM message)
    {Hi : Inhabited index}
    (constraint : composite_label IM -> composite_state IM * option message -> Prop)
    (X := composite_vlsm IM constraint)
    (ID : forall i : index, vdecision (IM i)).

Definition live : Prop :=
  forall
    (tr : Trace)
    (Htr: complete_trace_prop X tr),
  exists
    (n : nat)
    (i : index)
    (st : vstate X),
    trace_nth tr n = (Some st)
    /\ (ID i) (st i) <> None.

End Liveness.

(** ** Clocks

Liveness always requires some notion of time, and assumptions
that messages are not infinitely delayed.

We will use logical clocks that assign states and
messages to times in [nat], with messages carrying the
time from the sending component, and messages only
expected to be received by a node at the matching time.
 *)

Section Clocks.

  (** A clock for a VLSM assigns a time to any state, and is
      nondecreasing on transitions.
   *)
  Record ClockFor `(X:VLSM message) : Type := {
    clock : vstate X -> nat;
    clock_monotone : forall l s om s' om',
        vtransition X l (s,om) = (s',om') -> clock s <= clock s';
    }.

  (** For a composite VLSM we usually want to have a separate
      clock for each component
   *)
  Definition ClocksFor `(IM:index -> VLSM message) : Type :=
    forall i, ClockFor (IM i).

  (** A message time function is consistent with a
      set of clocks for a composite VLSM if
      the message time always agrees with the time
      of the sending component at the begining of
      the transition where the message is sent.
   *)
  Record MessageTimeProp
        `(IM: index -> VLSM message) `{EqDecision index} `{Inhabited index} constraint
        (X := composite_vlsm IM constraint)
        (clocks : ClocksFor IM)
        (message_time : message -> nat)
    : Type := {
    message_time_accurate :
      forall m t,
        message_time m = t
        <-> (forall (l:vlabel X) s om l s',
             vtransition X l (s,om) = (s', Some m) -> clock _ (clocks _) (s (projT1 l)) = t)
             }.

End Clocks.

(** ** Plans

Protocols may be designed so that only a subset of validators
are expected to send messages in each phase.

Our example protocol will use a fixed that specifies the
expected set of senders for each time.
Here we define the conditions that such a fixed plan will
need to satisfy.

Later protocols will dyanmically construct plans to
react to failures, and we will need to generalize
these properties to apply to dynamic plans.
 *)
Section Plan.
  Context
    (index: Type)
    {Hweights: Measurable index}
    {index_listing: list index}
    {Hfinite: FinFun.Listing index_listing}
  .

  (** An "odd" set cannot be partitioned into
      two disjoint pieces with equal weight,
      so votes cannot have ties *)
  Definition odd_set (P: index -> Prop) : Prop :=
    forall l1 l2,
      (forall i, P i <-> (In i l1 \/ In i l2)) ->
      NoDup (l1++l2) ->
      sum_weights l1 <> sum_weights l2.

  Record Plan (plan: nat -> index -> Prop) := {
    stages_nonempty : forall n, ~forall v, ~plan n v;
    plan_has_odd_stage: exists n, odd_set (plan n);
    recurring_sends: forall n v, exists n', n' > n /\ plan n' v;
    }.
End Plan.

(** ** Synchrony Constraints

Synchrony assumptions will be expresed with composition constraints.

Currently we define only a strong assumption that doesn't allow
any messages to be delayed, which will be used for example proofs of
liveness.

Definitions allowing a limited rate of "synchronization faults" will
be added before verifying more robust protocols over more realistic
assumptions.
 *)
Section StrongSynchrony.
  Context
    {message : Type}
    {index : Type}
    {index_listing : list index}
    (finite_index : Listing index_listing)
    {Heqd : EqDecision index}
    (IM : index -> VLSM message)
    {Hi : Inhabited index}
    (constraint : composite_label IM -> composite_state IM * option message -> Prop)
    {Hsents : forall i, has_been_sent_capability (IM i)}
    {Hobserveds: forall i, has_been_observed_capability (IM i)}
    (clocks : ClocksFor IM)
    (message_time : message -> nat)
  .

  (** This portion of a constraint ensures that messages are received only
      by components at the proper time.

      Perhaps this condition should be added to [MessageTimeProp] and
      required as a property of the components in [IM] rather than
      imposed as a composition constraint.
   *)
  Definition delivery_time_constraint :
    composite_label IM -> composite_state IM * option message -> Prop
    := fun l som =>
         let (i,_) := l in
         let (s,om) := som in
         match om with
         | Some m => message_time m = clock _ (clocks i) (s i)
         | None => True
         end.

  Definition all_earlier_messages_received (i:index) (s:composite_state IM) : Prop :=
    forall msg, (exists (j:index), has_been_sent (IM j) (s j) msg) ->
                message_time msg <= clock _ (clocks i) (s i) ->
                has_been_observed (IM i) (s i) msg.

  (** This portion of a constraint prevents a component from advancing its clock
      if it has not received all oustanding messages from the time
      it is leaving.

      N.B. As written, this does not prevent the possiblity that some
      other component which is still in the earlier time hasn't even
      sent a message yet. Combined with the use of [lt] in
      [all_earlier_messages_received], and the [delivery_time_constraint],
      this component would never be able to advance its clock again
      after such a "late send".
   *)
  Definition timely_reception_constraint:
    composite_label IM -> composite_state IM * option message -> Prop
    := fun l som =>
         let (i,l_i) := l in
         let (s,om) := som in
         let (s',_) := vtransition (IM i) l_i (s i,om) in
         clock _ (clocks i) (s i) < clock _ (clocks i) s'
         -> all_earlier_messages_received i s.

  Context
    (Free := free_composite_vlsm IM)
    (composite_has_been_sent_capability : has_been_sent_capability Free := composite_has_been_sent_capability IM (free_constraint IM) finite_index Hsents)
    .

  Existing Instance composite_has_been_sent_capability.

  (** This strong constraint allows no equivocations and
      no failures of synchrony.
   *)
  Definition no_synch_faults_no_equivocation_constraint :
    composite_label IM -> composite_state IM * option message -> Prop
    := fun l som =>
         no_equivocations Free l som
         /\ delivery_time_constraint l som
         /\ timely_reception_constraint l som.

End StrongSynchrony.


Load LFindLoad.
Load LFindLoad.
From adtind Require Import goal29.

From lfind Require Import LFind.
Lemma lfind_state  (x:lst):@eq lst (rev (qreva x Nil)) x.
Admitted.
From QuickChick Require Import QuickChick.
QCInclude "/home/yousef/lemmafinder/benchmark/_lfind_clam_lf_goal29_theorem0_97_rev_qreva_nil/".
QCInclude ".".
Extract Constant defNumTests => "50".
Derive Show for lst.

              Derive Arbitrary for lst.

              Instance Dec_Eq_lst : Dec_Eq lst.

              Proof. dec_eq. Qed.

Open Scope string_scope.

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