(** This file proves the third isomorphism theorem,
    [isomorphic_third_isomorphism]. *)
Require Import
  HoTT.Types.Universe
  HoTT.HIT.quotient
  HoTT.Classes.interfaces.canonical_names
  HoTTClasses.theory.ua_quotient_algebra
  HoTTClasses.theory.ua_isomorphic
  HoTTClasses.theory.ua_first_isomorphism.

Import algebra_notations quotient_algebra_notations isomorphic_notations.

(** This section defines the quotient [cong_quotient] of two
    congruences [Φ] and [Ψ], where [Ψ] is a subcongruence of [Φ].
    It is shown that [cong_quotient] is a congruence. *)

Section cong_quotient.
  Context
    `{Univalence}
    {σ : Signature} {A : Algebra σ}
    (Φ : ∀ s, relation (A s)) `{!IsCongruence A Φ}
    (Ψ : ∀ s, relation (A s)) `{!IsCongruence A Ψ}
    (subrel : ∀ (s : Sort σ) (x y : A s), Ψ s x y → Φ s x y).

  Definition cong_quotient (_ : ∀ s x y, Ψ s x y → Φ s x y)
    (s : Sort σ) (a b : (A/Ψ) s)
    := ∀ (x y : A s), in_class (Ψ s) a x → in_class (Ψ s) b y → Φ s x y.

  Global Instance equivalence_relation_quotient (s : Sort σ)
    : EquivRel (cong_quotient subrel s).
  Proof.
    constructor.
    - refine (quotient_ind_prop (Ψ s) _ _). intros x y z P Q.
      apply subrel.
      by transitivity x.
    - refine (quotient_ind_prop (Ψ s) _ _). intro x1.
      refine (quotient_ind_prop (Ψ s) _ _). intros x2 C y1 y2 P Q.
      symmetry.
      by apply C.
    - refine (quotient_ind_prop (Ψ s) _ _). intro x1.
      refine (quotient_ind_prop (Ψ s) _ _). intro x2.
      refine (quotient_ind_prop (Ψ s) _ _). intros x3 C D y1 y2 P Q.
      transitivity x2.
      + exact (C y1 x2 P (EquivRel_Reflexive x2)).
      + exact (D x2 y2 (EquivRel_Reflexive x2) Q).
  Defined.

  Lemma for_all_relation_quotient {w : list (Sort σ)} (a b : FamilyProd A w)
    : for_all_2_family_prod (A/Ψ) (A/Ψ) (cong_quotient subrel)
        (map_family_prod (λ s, class_of (Ψ s)) a)
        (map_family_prod (λ s, class_of (Ψ s)) b) →
      for_all_2_family_prod A A Φ a b.
  Proof.
    intro F. induction w; cbn in *.
    - constructor.
    - destruct a as [x a], b as [y b], F as [Q F].
      split.
      + apply Q; cbn; reflexivity.
      + by apply IHw.
  Qed.

  Global Instance ops_compatible_quotient
    : OpsCompatible (A/Ψ) (cong_quotient subrel).
  Proof.
    intros u.
    refine (quotient_ind_prop_family_prod A Ψ _ _). intro a.
    refine (quotient_ind_prop_family_prod A Ψ _ _). intro b.
    (* It should not be necessary to provide the explicit types: *)
    destruct (compute_op_quotient A Ψ u a
              : ap_operation (u^^A / Ψ)
                 (map_family_prod (λ s, class_of (Ψ s)) _) = _)^.
    destruct (compute_op_quotient A Ψ u b
              : ap_operation (u^^A / Ψ)
                 (map_family_prod (λ s, class_of (Ψ s)) _) = _)^.
    intros R x y P Q.
    apply subrel in P.
    apply subrel in Q.
    transitivity (ap_operation (u^^A) a).
    - by symmetry.
    - transitivity (ap_operation (u^^A) b); try assumption.
      apply (ops_compatible A Φ u).
      by apply for_all_relation_quotient.
  Defined.

  Global Instance is_congruence_quotient
    : IsCongruence (A/Ψ) (cong_quotient subrel)
    := BuildIsCongruence (A/Ψ) (cong_quotient subrel).

End cong_quotient.

Section third_isomorphism.
  Context
    `{Univalence}
    {σ : Signature} {A : Algebra σ}
    (Φ : ∀ s, relation (A s)) `{!IsCongruence A Φ}
    (Ψ : ∀ s, relation (A s)) `{!IsCongruence A Ψ}
    (subrel : ∀ (s : Sort σ) (x y : A s), Ψ s x y → Φ s x y).

  Lemma third_surjecton_well_def (s : Sort σ)
    (x y : A s) (P : Ψ s x y)
    : class_of (Φ s) x = class_of (Φ s) y.
  Proof.
    apply related_classes_eq. exact (subrel s x y P).
  Defined.

  Definition def_third_surjection (s : Sort σ) : (A/Ψ) s → (A/Φ) s
    := quotient_rec (Ψ s) (class_of (Φ s)) (third_surjecton_well_def s).

  Lemma oppreserving_third_surjection {w : SymbolType σ} (f : Operation A w)
    : ∀ (α : Operation (A/Φ) w) (Qα : ComputeOpQuotient A Φ f α)
        (β : Operation (A/Ψ) w) (Qβ : ComputeOpQuotient A Ψ f β),
      OpPreserving def_third_surjection β α.
  Proof.
    induction w.
    - refine (quotient_ind_prop (Φ t) _ _). intros α Qα.
      refine (quotient_ind_prop (Ψ t) _ _). intros β Qβ.
      apply related_classes_eq.
      transitivity f.
      + apply subrel. apply (classes_eq_related (Ψ t)). exact (Qβ tt).
      + apply (classes_eq_related (Φ t)). symmetry. exact (Qα tt).
    - intros α Qα β Qβ.
      refine (quotient_ind_prop (Ψ t) _ _).
      intro x.
      exact (IHw (f x) (α (class_of (Φ t) x)) (λ a, Qα (x,a))
               (β (class_of (Ψ t) x)) (λ a, Qβ (x,a))).
  Defined.

 Global Instance is_homomorphism_third_surjection
    : IsHomomorphism def_third_surjection.
  Proof.
    intro u.
    eapply oppreserving_third_surjection; apply compute_op_quotient.
  Defined.

  Definition hom_third_surjection : Homomorphism (A/Ψ) (A/Φ)
    := BuildHomomorphism def_third_surjection.

  Global Instance surjection_third_surjection (s : Sort σ)
    : IsSurjection (hom_third_surjection s).
  Proof.
    apply BuildIsSurjection.
    refine (quotient_ind_prop (Φ s) _ _).
    intro x.
    apply tr.
    by exists (class_of (Ψ s) x).
  Qed.

  Local Notation Θ := (cong_quotient Φ Ψ subrel).

  Lemma path_quotient_algebras_third_surjection
    : A/Ψ / cong_ker hom_third_surjection = A/Ψ / Θ.
  Proof.
    apply path_quotient_algebra_iff. intros s x y.
    split; generalize dependent y; generalize dependent x;
           refine (quotient_ind_prop (Ψ s) _ _); intro x;
           refine (quotient_ind_prop (Ψ s) _ _); intro y.
    - intros K x' y' Cx Cy.
      apply subrel in Cx. apply subrel in Cy.
      apply (classes_eq_related (Φ s)) in K.
      transitivity x.
      + by symmetry.
      + by transitivity y.
    - intro T.
      apply related_classes_eq.
      exact (T x y (EquivRel_Reflexive x) (EquivRel_Reflexive y)).
  Defined.

  Definition hom_third_isomorphism : Homomorphism (A/Ψ/Θ) (A/Φ)
    := transport (λ X, Homomorphism X (A/Φ))
          path_quotient_algebras_third_surjection
          (hom_first_isomorphism_surjection hom_third_surjection).

  Theorem is_isomorphism_third_isomorphism
    : IsIsomorphism hom_third_isomorphism.
  Proof.
    unfold hom_third_isomorphism.
    destruct path_quotient_algebras_third_surjection.
    exact _.
  Qed.

  Global Existing Instance is_isomorphism_third_isomorphism.

  (** The third isomorphism theorem. *)

  Corollary isomorphic_third_isomorphism : A/Ψ/Θ ≅ A/Φ.
  Proof.
    exact (BuildIsomorphic hom_third_isomorphism).
  Defined.

  Corollary id_third_isomorphism : A/Ψ/Θ = A/Φ.
  Proof.
    exact (id_isomorphic isomorphic_third_isomorphism).
  Defined.
End third_isomorphism.


(* Copyright 2012-2015 by Adam Petcher.				*
 * Use of this source code is governed by the license described	*
 * in the LICENSE file at the root of the source tree.		*)

(* Tactics used to manipulate and reason about distributions corresponding to computations. *)

Set Implicit Arguments.

Require Import FCF.Rat.
Require Import FCF.Comp.
Require Import FCF.DistRules.
Require Import FCF.DistSem.
Require Import FCF.StdNat.
Require Import FCF.Fold.
Require Import FCF.NotationV1.

Local Open Scope rat_scope.
Local Open Scope comp_scope.

Definition leftc := false.
Definition rightc := true.

(* wftac -- A tactic for deciding well-formedness *)
#[export] Hint Resolve posnat_pos : wftac.

Ltac pairInv :=
  match goal with
    | [H : (_, _) = (_, _) |- _] =>
      inversion H; clear H; subst
  end.

Ltac simp_ret :=
  match goal with
    | [H : In _ (getSupport (ret _)) |- _] =>
      simpl in H; intuition; pairInv
  end.

Ltac wftac_one :=
  match goal with
    | [|- well_formed_comp (Bind _ _) ] => eapply well_formed_Bind
    | [|- well_formed_comp (Ret _ _ ) ] => eapply well_formed_Ret
    | [|- well_formed_comp (Rnd _) ] => eapply well_formed_Rnd
    | [|- well_formed_comp (let (_,_) := ?y in _ ) ] => destruct y
    | [|- well_formed_comp (if ?x then _ else _) ] => destruct x
    | [|- @well_formed_oc _ _ _ _ ] => econstructor
  end.

Ltac wftac :=
  repeat (unfold setLet; intuition; eauto with wftac; try simp_ret; wftac_one).

Ltac destructLet_1 :=
  match goal with
    | [|- context[match ?x with | pair _ _ => _ end]] => destruct x
  end.

Ltac destructLet := repeat destructLet_1.

(* tactics *)

Ltac dist_ret_l :=
  match goal with
      | [ |- ?rel (evalDist (Bind (Ret _ _) ?f) _) _ ] =>
        eapply trans; [eapply (@evalDist_left_ident rel _ _ _ _ f); eauto with typeclass_instances | idtac]
  end.

Ltac dist_ret_r :=
  match goal with
      | [ |- ?rel _ (evalDist (Bind (Ret _ _) ?f) _) ] =>
        eapply trans; [idtac | eapply (@evalDist_left_ident (Basics.flip rel) _ _ _ _ f);  eauto with typeclass_instances]
  end.

Ltac dist_simp_1 := unfold setLet; try dist_ret_l; try dist_ret_r; cbv beta iota; destructLet. (* we only want to destruct identifiers, so we must cbv first*)

Ltac dist_simp := repeat dist_simp_1.

Ltac dist_simp_weak_1 := unfold setLet; try dist_ret_l.

Ltac dist_simp_weak := repeat dist_simp_weak_1.

Ltac dist_inline_l :=
  match goal with
      | [ |- ?rel _ _ ] =>
        eapply trans; [ eapply (@evalDist_assoc rel);  eauto with typeclass_instances | idtac]
  end; dist_simp_weak.

Ltac dist_inline_r :=
  match goal with
      | [ |- ?rel _ _ ] =>
        eapply trans; [ idtac | eapply (@evalDist_assoc (Basics.flip rel));  eauto with typeclass_instances]
  end; dist_simp_weak.

Ltac dist_inline s :=
  match s with
    | leftc => dist_inline_l
    | rightc => dist_inline_r
  end.

Ltac dist_ret s :=
  match s with
      | leftc => dist_ret_l
      | rightc => dist_ret_r
  end.

Ltac dist_inline_first_1 := try dist_inline_l; try dist_inline_r.
Ltac dist_inline_first := repeat (dist_simp_weak_1; dist_inline_first_1).

Ltac dist_swap_l :=
  match goal with
    | [ |- ?rel (evalDist (Bind ?c1 (fun x => (Bind ?c2 _))) _) _ ] =>
      eapply trans; [eapply (@evalDist_commute rel _ _ c1 c2); eauto with typeclass_instances | idtac]
  end.

Ltac dist_swap_r :=
  match goal with
    | [ |- ?rel _ (evalDist (Bind ?c1 (fun x => (Bind ?c2 _))) _) ] =>
      eapply trans; [ idtac | eapply (@evalDist_commute (Basics.flip rel) _ _ c1 c2);  eauto with typeclass_instances]
  end; dist_simp_weak.

Ltac dist_swap side :=
  match side with
    | leftc => dist_swap_l
    | rightc => dist_swap_r
  end.

Ltac dist_at_l tac line :=
  match line with
    | O => tac leftc
    | S ?line' => eapply trans; [ eapply rel_seq; intuition; dist_at_l tac line'; eapply refl; eapply eqRat_refl | idtac]
  end; dist_simp_weak.

Ltac dist_at_r tac line :=
  match line with
    | O => tac rightc
    | S ?line' =>
      eapply trans; [idtac |
                     eapply rel_seq; [ intuition | intuition; (dist_at_r tac line'); eapply refl; eapply eqRat_refl] ]
  end; dist_simp.

Ltac dist_at tac side line :=
  match side with
    | leftc => dist_at_l tac (line)%nat
    | rightc => dist_at_r tac (line)%nat
  end.

Ltac dist_skip :=
  eapply evalDist_seq; [ idtac | eauto with typeclass_instances | idtac] ; intuition; subst; dist_simp_weak; intuition.

Ltac dist_irr_l :=
  eapply evalDist_irr_l; [  eauto with typeclass_instances | simpl | idtac] ; intuition; dist_simp_weak.

Ltac dist_irr_r :=
  eapply evalDist_irr_r; [  eauto with typeclass_instances | simpl | idtac] ; intuition; dist_simp_weak.

Lemma eqb_true_False :
  forall (A : Set)(eqd : EqDec A) (a1 a2 : A),
    (eqb a1 a2 = true -> False) ->
    a1 <> a2.

  intuition.
  subst.
  eapply H.
  eapply eqb_refl.

Qed.

Ltac dist_compute_1 :=
  match goal with
    | [H : RatRel ?rel |- ?rel ?x ?x ] => eapply refl
    | [|- context[if ?a then _ else _ ]] => destruct a
    | [H : context[if ?a then _ else _ ] |- _] => destruct a
    | [H : eqb _ _ = true |- _ ] => rewrite eqb_leibniz in H; subst
    | [H : eqb _ _ = true -> False |- _] => apply eqb_true_False in H
    | [H1 : true = ?b -> False, H2 : false = ?b -> False |- _] => destruct b
  end.

Ltac dist_compute_simp := simpl; unfold Fold.sumList; try rewrite <- ratAdd_0_l; try rewrite <- ratAdd_0_r; try rewrite ratMult_1_l; try rewrite ratMult_1_r; try rewrite ratMult_0_r; try rewrite ratMult_0_l.

Ltac dist_compute := repeat
  (dist_compute_simp; try dist_compute_1; try congruence; intuition).

Ltac dist_transitivity :=
  match goal with
    | [|- _ == _] => eapply eqRat_trans
    | [|- _ <= _] => eapply leRat_trans
  end.

Ltac dist_ident_expand_l :=
   dist_transitivity; [try apply eqRat_impl_leRat; symmetry; eapply evalDist_right_ident | idtac].

Ltac dist_ident_expand_r :=
   dist_transitivity; [idtac | eapply evalDist_right_ident].


(* This file only exists because of COQBUG https://github.com/coq/coq/issues/11352:
   The more unfoldable definitions there are, the slower firstorder becomes,
   so we isolate the map goals of Spilling.v into this file where everything is kept
   as abstract as possible, so that firstorder can't unfold too much. *)
Require Import coqutil.Map.Interface coqutil.Map.Properties.

Section LEMMAS.
  Context {K V: Type} {map: map.map K V} {ok: map.ok map}.
  Implicit Types (k : K) (v : V) (m : map).

  Axiom map__split_spec: forall (M A B: map),
      map.split M A B <-> forall k,
        (exists v, map.get M k = Some v /\
                   ((map.get A k = Some v /\ map.get B k = None) \/
                    (map.get B k = Some v /\ map.get A k = None))) \/
        (map.get M k = None /\ map.get A k = None /\ map.get B k = None).

  Axiom map__putmany_spec: forall (m1 m2: map) k,
      (exists v, map.get (map.putmany m1 m2) k = Some v /\
                 (map.get m2 k = Some v \/ (map.get m2 k = None /\ map.get m1 k = Some v))) \/
      (map.get (map.putmany m1 m2) k = None /\ map.get m2 k = None /\ map.get m1 k = None).

  Lemma split_stackalloc_1: forall (m2 mSmall mL mCombined mStack0: map),
      map.split m2 mSmall mL ->
      map.split mCombined m2 mStack0 ->
      map.split (map.putmany mSmall mStack0) mSmall mStack0.
  Proof.
    intros.
    rewrite map__split_spec in *.
    pose proof map__putmany_spec mSmall mStack0.
    intro k.
    repeat match goal with
           | H: forall _, _ |- _ => specialize (H k)
           end.
    firstorder congruence.
  Qed.

  Lemma split_stackalloc_2: forall (m2 mSmall mL mCombined mStack0: map),
      map.split m2 mSmall mL ->
      map.split mCombined m2 mStack0 ->
      map.split mCombined (map.putmany mSmall mStack0) mL.
  Proof.
    intros.
    rewrite map__split_spec in *.
    pose proof map__putmany_spec mSmall mStack0.
    intro k.
    repeat match goal with
           | H: forall _, _ |- _ => specialize (H k)
           end.
    firstorder congruence.
  Qed.

  Lemma split_interact_assoc: forall m mKeep mGive m2 mL mReceive m',
      map.split m mKeep mGive ->
      map.split m2 m mL ->
      map.split m' (map.putmany mKeep mL) mReceive ->
      map.split m' (map.putmany mKeep mReceive) mL.
  Proof.
    intros.
    rewrite map__split_spec in *.
    pose proof map__putmany_spec mKeep mL.
    pose proof map__putmany_spec mKeep mReceive.
    intro k.
    repeat match goal with
           | H: forall _, _ |- _ => specialize (H k)
           end.
    firstorder congruence.
  Qed.

  Lemma split_interact_shrink: forall mKeep mL m' mReceive,
      map.split m' (map.putmany mKeep mL) mReceive ->
      map.split (map.putmany mKeep mReceive) mKeep mReceive.
  Proof.
    intros.
    rewrite map__split_spec in *.
    pose proof map__putmany_spec mKeep mL.
    pose proof map__putmany_spec mKeep mReceive.
    intro k.
    repeat match goal with
           | H: forall _, _ |- _ => specialize (H k)
           end.
    firstorder congruence.
  Qed.

  Lemma split_interact:
    forall (m mKeep mGive : map) (frame m2 mL mStack : map),
      map.split m mKeep mGive ->
      map.split m2 m mL ->
      map.split mL mStack frame ->
      map.split m2 (map.putmany mKeep mL) mGive.
  Proof.
    intros.
    rewrite map__split_spec in *.
    pose proof map__putmany_spec mKeep mL.

    (* COQBUG https://github.com/coq/coq/issues/12722
    firstorder congruence.
    fails with "Error: Tactic failure: reversible in 1st order mode." *)

    (* workaround: *)
    intro k.
    repeat match goal with
           | H: forall _, _ |- _ => specialize (H k)
           end.

    firstorder congruence.
  Qed.

End LEMMAS.


Require Import Coq.Lists.List.
Import ListNotations.

Require Import variables.
Require Import states.
Require Import states_fun_rules.
Require Import functions.
Require Import functions_fun_rules.

(* S_DFRS *)

Fixpoint bcheck_function_entries
(l : list (EXP * EXP * ASGMTS * REQUIREMENT))
(IO T OT : list (VNAME * TYPE)) : bool :=
    match l with
    | []     => true
    | h :: t => bvar_consistent_exp (fst (fst (fst h))) IO T
                && bvar_consistent_exp (snd (fst (fst h))) T T
                && bwell_typed_asgmts (snd (fst h)).(asgmts) OT
                && bcheck_function_entries t IO T OT
    end.

Fixpoint bcheck_functions (lf : list FUNCTION)
  (IO T OT : list (VNAME * TYPE)) : bool :=
    match lf with
    | []     => true
    | h :: t => bcheck_function_entries h.(function) IO T OT
                && bcheck_functions t IO T OT
    end.

Definition fun_rules_s_dfrs
(vars : DFRS_VARIABLES) (initial : DFRS_INITIAL_STATE)
(funs : DFRS_FUNCTIONS) : bool :=
  let IO := vars.(I).(svars) ++ vars.(O).(svars) in
  let OT := vars.(O).(svars) ++ vars.(T).(stimers) in
  let IOT := IO ++ vars.(T).(stimers) in
  let IOTgcvar := [vars.(gcvar)] ++
                  map (fun x => ((fst x).(vname), snd x)) IOT
  in
    (bwell_typed_state initial.(s0) IOTgcvar)
    && (bcheck_functions funs.(F) IO vars.(T).(stimers) OT).


From Velus Require Import Common.
From Velus Require Import Operators.
From Velus Require Import Clocks.
From Coq Require Import PArith.

From Coq Require Import List.
Import List.ListNotations.
Open Scope list_scope.

From Velus Require Import CoreExpr.CESyntax.
From Velus Require Import NLustre.NLSyntax.

From Coq Require Import Morphisms.
From Coq Require Import Permutation.

(** * Collecting memory cells *)

(**

  The [memories] function collects the set of variables that will turn
  into heap variables after compilation, ie. variables denoting an
  [fby] equation.

  We (ought to) have the following equivalence:
    [forall x, PS.In x (memories eqs) <-> ~ Is_Variable x eqs]

 *)

Module Type MEMORIES
       (Ids            : IDS)
       (Op             : OPERATORS)
       (Import CESyn   : CESYNTAX     Op)
       (Import Syn     : NLSYNTAX Ids Op CESyn).

  Definition memory_eq (mems: PS.t) (eq: equation) : PS.t :=
    match eq with
    | EqFby x _ _ _ => PS.add x mems
    | _ => mems
    end.

  Definition memories (eqs: list equation) : PS.t :=
    List.fold_left memory_eq eqs PS.empty.

  (** ** Properties *)

  Lemma In_fold_left_memory_eq:
    forall x eqs m,
      PS.In x (fold_left memory_eq eqs m)
      <-> PS.In x (fold_left memory_eq eqs PS.empty) \/ PS.In x m.
  Proof.
    induction eqs as [|eq]; simpl.
    - split; auto.
      intros [Hin|]; auto.
      apply not_In_empty in Hin; contradiction.
    - setoid_rewrite IHeqs; split.
      + intros [?|Hin]; auto.
        destruct eq; simpl; auto.
        apply PS.add_spec in Hin as [|]; auto.
        subst; rewrite PS.add_spec; auto.
      + intros [[?|Hin]|?]; auto.
        * destruct eq; simpl; try (apply not_In_empty in Hin; contradiction).
          apply PS.add_spec in Hin as [|Hin]; try (apply not_In_empty in Hin; contradiction).
          subst; rewrite PS.add_spec; auto.
        * destruct eq; simpl; auto.
          rewrite PS.add_spec; auto.
  Qed.

  Instance List_fold_left_memory_eq_Proper (eqs: list equation) :
    Proper (PS.eq ==> PS.eq) (fold_left memory_eq eqs).
  Proof.
    induction eqs as [|[]]; intros * ?? E; simpl; auto.
    apply IHeqs; rewrite E; reflexivity.
  Qed.

  Lemma in_memories_var_defined:
    forall x eqs,
      PS.In x (memories eqs) ->
      In x (vars_defined eqs).
  Proof.
    unfold memories.
    intros * Hin.
    induction eqs as [|eq]; simpl in *.
    - now apply PSF.empty_iff in Hin.
    - apply In_fold_left_memory_eq in Hin as [Hin|Hin].
      + apply in_app; auto.
      + destruct eq; simpl in Hin;
          try (apply PSF.empty_iff in Hin; contradiction).
        apply PS.add_spec in Hin as [|Hin];
          try (apply PSF.empty_iff in Hin; contradiction).
        subst; simpl; left; auto.
  Qed.

  Lemma in_memories_is_fby:
    forall eqs eq,
      In eq eqs ->
      NoDup (vars_defined eqs) ->
      forall x, In x (var_defined eq) ->
      PS.mem x (memories eqs) = is_fby eq.
  Proof.
    unfold memories.
    induction eqs as [|eq eqs]; simpl; try now intuition.
    intros eq' Hin Hndup ? Hin'.
    apply NoDup_app'_iff in Hndup as (Hndup_eq & Hndup_eqs & Hndup_def).
    destruct Hin as [|Hin].
    - subst eq'.
      assert (PS.mem x (fold_left memory_eq eqs PS.empty) = false).
      { apply PSP.Dec.F.not_mem_iff; intro.
        eapply Forall_forall in Hndup_def; eauto.
        eapply Hndup_def; eauto.
        now apply in_memories_var_defined.
      }
      destruct eq; simpl in *; auto.
      apply In_fold_left_memory_eq.
      right; apply PS.add_spec; intuition.
    - erewrite <-IHeqs; eauto.
      destruct eq; simpl; auto.
      assert (x <> i).
      { intro; subst x.
        eapply Forall_forall in Hndup_def; [|simpl; eauto].
        apply Hndup_def; simpl; eauto.
        unfold vars_defined. rewrite flat_map_concat_map.
        eapply in_concat'; eauto.
        now apply in_map.
      }
      destruct (PS.mem x (fold_left memory_eq eqs PS.empty)) eqn: E.
      + rewrite PS.mem_spec in *.
        rewrite In_fold_left_memory_eq; auto.
      + rewrite <-PSP.Dec.F.not_mem_iff in *.
        rewrite In_fold_left_memory_eq, PS.add_spec, PSF.empty_iff.
        intros [?|[?|?]]; auto.
  Qed.

  Lemma in_memories_filter_is_fby:
    forall x eqs,
      PS.In x (memories eqs) <-> In x (vars_defined (filter is_fby eqs)).
  Proof.
    unfold memories.
    induction eqs as [|eq eqs].
    - split; intro HH; try apply not_In_empty in HH; intuition.
    - destruct eq; simpl; (try now rewrite IHeqs).
      split; intro HH.
      + apply In_fold_left_memory_eq in HH.
        destruct HH as [HH|HH].
        * right; now apply IHeqs.
        * apply PS.add_spec in HH.
          destruct HH as [HH|HH]; subst; auto.
          contradiction (not_In_empty x).
      + apply In_fold_left_memory_eq.
        destruct HH as [HH|HH].
        * rewrite PS.add_spec; intuition.
        * apply IHeqs in HH; now left.
  Qed.

  Remark filter_mem_fst:
    forall A B p (xs: list (ident * (A * B))),
      map fst (filter (fun (x:ident*(A*B)) => PS.mem (fst x) p) xs)
      = filter (fun x => PS.mem x p) (map fst xs).
  Proof.
    induction xs as [|x xs]; auto.
    simpl.
    destruct (PS.mem (fst x) p); simpl;
      now rewrite IHxs.
  Qed.

  Lemma notb_filter_mem_fst:
    forall A B p (xs: list (ident * (A * B))),
      map fst (filter (notb (fun (x:ident*(A*B)) => PS.mem (fst x) p)) xs)
      = filter (notb (fun x => PS.mem x p)) (map fst xs).
  Proof.
    unfold notb; simpl.
    induction xs as [|x xs]; auto; simpl.
    destruct (negb (PS.mem (fst x) p)); simpl;
      now rewrite IHxs.
  Qed.

  Lemma fst_partition_memories_var_defined:
    forall n,
      Permutation
        (map fst (fst (partition
                         (fun x => PS.mem (fst x) (memories n.(n_eqs)))
                         n.(n_vars))))
        (vars_defined (filter is_fby n.(n_eqs))).
  Proof.
    intro n.
    match goal with |- Permutation (map fst (fst (partition ?p ?l))) _ =>
      assert (Permutation (map fst (fst (partition p l)))
                          (map fst (filter p n.(n_vars))))
                      as Hperm by now rewrite fst_partition_filter
    end.
    rewrite Hperm; clear Hperm.
    match goal with |- context[filter ?p ?l] =>
      rewrite <-(app_nil_r (filter p l))
    end.

    assert (NoDup (filter (fun x => PS.mem (fst x) (memories (n_eqs n))) (n_out n))).
    {
      apply NoDupMembers_NoDup, fst_NoDupMembers.
      rewrite filter_mem_fst.
      apply nodup_filter.
      pose proof (n.(n_nodup)) as Hnodup.
      do 2 apply NoDupMembers_app_r in Hnodup.
      now apply fst_NoDupMembers.
    }

    assert (filter (fun x=>PS.mem (fst x) (memories n.(n_eqs))) n.(n_out) = [])
      as Hfout.
    { simpl.
      apply Permutation_nil.
      apply NoDup_Permutation; auto using NoDup. intros x.
      split; try (now intuition); []. intro Hin.

      apply filter_In in Hin as [Hin Hmem].

      assert (In (fst x) (map fst (n_out n)))
        by now eapply in_map.

      assert (In (fst x) (vars_defined (filter is_fby (n_eqs n))))
        by now apply in_memories_filter_is_fby.

      eapply n.(n_vout); eauto.
    }

    rewrite <-Hfout; clear Hfout.
    rewrite filter_app, filter_mem_fst, <-n_defd.
    remember (memories n.(n_eqs)) as mems.
    set (P:=fun eqs eq=> In eq eqs ->
                      forall x, In x (var_defined eq) ->
                           PS.mem x mems = is_fby eq).
    assert (forall eq, P n.(n_eqs) eq) as Peq.
    { subst P mems.
      intro. intro Hin.
      apply in_memories_is_fby; auto.
      rewrite n_defd.
      apply fst_NoDupMembers.
      pose proof (n.(n_nodup)) as Hnodup.
      now apply NoDupMembers_app_r in Hnodup.
    }
    clear Heqmems.
    induction n.(n_eqs) as [|eq eqs]; auto.
    assert (forall eq, P eqs eq) as Peq'
        by (intros e Hin; apply Peq; now constructor 2).
    specialize (IHeqs Peq'). clear Peq'.
    destruct eq eqn:Heq; simpl;
      specialize (Peq eq); red in Peq; subst eq;
        simpl in Peq.

    + (* Case: EqDef *)
      rewrite Peq; eauto.
    + (* Case: EqApp *)
      assert (Pfilter: Permutation (filter (fun x => PS.mem x mems) l) []).
      {
        assert (Hmem_in: forall x, In x l -> PS.mem x mems = false)
          by now apply Peq; eauto.

        assert (Hfilter: filter (fun x => PS.mem x mems) l = []).
        {
          clear - Hmem_in.
          induction l as [ | a i IHi] ; auto; simpl.
          rewrite Hmem_in; try now constructor.
          apply IHi. intros.
          apply Hmem_in. now constructor 2.
        }

        now rewrite Hfilter.
      }

      unfold vars_defined; unfold var_defined; simpl.
      now rewrite <- filter_app, IHeqs, Pfilter.

    + (* Case: EqFby *)
      unfold vars_defined;
        simpl; unfold var_defined; simpl.
      rewrite Peq; eauto.
  Qed.

  Lemma snd_partition_memories_var_defined:
    forall n,
      Permutation
        (map fst (snd (partition
                         (fun x => PS.mem (fst x) (memories n.(n_eqs)))
                         n.(n_vars)) ++ n.(n_out)))
        (vars_defined (filter (notb is_fby) n.(n_eqs))).
  Proof.
    intro n.
    match goal with |- Permutation (map fst (snd (partition ?p ?l) ++ _)) _ =>
      assert (Permutation (map fst (snd (partition p l)))
                          (map fst (filter (notb p) n.(n_vars))))
                      as Hperm by (now rewrite snd_partition_filter)
    end.
    rewrite map_app, Hperm, <-map_app; clear Hperm.

    assert (filter (notb (fun x => PS.mem (fst x) (memories n.(n_eqs)))) n.(n_out) = n.(n_out))
      as Hfout.
    { simpl.
      pose proof (n_vout n) as Out.
      setoid_rewrite <-in_memories_filter_is_fby in Out.
      unfold notb.
      induction (n_out n) as [|(x, t)]; simpl; auto.
      destruct (PS.mem x (memories (n_eqs n))) eqn: E; simpl.
      - apply PSE.MP.Dec.F.mem_iff in E.
        exfalso; eapply Out; eauto.
        simpl; auto.
      - rewrite IHl; auto.
        intros ???; eapply Out; eauto.
        simpl; auto.
    }

    rewrite <-Hfout; clear Hfout.
    rewrite filter_app, notb_filter_mem_fst, <-n_defd.
    remember (memories n.(n_eqs)) as mems.
    set (P := fun eqs eq =>  In eq eqs ->
                          forall x, In x (var_defined eq) ->
                               PS.mem x mems = is_fby eq).
    assert (forall eq, P n.(n_eqs) eq) as Peq.
    { subst P mems.
      intro. intro Hin.
      apply in_memories_is_fby; auto.
      rewrite n_defd.
      apply fst_NoDupMembers.
      pose proof (n.(n_nodup)) as Hnodup.
      now apply NoDupMembers_app_r in Hnodup.
    }
    clear Heqmems.
    unfold notb, vars_defined.
    induction n.(n_eqs) as [|eq eqs]; auto.
    assert (forall eq, P eqs eq) as Peq'
        by (intros e Hin; apply Peq; now constructor 2).
    specialize (IHeqs Peq'). clear Peq'.
    destruct eq eqn:Heq; simpl;
      specialize (Peq eq); red in Peq; subst eq;
        simpl in Peq.

    + rewrite Peq; eauto.
      simpl; auto.

    + assert (Hmem_in: forall x, In x l -> PS.mem x mems = false)
        by now apply Peq; eauto.

      assert (Hfilter: filter (fun x => negb (PS.mem x mems)) l = l).
      { clear - Hmem_in.
        induction l as [ | a i IHi] ; auto; simpl.
        rewrite Hmem_in; simpl; try now constructor.
        rewrite IHi; auto.
        intros.
        apply Hmem_in. now constructor 2.
      }

      rewrite <-filter_app; setoid_rewrite Hfilter.
      apply Permutation_app_head; auto.

    + rewrite Peq; eauto.
  Qed.

End MEMORIES.

Module MemoriesFun
       (Ids     : IDS)
       (Op      : OPERATORS)
       (CESyn   : CESYNTAX     Op)
       (Syn     : NLSYNTAX Ids Op CESyn)
       <: MEMORIES Ids Op CESyn Syn.
  Include MEMORIES Ids Op CESyn Syn.
End MemoriesFun.


Axiom Ens : Set.
Axiom tin : Ens -> Ens -> Prop.
Axiom Sing : Ens -> Ens.

(*Axiom A:Type.
Definition Ens := A -> Prop.
Definition tin x (s:Ens) := s x.
Definition Sing x : Ens := eq x.*)

Section FixingBraceNotation.
  Notation "x  ∈  y" := (tin x y) (at level 50).
  (* Note: the level on the following modifier is already set for this
  notation and so is redundant, but it needs to be reproduced exactly if
  you add a format modifier (you can overwrite the notation but not the
  parsing levels). *)
  Notation "{ x }" := (Sing x) (at level 0, x at level 99).
  Notation "x  ∈  { y }" := (tin x (Sing y)) (at level 50).
  Check fun x => (x ∈ { x }).
  Check fun x => {x}.
End FixingBraceNotation.

Section RemovingWhitespace.
  Notation "x  ∈  y" := (tin x y) (at level 50).
  Notation "{ x }`" := (Sing x) (at level 0, format "{ x }`").
  Check fun x => (x ∈ { x }`).
End RemovingWhitespace.

Section AddingWhitespace.
  Notation "x  ∈  y" := (tin x y) (at level 50).
  Notation "{  x  }`" := (Sing x) (at level 0).
  Check fun x => (x ∈ {x}`).
End AddingWhitespace.


Require Import String.
Import List.
Import ListNotations.

Set Implicit Arguments.
Require Import Flood_Box.

Lemma add_message_to_all_reveals_older_messages:
  forall buf buf' i' port_buf' i m c,
  buf' = add_message_to_all buf i m c ->
  nth_error buf' i' = Some port_buf' ->
  exists port_buf, port_buf' = (i, m, c) :: port_buf.
Proof.
  intros buf.
  induction buf;
  intros buf' i' port_buf' i m c;
  intros H_add H_nth.
  - simpl in H_add.
    subst.
    destruct i';
    simpl in H_nth;
    discriminate.
  - simpl in H_add.
    subst.
    destruct i';
    simpl in H_nth.
    + inversion H_nth.
      exists a.
      reflexivity.
    + apply IHbuf with (add_message_to_all buf i m c) i'.
      * reflexivity.
      * assumption.
Qed.

Lemma add_message_to_all_old_lookups:
  forall buf buf' port_buf' k i m c,
  buf' = add_message_to_all buf i m c ->
  nth_error buf' k = Some ((i, m, c) :: port_buf') ->
  nth_error buf k = Some port_buf'.
Proof.
  intros buf.
  induction buf;
  intros buf' port_buf' k i m c;
  intros H_add H_nth;
  simpl in H_add;
  subst.
  - destruct k;
    simpl in H_nth;
    discriminate.
  - destruct k;
    simpl in H_nth |- *.
    + inversion H_nth.
      reflexivity.
    + apply IHbuf with (add_message_to_all buf i m c) i m c.
      * reflexivity.
      * assumption.
Qed.

Lemma add_message_to_all_preserves_length:
  forall buf i m c,
  Datatypes.length buf = Datatypes.length (add_message_to_all buf i m c).
Proof.
  intros buf.
  induction buf;
  intros i m c;
  simpl.
  - reflexivity.
  - rewrite <- IHbuf.
    reflexivity.
Qed.


(*

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

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

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

  VPrl is distributed in the hope that it will be useful,
  but WITHOUT ANY WARRANTY; without even the implied warranty of
  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  GNU General Public License for more details.

  You should have received a copy of the GNU General Public License
  along with VPrl.  If not, see <http://www.gnu.org/licenses/>.

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

  Authors: Abhishek Anand & Vincent Rahli

*)

Require Export sequents2.
Require Export sequents_lib.
Require Export rules_useful.
Require Export per_props_equality.
Require Export per_props_union.
Require Export per_props_cequiv.
Require Export per_props_squash.
Require Export subst_tacs.
Require Export sequents_equality.
Require Export sequents_tacs2.

Lemma inhabited_mkc_or {o} :
  forall lib (A B : @CTerm o),
    inhabited_type lib (mkc_or A B)
    <=> (type lib A
         # type lib B
         # (inhabited_type lib A {+} inhabited_type lib B)).
Proof.
  introv.
  unfold inhabited_type.
  split; introv h; exrepnd.

  - apply equality_mkc_or in h0; exrepnd; dands; auto.
    repndors; exrepnd.

    + left; exists a1.
      apply equality_refl in h0; auto.

    + right; exists b1.
      apply equality_refl in h0; auto.

  - repndors; exrepnd.

    + exists (mkc_inl t).
      apply equality_mkc_or; dands; auto.
      left.
      exists t t; dands; auto; spcast;
      apply computes_to_valc_refl; eauto 3 with slow.

    + exists (mkc_inr t).
      apply equality_mkc_or; dands; auto.
      right.
      exists t t; dands; auto; spcast;
      apply computes_to_valc_refl; eauto 3 with slow.
Qed.

Lemma equality_base_implies_equality {o} :
  forall lib (x y T : @CTerm o),
     type lib T -> equality lib x y mkc_base -> member lib x T -> equality lib x y T.
Proof.
   intros.
   rw @equality_in_base_iff in H0.
   spcast.
   eapply equality_respects_cequivc_right; eauto.
Qed.

Lemma equality_mkc_equality_in_uni_equal_base {o} :
  forall (lib : library) (i : nat) (a1 a2 b1 b2 A B : @CTerm o),
  equality lib A B (mkc_uni i) ->
  equality lib a1 b1 A ->
  equality lib a2 b2 mkc_base ->
  equality lib (mkc_equality a1 a2 A) (mkc_equality b1 b2 B) (mkc_uni i) .
Proof. intros. dup H0 as h1. dup H0 as h2.
       apply equality_refl in h1. apply equality_sym in h2. apply equality_refl in h2.
       dup H1 as e. apply equality_in_base in e. spcast.
       apply equality_mkc_equality2_sp_in_uni; dands; sp; try (split; intro).
       - pose proof (equality_respects_cequivc lib a2 b2 A e H2).
         apply equality_sym in H3. apply equality_refl in H3. auto.
       - apply cequivc_sym in e.
         pose proof (equality_respects_cequivc lib b2 a2 A e H2).
         apply equality_sym in H3. apply equality_refl in H3. auto.
       - apply equality_respects_cequivc; auto.
Qed.

Lemma equality_mkc_equality_in_uni_equal_equal {o} :
  forall (lib : library) (i : nat) (a1 a2 b1 b2 A B : @CTerm o),
  equality lib A B (mkc_uni i) ->
  equality lib a1 b1 A ->
  equality lib a2 b2 A ->
  equality lib (mkc_equality a1 a2 A) (mkc_equality b1 b2 B) (mkc_uni i) .
Proof. intros. dup H0 as h1. dup H0 as h2.
       apply equality_refl in h1. apply equality_sym in h2. apply equality_refl in h2.
       dup H1 as r1. dup H1 as r2.
       apply equality_refl in r1. apply equality_sym in r2. apply equality_refl in r2.

       apply equality_mkc_equality2_sp_in_uni; dands; sp; try (split; intro).

Qed.

Lemma equality_mkc_equality_in_uni_base_equal {o} :
  forall (lib : library) (i : nat) (a1 a2 b1 b2 A B : @CTerm o),
  equality lib A B (mkc_uni i) ->
  equality lib a1 b1 mkc_base ->
  equality lib a2 b2 A ->
  equality lib (mkc_equality a1 a2 A) (mkc_equality b1 b2 B) (mkc_uni i) .
Proof. intros. dup H1 as h1. dup H1 as h2.
       apply equality_refl in h1. apply equality_sym in h2. apply equality_refl in h2.
       dup H0 as e. apply equality_in_base in e. spcast.
       apply equality_mkc_equality2_sp_in_uni; dands; sp; try (split; intro).
       - pose proof (equality_respects_cequivc lib a1 b1 A e H2).
         apply equality_sym in H3. apply equality_refl in H3. auto.
       - apply cequivc_sym in e.
         pose proof (equality_respects_cequivc lib b1 a1 A e H2).
         apply equality_sym in H3. apply equality_refl in H3. auto.
       - apply equality_respects_cequivc; auto.
Qed.

Lemma equality_mkc_equality_in_uni_base_base {o} :
  forall (lib : library) (i : nat) (a1 a2 b1 b2 A B : @CTerm o),
  equality lib A B (mkc_uni i) ->
  equality lib a1 b1 mkc_base ->
  equality lib a2 b2 mkc_base ->
  equality lib (mkc_equality a1 a2 A) (mkc_equality b1 b2 B) (mkc_uni i) .
Proof. intros.
       apply equality_in_base in H0. spcast.
       apply equality_in_base in H1. spcast.
       dup H0 as e0. apply cequivc_sym in e0.
       dup H1 as e1. apply cequivc_sym in e1.
       pose proof (equality_respects_cequivc lib a1 b1 A H0) as X0.
       pose proof (equality_respects_cequivc lib b1 a1 A e0) as Y0.
       pose proof (equality_respects_cequivc lib a2 b2 A H1) as X1.
       pose proof (equality_respects_cequivc lib b2 a2 A e1) as Y1.
       apply equality_mkc_equality2_sp_in_uni; dands; sp; try (split; intro).
       - apply X0 in H2.
         apply equality_sym in H2. apply equality_refl in H2. auto.
       - apply Y0 in H2.
         apply equality_sym in H2. apply equality_refl in H2. auto.
       - apply X1 in H2.
         apply equality_sym in H2. apply equality_refl in H2. auto.
       - apply Y1 in H2.
         apply equality_sym in H2. apply equality_refl in H2. auto.

Qed.

Definition rule_equality_equality_concl {o} (H : @bhyps o) a1 a2 b1 b2 A B i :=
  mk_baresequent
    H
    (mk_conclax (mk_equality
                   (mk_equality a1 a2 A)
                   (mk_equality b1 b2 B)
                   (mk_uni i))).

Definition rule_equality_equality_hyp1 {o} (H : @bhyps o) A B i e :=
  mk_baresequent H (mk_concl (mk_equality A B (mk_uni i)) e).

Definition rule_equality_equality_hyp2 {o} (H : @bhyps o) a b A e :=
  mk_baresequent H (mk_concl (mk_equality a b A) e).

(**

<<
   H |- (a1 = a2 in A) = (b1 = b2 in B) in U(i)

     By equalityEquality

     H |- A = B in U(i)
     H |- a1 = b1 in A
     H |- a2 = b2 in A
>>
 *)
Definition rule_equality_equality {o}
           (H  : @barehypotheses o)
           (A B a1 a2 b1 b2 e1 e2 e3 : NTerm)
           (i : nat) :=
  mk_rule
    (rule_equality_equality_concl H a1 a2 b1 b2 A B i)
    [ rule_equality_equality_hyp1 H A B i e1,
      rule_equality_equality_hyp2 H a1 b1 A e2,
      rule_equality_equality_hyp2 H a2 b2 A e3
    ]
    [].

Lemma rule_equality_equality_true3 {o} :
  forall lib (H : @barehypotheses o)
         (A B a1 a2 b1 b2 e1 e2 e3 : NTerm)
         (i : nat),
    rule_true3 lib (rule_equality_equality H A B a1 a2 b1 b2 e1 e2 e3 i).
Proof.
  unfold rule_equality_equality, rule_true3, wf_bseq, closed_type_baresequent, closed_extract_baresequent; simpl.
  intros.
  clear cargs.

  (* We prove the well-formedness of things *)
  destseq; allsimpl.
  dLin_hyp.
  destruct Hyp as [wf1 hyp1].
  destruct Hyp0 as [wf2 hyp2].
  destruct Hyp1 as [wf3 hyp3].
  destseq; allsimpl; proof_irr; GC.

  match goal with
  | [ |- sequent_true2 _ ?s ] => assert (wf_csequent s) as wfc
  end.
  {
    clear hyp1 hyp2 hyp3.
    unfold wf_csequent, wf_sequent, wf_concl; simpl.
    dands; auto.
    - apply wf_axiom.
    - unfold closed_extract; simpl; auto.
  }
  exists wfc.
  destseq; simpl in *.

  (* We prove some simple facts on our sequents *)
  (* done with proving these simple facts *)

  vr_seq_true.
  lsubst_tac.
  rw <- @member_equality_iff.

  pose proof (teq_and_eq_if_equality
                lib (mk_uni i) (mk_equality a1 a2 A) (mk_equality b1 b2 B)
                s1 s2 H wT w1 w2 c1 c6 c2 c7 cT cT2
                eqh sim) as eqp.
  lsubst_tac.
  repeat (autodimp eqp hyp);[apply tequality_mkc_uni|].

  clear dependent s1.
  clear dependent s2.

  introv hf sim.
  lsubst_tac.
  vr_seq_true in hyp1.
    pose proof (hyp1 s1 s2 hf sim) as X; clear hyp1; exrepnd.
    lsubst_tac.
   vr_seq_true in hyp2.
      pose proof (hyp2 s1 s2 hf sim) as Y; clear hyp2; exrepnd.
      lsubst_tac.
   vr_seq_true in hyp3.
      pose proof (hyp3 s1 s2 hf sim) as Z; clear hyp3; exrepnd.
      lsubst_tac.
    rw @tequality_mkc_equality in X0;
    rw @tequality_mkc_equality in Y0;
    rw @tequality_mkc_equality in Z0.
    apply equality_in_mkc_equality in X1;
    apply equality_in_mkc_equality in Y1;
    apply equality_in_mkc_equality in Z1.
    repnd.
    dup Z6 as ZZ1. apply equality_refl in ZZ1.
    dup Z6 as ZZ2. apply equality_sym in ZZ2. apply equality_refl in ZZ2.
    dimp Z4. auto. clear Z4.
    dimp Z0. auto. clear Z0.
    dup Y6 as YY1. apply equality_refl in YY1.
    dup Y6 as YY2. apply equality_sym in YY2. apply equality_refl in YY2.
    dimp Y4. auto. clear Y4.
    dimp Y0. auto. clear Y0.
    apply @equality_mkc_equality_in_uni_equal_equal.

   - eapply equality_trans. exact X6. apply X0.
     apply equality_sym in X6; apply equality_refl in X6; auto.
   - eapply equality_trans. exact Y6.  auto.
   - eapply equality_trans. exact Z6. auto.

Qed.

Lemma rule_equality_equality_true_ext_lib {o} :
  forall lib (H : @barehypotheses o)
         (A B a1 a2 b1 b2 e1 e2 e3 : NTerm)
         (i : nat),
    rule_true_ext_lib lib (rule_equality_equality H A B a1 a2 b1 b2 e1 e2 e3 i).
Proof.
  introv.
  apply rule_true3_implies_rule_true_ext_lib.
  introv.
  apply rule_equality_equality_true3.
Qed.

Lemma rule_equality_equality_wf2 {o} :
  forall (H : @barehypotheses o)
         (A B a1 a2 b1 b2 e1 e2 e3 : NTerm)
         (i : nat),
    wf_rule2 (rule_equality_equality H A B a1 a2 b1 b2 e1 e2 e3 i).
Proof.
  introv wf m; allsimpl.
  repndors; subst; tcsp;
    allunfold @wf_bseq; allsimpl; repnd; dands; auto.

  - allrw <- @wf_equality_iff; tcsp.

  - unfold closed_type_baresequent in *; simpl in *.
    unfold closed_type in *; simpl in *.
    allrw @covered_equality; tcsp.

  - allrw <- @wf_equality_iff; tcsp.

  - unfold closed_type_baresequent in *; simpl in *.
    unfold closed_type in *; simpl in *.
    allrw @covered_equality; tcsp.

  - allrw <- @wf_equality_iff; tcsp.

  - unfold closed_type_baresequent in *; simpl in *.
    unfold closed_type in *; simpl in *.
    allrw @covered_equality; tcsp.
Qed.

Definition rule_equality_equality_hyp3 {o} (H : @bhyps o) a b e :=
  mk_baresequent H (mk_concl (mk_equality a b mk_base) e).

(**

<<
   H |- (a1 = a2 in A) = (b1 = b2 in B) in U(i)

     By equalityEqualityBase

     H |- A = B in U(i)
     H |- a1 = b1 in Base
     H |- a2 = b2 in Base
>>
 *)
Definition rule_equality_equality_base {o}
           (H  : @barehypotheses o)
           (A B a1 a2 b1 b2 e1 e2 e3 : NTerm)
           (i : nat) :=
  mk_rule
    (rule_equality_equality_concl H a1 a2 b1 b2 A B i)
    [ rule_equality_equality_hyp1 H A B i e1,
      rule_equality_equality_hyp3 H a1 b1 e2,
      rule_equality_equality_hyp3 H a2 b2 e3
    ]
    [].

Lemma rule_equality_equality_base_true3 {o} :
  forall lib (H : @barehypotheses o)
         (A B a1 a2 b1 b2 e1 e2 e3 : NTerm)
         (i : nat),
    rule_true3 lib (rule_equality_equality_base H A B a1 a2 b1 b2 e1 e2 e3 i).
Proof.
  unfold rule_equality_equality_base, rule_true3, wf_bseq, closed_type_baresequent, closed_extract_baresequent; simpl.
  intros.
  clear cargs.

  (* We prove the well-formedness of things *)
  destseq; allsimpl.
  dLin_hyp.
  destruct Hyp as [wf1 hyp1].
  destruct Hyp0 as [wf2 hyp2].
  destruct Hyp1 as [wf3 hyp3].
  destseq; allsimpl; proof_irr; GC.

  match goal with
  | [ |- sequent_true2 _ ?s ] => assert (wf_csequent s) as wfc
  end.
  {
    clear hyp1 hyp2 hyp3.
    unfold wf_csequent, wf_sequent, wf_concl; simpl.
    dands; auto.
    - apply wf_axiom.
    - unfold closed_extract; simpl; auto.
  }
  exists wfc.
  destseq; simpl in *.

  (* We prove some simple facts on our sequents *)
  (* done with proving these simple facts *)

  vr_seq_true.
  lsubst_tac.
  rw <- @member_equality_iff.

  pose proof (teq_and_eq_if_equality
                lib (mk_uni i) (mk_equality a1 a2 A) (mk_equality b1 b2 B)
                s1 s2 H wT w1 w2 c1 c6 c2 c7 cT cT2
                eqh sim) as eqp.
  lsubst_tac.
  repeat (autodimp eqp hyp);[apply tequality_mkc_uni|].

  clear dependent s1.
  clear dependent s2.

  introv hf sim.
  lsubst_tac.
  vr_seq_true in hyp1.
    pose proof (hyp1 s1 s2 hf sim) as X; clear hyp1; exrepnd.
    lsubst_tac.
   vr_seq_true in hyp2.
      pose proof (hyp2 s1 s2 hf sim) as Y; clear hyp2; exrepnd.
      lsubst_tac.
   vr_seq_true in hyp3.
      pose proof (hyp3 s1 s2 hf sim) as Z; clear hyp3; exrepnd.
      lsubst_tac.
    rw @tequality_mkc_equality in X0;
    rw @tequality_mkc_equality in Y0;
    rw @tequality_mkc_equality in Z0.
    apply equality_in_mkc_equality in X1;
    apply equality_in_mkc_equality in Y1;
    apply equality_in_mkc_equality in Z1.
    repnd.
    dimp Z0. apply member_base. clear Z0 Z5.
    dimp Z4. apply member_base. clear Z3 Z4.
    dup Y6 as YY1. apply equality_refl in YY1.
    dup Y6 as YY2. apply equality_sym in YY2. apply equality_refl in YY2.
    dimp Y4. auto. clear Y4.
    dimp Y0. auto. clear Y0.
    apply @equality_mkc_equality_in_uni_base_base.

   - eapply equality_trans. exact X6. apply X0.
     apply equality_sym in X6; apply equality_refl in X6; auto.
   - eapply equality_trans. exact Y6.  auto.
   - eapply equality_trans. exact Z6.  auto.

Qed.

Lemma rule_equality_equality_base_true_ext_lib {o} :
  forall lib (H : @barehypotheses o)
         (A B a1 a2 b1 b2 e1 e2 e3 : NTerm)
         (i : nat),
    rule_true_ext_lib lib (rule_equality_equality_base H A B a1 a2 b1 b2 e1 e2 e3 i).
Proof.
  introv.
  apply rule_true3_implies_rule_true_ext_lib.
  introv.
  apply rule_equality_equality_base_true3.
Qed.

Lemma rule_equality_equality_base_wf2 {o} :
  forall (H : @barehypotheses o)
         (A B a1 a2 b1 b2 e1 e2 e3 : NTerm)
         (i : nat),
    wf_rule2 (rule_equality_equality_base H A B a1 a2 b1 b2 e1 e2 e3 i).
Proof.
  introv wf m; allsimpl.
  repndors; subst; tcsp;
    allunfold @wf_bseq; allsimpl; repnd; dands; auto.

  - allrw <- @wf_equality_iff; tcsp.

  - unfold closed_type_baresequent in *; simpl in *.
    unfold closed_type in *; simpl in *.
    allrw @covered_equality; tcsp.

  - allrw <- @wf_equality_iff; tcsp.

  - unfold closed_type_baresequent in *; simpl in *.
    unfold closed_type in *; simpl in *.
    allrw @covered_equality; tcsp.

  - allrw <- @wf_equality_iff; tcsp.

  - unfold closed_type_baresequent in *; simpl in *.
    unfold closed_type in *; simpl in *.
    allrw @covered_equality; tcsp.
Qed.

(**

<<
   H |- (a1 = a2 in A) = (b1 = b2 in B) in U(i)

     By equalityEqualityBase1

     H |- A = B in U(i)
     H |- a1 = b1 in Base
     H |- a2 = b2 in A
>>
 *)
Definition rule_equality_equality_base1 {o}
           (H  : @barehypotheses o)
           (A B a1 a2 b1 b2 e1 e2 e3 : NTerm)
           (i : nat) :=
  mk_rule
    (rule_equality_equality_concl H a1 a2 b1 b2 A B i)
    [ rule_equality_equality_hyp1 H A B i e1,
      rule_equality_equality_hyp3 H a1 b1 e2,
      rule_equality_equality_hyp2 H a2 b2 A e3
    ]
    [].

Lemma rule_equality_equality_base1_true3 {o} :
  forall lib (H : @barehypotheses o)
         (A B a1 a2 b1 b2 e1 e2 e3 : NTerm)
         (i : nat),
    rule_true3 lib (rule_equality_equality_base1 H A B a1 a2 b1 b2 e1 e2 e3 i).
Proof.
  unfold rule_equality_equality_base1, rule_true3, wf_bseq, closed_type_baresequent, closed_extract_baresequent; simpl.
  intros.
  clear cargs.

  (* We prove the well-formedness of things *)
  destseq; allsimpl.
  dLin_hyp.
  destruct Hyp as [wf1 hyp1].
  destruct Hyp0 as [wf2 hyp2].
  destruct Hyp1 as [wf3 hyp3].
  destseq; allsimpl; proof_irr; GC.

  match goal with
  | [ |- sequent_true2 _ ?s ] => assert (wf_csequent s) as wfc
  end.
  {
    clear hyp1 hyp2 hyp3.
    unfold wf_csequent, wf_sequent, wf_concl; simpl.
    dands; auto.
    - apply wf_axiom.
    - unfold closed_extract; simpl; auto.
  }
  exists wfc.
  destseq; simpl in *.

  (* We prove some simple facts on our sequents *)
  (* done with proving these simple facts *)

  vr_seq_true.
  lsubst_tac.
  rw <- @member_equality_iff.

  pose proof (teq_and_eq_if_equality
                lib (mk_uni i) (mk_equality a1 a2 A) (mk_equality b1 b2 B)
                s1 s2 H wT w1 w2 c1 c6 c2 c7 cT cT2
                eqh sim) as eqp.
  lsubst_tac.
  repeat (autodimp eqp hyp);[apply tequality_mkc_uni|].

  clear dependent s1.
  clear dependent s2.

  introv hf sim.
  lsubst_tac.
  vr_seq_true in hyp1.
    pose proof (hyp1 s1 s2 hf sim) as X; clear hyp1; exrepnd.
    lsubst_tac.
   vr_seq_true in hyp2.
      pose proof (hyp2 s1 s2 hf sim) as Y; clear hyp2; exrepnd.
      lsubst_tac.
   vr_seq_true in hyp3.
      pose proof (hyp3 s1 s2 hf sim) as Z; clear hyp3; exrepnd.
      lsubst_tac.
    rw @tequality_mkc_equality in X0;
    rw @tequality_mkc_equality in Y0;
    rw @tequality_mkc_equality in Z0.
    apply equality_in_mkc_equality in X1;
    apply equality_in_mkc_equality in Y1;
    apply equality_in_mkc_equality in Z1.
    repnd.
    dimp Y0. apply member_base. clear Y0 Y5.
    dimp Y4. apply member_base. clear Y3 Y4.
    dup Z6 as ZZ1. apply equality_refl in ZZ1.
    dup Z6 as ZZ2. apply equality_sym in ZZ2. apply equality_refl in ZZ2.
    dimp Z4. auto. clear Z4.
    dimp Z0. auto. clear Z0.
    apply @equality_mkc_equality_in_uni_base_equal.

   - eapply equality_trans. exact X6. apply X0.
     apply equality_sym in X6; apply equality_refl in X6; auto.
   - eapply equality_trans. exact Y6.  auto.
   - eapply equality_trans. exact Z6. auto.

Qed.

Lemma rule_equality_equality_base1_true_ext_lib {o} :
  forall lib (H : @barehypotheses o)
         (A B a1 a2 b1 b2 e1 e2 e3 : NTerm)
         (i : nat),
    rule_true_ext_lib lib (rule_equality_equality_base1 H A B a1 a2 b1 b2 e1 e2 e3 i).
Proof.
  introv.
  apply rule_true3_implies_rule_true_ext_lib.
  introv.
  apply rule_equality_equality_base1_true3.
Qed.

Lemma rule_equality_equality_base1_wf2 {o} :
  forall (H : @barehypotheses o)
         (A B a1 a2 b1 b2 e1 e2 e3 : NTerm)
         (i : nat),
    wf_rule2 (rule_equality_equality_base1 H A B a1 a2 b1 b2 e1 e2 e3 i).
Proof.
  introv wf m; allsimpl.
  repndors; subst; tcsp;
    allunfold @wf_bseq; allsimpl; repnd; dands; auto.

  - allrw <- @wf_equality_iff; tcsp.

  - unfold closed_type_baresequent in *; simpl in *.
    unfold closed_type in *; simpl in *.
    allrw @covered_equality; tcsp.

  - allrw <- @wf_equality_iff; tcsp.

  - unfold closed_type_baresequent in *; simpl in *.
    unfold closed_type in *; simpl in *.
    allrw @covered_equality; tcsp.

  - allrw <- @wf_equality_iff; tcsp.

  - unfold closed_type_baresequent in *; simpl in *.
    unfold closed_type in *; simpl in *.
    allrw @covered_equality; tcsp.
Qed.

(**

<<
   H |- (a1 = a2 in A) = (b1 = b2 in B) in U(i)

     By equalityEqualityBase2

     H |- A = B in U(i)
     H |- a1 = b1 in A
     H |- a2 = b2 in Base
>>
 *)
Definition rule_equality_equality_base2 {o}
           (H  : @barehypotheses o)
           (A B a1 a2 b1 b2 e1 e2 e3 : NTerm)
           (i : nat) :=
  mk_rule
    (rule_equality_equality_concl H a1 a2 b1 b2 A B i)
    [ rule_equality_equality_hyp1 H A B i e1,
      rule_equality_equality_hyp2 H a1 b1 A e2,
      rule_equality_equality_hyp3 H a2 b2 e3
    ]
    [].

Lemma rule_equality_equality_base2_true3 {o} :
  forall lib (H : @barehypotheses o)
         (A B a1 a2 b1 b2 e1 e2 e3 : NTerm)
         (i : nat),
    rule_true3 lib (rule_equality_equality_base2 H A B a1 a2 b1 b2 e1 e2 e3 i).
Proof.
  unfold rule_equality_equality_base2, rule_true3, wf_bseq, closed_type_baresequent, closed_extract_baresequent; simpl.
  intros.
  clear cargs.

  (* We prove the well-formedness of things *)
  destseq; allsimpl.
  dLin_hyp.
  destruct Hyp as [wf1 hyp1].
  destruct Hyp0 as [wf2 hyp2].
  destruct Hyp1 as [wf3 hyp3].
  destseq; allsimpl; proof_irr; GC.

  match goal with
  | [ |- sequent_true2 _ ?s ] => assert (wf_csequent s) as wfc
  end.
  {
    clear hyp1 hyp2 hyp3.
    unfold wf_csequent, wf_sequent, wf_concl; simpl.
    dands; auto.
    - apply wf_axiom.
    - unfold closed_extract; simpl; auto.
  }
  exists wfc.
  destseq; simpl in *.

  (* We prove some simple facts on our sequents *)
  (* done with proving these simple facts *)

  vr_seq_true.
  lsubst_tac.
  rw <- @member_equality_iff.

  pose proof (teq_and_eq_if_equality
                lib (mk_uni i) (mk_equality a1 a2 A) (mk_equality b1 b2 B)
                s1 s2 H wT w1 w2 c1 c6 c2 c7 cT cT2
                eqh sim) as eqp.
  lsubst_tac.
  repeat (autodimp eqp hyp);[apply tequality_mkc_uni|].

  clear dependent s1.
  clear dependent s2.

  introv hf sim.
  lsubst_tac.
  vr_seq_true in hyp1.
    pose proof (hyp1 s1 s2 hf sim) as X; clear hyp1; exrepnd.
    lsubst_tac.
   vr_seq_true in hyp2.
      pose proof (hyp2 s1 s2 hf sim) as Y; clear hyp2; exrepnd.
      lsubst_tac.
   vr_seq_true in hyp3.
      pose proof (hyp3 s1 s2 hf sim) as Z; clear hyp3; exrepnd.
      lsubst_tac.
    rw @tequality_mkc_equality in X0;
    rw @tequality_mkc_equality in Y0;
    rw @tequality_mkc_equality in Z0.
    apply equality_in_mkc_equality in X1;
    apply equality_in_mkc_equality in Y1;
    apply equality_in_mkc_equality in Z1.
    repnd.
    dimp Z0. apply member_base. clear Z0 Z5.
    dimp Z4. apply member_base. clear Z3 Z4.
    dup Y6 as YY1. apply equality_refl in YY1.
    dup Y6 as YY2. apply equality_sym in YY2. apply equality_refl in YY2.
    dimp Y4. auto. clear Y4.
    dimp Y0. auto. clear Y0.
    apply @equality_mkc_equality_in_uni_equal_base.

   - eapply equality_trans. exact X6. apply X0.
     apply equality_sym in X6; apply equality_refl in X6; auto.
   - eapply equality_trans. exact Y6.  auto.
   - apply equality_base_implies_equality. apply equality_refl in X6; auto.
       eapply equality_trans. exact Z6. auto.
       apply member_base.

Qed.

Lemma rule_equality_equality_base2_true_ext_lib {o} :
  forall lib (H : @barehypotheses o)
         (A B a1 a2 b1 b2 e1 e2 e3 : NTerm)
         (i : nat),
    rule_true_ext_lib lib (rule_equality_equality_base2 H A B a1 a2 b1 b2 e1 e2 e3 i).
Proof.
  introv.
  apply rule_true3_implies_rule_true_ext_lib.
  introv.
  apply rule_equality_equality_base2_true3.
Qed.

Lemma rule_equality_equality_base2_wf2 {o} :
  forall (H : @barehypotheses o)
         (A B a1 a2 b1 b2 e1 e2 e3 : NTerm)
         (i : nat),
    wf_rule2 (rule_equality_equality_base2 H A B a1 a2 b1 b2 e1 e2 e3 i).
Proof.
  introv wf m; allsimpl.
  repndors; subst; tcsp;
    allunfold @wf_bseq; allsimpl; repnd; dands; auto.

  - allrw <- @wf_equality_iff; tcsp.

  - unfold closed_type_baresequent in *; simpl in *.
    unfold closed_type in *; simpl in *.
    allrw @covered_equality; tcsp.

  - allrw <- @wf_equality_iff; tcsp.

  - unfold closed_type_baresequent in *; simpl in *.
    unfold closed_type in *; simpl in *.
    allrw @covered_equality; tcsp.

  - allrw <- @wf_equality_iff; tcsp.

  - unfold closed_type_baresequent in *; simpl in *.
    unfold closed_type in *; simpl in *.
    allrw @covered_equality; tcsp.
Qed.


(* *********************************************************************)
(*                                                                     *)
(*              The Compcert verified compiler                         *)
(*                                                                     *)
(*          Xavier Leroy, INRIA Paris-Rocquencourt                     *)
(*                                                                     *)
(*  Copyright Institut National de Recherche en Informatique et en     *)
(*  Automatique.  All rights reserved.  This file is distributed       *)
(*  under the terms of the INRIA Non-Commercial License Agreement.     *)
(*                                                                     *)
(* *********************************************************************)

(** Machine- and ABI-dependent layout information for activation records. *)

Require Import Coqlib.
Require Import Bounds.

(** The general shape of activation records is as follows,
  from bottom (lowest offsets) to top:
- Space for outgoing arguments to function calls.
- Local stack slots.
- Saved values of integer callee-save registers used by the function.
- Saved values of float callee-save registers used by the function.
- Saved return address into caller.
- Pointer to activation record of the caller.
- Space for the stack-allocated data declared in Cminor.

The [frame_env] compilation environment records the positions of
the boundaries between areas in the frame part.
*)

Definition fe_ofs_arg := 0.

Record frame_env : Type := mk_frame_env {
  fe_size: Z;
  fe_ofs_link: Z;
  fe_ofs_retaddr: Z;
  fe_ofs_local: Z;
  fe_ofs_int_callee_save: Z;
  fe_num_int_callee_save: Z;
  fe_ofs_float_callee_save: Z;
  fe_num_float_callee_save: Z;
  fe_stack_data: Z
}.

(** Computation of the frame environment from the bounds of the current
  function. *)

Definition make_env (b: bounds) :=
  let ol := align (4 * b.(bound_outgoing)) 8 in    (* locals *)
  let oics := ol + 4 * b.(bound_local) in (* integer callee-saves *)
  let oendi := oics + 4 * b.(bound_int_callee_save) in
  let ofcs := align oendi 8 in       (* float callee-saves *)
  let ora := ofcs + 8 * b.(bound_float_callee_save) in (* retaddr *)
  let olink := ora + 4 in (* back link *)
  let ostkdata := olink + 4 in (* stack data *)
  let sz := align (ostkdata + b.(bound_stack_data)) 8 in
  mk_frame_env sz olink ora ol
                  oics b.(bound_int_callee_save)
                  ofcs b.(bound_float_callee_save)
                  ostkdata.

(** Separation property *)

Remark frame_env_separated:
  forall b,
  let fe := make_env b in
  0 <= fe_ofs_arg
  /\ fe_ofs_arg + 4 * b.(bound_outgoing) <= fe.(fe_ofs_local)
  /\ fe.(fe_ofs_local) + 4 * b.(bound_local) <= fe.(fe_ofs_int_callee_save)
  /\ fe.(fe_ofs_int_callee_save) + 4 * b.(bound_int_callee_save) <= fe.(fe_ofs_float_callee_save)
  /\ fe.(fe_ofs_float_callee_save) + 8 * b.(bound_float_callee_save) <= fe.(fe_ofs_retaddr)
  /\ fe.(fe_ofs_retaddr) + 4 <= fe.(fe_ofs_link)
  /\ fe.(fe_ofs_link) + 4 <= fe.(fe_stack_data)
  /\ fe.(fe_stack_data) + b.(bound_stack_data) <= fe.(fe_size).
Proof.
  intros.
  generalize (align_le (4 * bound_outgoing b) 8 (refl_equal)).
  generalize (align_le (fe_ofs_int_callee_save fe + 4 * b.(bound_int_callee_save)) 8 (refl_equal _)).
  generalize (align_le (fe_stack_data fe + b.(bound_stack_data)) 8 (refl_equal)).
  unfold fe, make_env, fe_size, fe_ofs_link, fe_ofs_retaddr,
    fe_ofs_local, fe_ofs_int_callee_save, fe_num_int_callee_save,
    fe_ofs_float_callee_save, fe_num_float_callee_save,
    fe_stack_data, fe_ofs_arg.
  intros.
  generalize (bound_local_pos b); intro;
  generalize (bound_int_callee_save_pos b); intro;
  generalize (bound_float_callee_save_pos b); intro;
  generalize (bound_outgoing_pos b); intro;
  generalize (bound_stack_data_pos b); intro.
  omega.
Qed.

(** Alignment property *)

Remark frame_env_aligned:
  forall b,
  let fe := make_env b in
  (4 | fe.(fe_ofs_link))
  /\ (8 | fe.(fe_ofs_local))
  /\ (4 | fe.(fe_ofs_int_callee_save))
  /\ (8 | fe.(fe_ofs_float_callee_save))
  /\ (4 | fe.(fe_ofs_retaddr))
  /\ (8 | fe.(fe_stack_data))
  /\ (8 | fe.(fe_size)).
Proof.
  intros.
  unfold fe, make_env, fe_size, fe_ofs_link, fe_ofs_retaddr,
    fe_ofs_local, fe_ofs_int_callee_save, fe_num_int_callee_save,
    fe_ofs_float_callee_save, fe_num_float_callee_save,
    fe_stack_data.
  set (x1 := 4 * bound_outgoing b).
  assert (4 | x1). unfold x1; exists (bound_outgoing b); ring.
  set (x2 := align x1 8).
  assert (8 | x2). apply align_divides. omega.
  set (x3 := x2 + 4 * bound_local b).
  assert (4 | x3). apply Zdivide_plus_r. apply Zdivides_trans with 8; auto. exists 2; auto.
  exists (bound_local b); ring.
  set (x4 := align (x3 + 4 * bound_int_callee_save b) 8).
  assert (8 | x4). apply align_divides. omega.
  set (x5 := x4 + 8 * bound_float_callee_save b).
  assert (8 | x5). apply Zdivide_plus_r; auto. exists (bound_float_callee_save b); ring.
  assert (4 | x5). apply Zdivides_trans with 8; auto. exists 2; auto.
  set (x6 := x5 + 4).
  assert (4 | x6). apply Zdivide_plus_r; auto. exists 1; auto.
  set (x7 := x6 + 4).
  assert (8 | x7). unfold x7, x6. replace (x5 + 4 + 4) with (x5 + 8) by omega.
  apply Zdivide_plus_r; auto. exists 1; auto.
  set (x8 := align (x7 + bound_stack_data b) 8).
  assert (8 | x8). apply align_divides. omega.
  tauto.
Qed.