Require Export euclidean__axioms.
Require Export euclidean__defs.
Require Export euclidean__tactics.
Require Export lemma__3__7a.
Require Export lemma__betweennotequal.
Require Export lemma__congruencesymmetric.
Require Export lemma__congruencetransitive.
Require Export lemma__differenceofparts.
Require Export lemma__extension.
Require Export lemma__lessthanadditive.
Require Export lemma__lessthanbetween.
Require Export lemma__lessthancongruence.
Require Export lemma__lessthancongruence2.
Require Export logic.
Definition lemma__21helper : forall A B C E, (euclidean__defs.TG B A A E B E) -> ((euclidean__axioms.BetS A E C) -> (euclidean__defs.TT B A A C B E E C)).
Proof.
intro A.
intro B.
intro C.
intro E.
intro H.
intro H0.
assert (exists H1, (euclidean__axioms.BetS B A H1) /\ ((euclidean__axioms.Cong A H1 A E) /\ (euclidean__defs.Lt B E B H1))) as H1 by exact H.
destruct H1 as [H2 H3].
destruct H3 as [H4 H5].
destruct H5 as [H6 H7].
assert (* Cut *) (euclidean__axioms.neq B A) as H8.
- assert (* Cut *) ((euclidean__axioms.neq A H2) /\ ((euclidean__axioms.neq B A) /\ (euclidean__axioms.neq B H2))) as H8.
-- apply (@lemma__betweennotequal.lemma__betweennotequal B A H2 H4).
-- destruct H8 as [H9 H10].
destruct H10 as [H11 H12].
exact H11.
- assert (* Cut *) (~(B = E)) as H9.
-- intro H9.
assert (* Cut *) (euclidean__defs.Lt B B B H2) as H10.
--- apply (@eq__ind__r euclidean__axioms.Point E (fun B0 => (euclidean__defs.TG B0 A A E B0 E) -> ((euclidean__axioms.BetS B0 A H2) -> ((euclidean__defs.Lt B0 E B0 H2) -> ((euclidean__axioms.neq B0 A) -> (euclidean__defs.Lt B0 B0 B0 H2)))))) with (x := B).
----intro H10.
intro H11.
intro H12.
intro H13.
exact H12.

---- exact H9.
---- exact H.
---- exact H4.
---- exact H7.
---- exact H8.
--- assert (exists K, (euclidean__axioms.BetS B K H2) /\ (euclidean__axioms.Cong B K B B)) as H11 by exact H10.
destruct H11 as [K H12].
destruct H12 as [H13 H14].
assert (* Cut *) (~(euclidean__axioms.neq B K)) as H15.
---- intro H15.
assert (* Cut *) (euclidean__axioms.neq B B) as H16.
----- apply (@euclidean__axioms.axiom__nocollapse B K B B H15 H14).
----- assert (* Cut *) (B = B) as H17.
------ assert (* Cut *) (False) as H17.
------- assert (* Cut *) (B = B) as H17.
-------- apply (@logic.eq__refl Point B).
-------- apply (@H16 H17).
------- assert (False) as H18 by exact H17.
apply (@logic.eq__refl Point B).
------ apply (@H16 H17).
---- assert (* Cut *) (euclidean__axioms.BetS B B H2) as H16.
----- apply (@eq__ind__r euclidean__axioms.Point K (fun X => euclidean__axioms.BetS B X H2)) with (x := B).
------ exact H13.
------apply (@euclidean__tactics.NNPP (B = K) H15).

----- assert (* Cut *) (euclidean__axioms.neq B B) as H17.
------ assert (* Cut *) ((euclidean__axioms.neq B H2) /\ ((euclidean__axioms.neq B B) /\ (euclidean__axioms.neq B H2))) as H17.
------- apply (@lemma__betweennotequal.lemma__betweennotequal B B H2 H16).
------- destruct H17 as [H18 H19].
destruct H19 as [H20 H21].
exact H20.
------ assert (* Cut *) (B = B) as H18.
------- assert (* Cut *) (False) as H18.
-------- assert (* Cut *) (B = B) as H18.
--------- apply (@logic.eq__refl Point B).
--------- apply (@H17 H18).
-------- assert (False) as H19 by exact H18.
apply (@logic.eq__refl Point B).
------- apply (@H17 H18).
-- assert (* Cut *) (euclidean__axioms.neq A C) as H10.
--- assert (* Cut *) ((euclidean__axioms.neq E C) /\ ((euclidean__axioms.neq A E) /\ (euclidean__axioms.neq A C))) as H10.
---- apply (@lemma__betweennotequal.lemma__betweennotequal A E C H0).
---- destruct H10 as [H11 H12].
destruct H12 as [H13 H14].
exact H14.
--- assert (* Cut *) (exists F, (euclidean__axioms.BetS B A F) /\ (euclidean__axioms.Cong A F A C)) as H11.
---- apply (@lemma__extension.lemma__extension B A A C H8 H10).
---- destruct H11 as [F H12].
destruct H12 as [H13 H14].
assert (* Cut *) (euclidean__axioms.neq E C) as H15.
----- assert (* Cut *) ((euclidean__axioms.neq E C) /\ ((euclidean__axioms.neq A E) /\ (euclidean__axioms.neq A C))) as H15.
------ apply (@lemma__betweennotequal.lemma__betweennotequal A E C H0).
------ destruct H15 as [H16 H17].
destruct H17 as [H18 H19].
exact H16.
----- assert (* Cut *) (exists G, (euclidean__axioms.BetS B E G) /\ (euclidean__axioms.Cong E G E C)) as H16.
------ apply (@lemma__extension.lemma__extension B E E C H9 H15).
------ destruct H16 as [G H17].
destruct H17 as [H18 H19].
assert (* Cut *) (euclidean__axioms.Cong A C A F) as H20.
------- apply (@lemma__congruencesymmetric.lemma__congruencesymmetric A A F C H14).
------- assert (* Cut *) (euclidean__axioms.Cong A E A H2) as H21.
-------- apply (@lemma__congruencesymmetric.lemma__congruencesymmetric A A H2 E H6).
-------- assert (* Cut *) (euclidean__axioms.Cong A E A E) as H22.
--------- apply (@euclidean__axioms.cn__congruencereflexive A E).
--------- assert (* Cut *) (euclidean__defs.Lt A E A C) as H23.
---------- exists E.
split.
----------- exact H0.
----------- exact H22.
---------- assert (* Cut *) (euclidean__defs.Lt A E A F) as H24.
----------- apply (@lemma__lessthancongruence.lemma__lessthancongruence A E A C A F H23 H20).
----------- assert (* Cut *) (euclidean__defs.Lt A H2 A F) as H25.
------------ apply (@lemma__lessthancongruence2.lemma__lessthancongruence2 A E A F A H2 H24 H21).
------------ assert (* Cut *) (euclidean__defs.Out A H2 F) as H26.
------------- exists B.
split.
-------------- exact H13.
-------------- exact H4.
------------- assert (* Cut *) (euclidean__axioms.BetS A H2 F) as H27.
-------------- apply (@lemma__lessthanbetween.lemma__lessthanbetween A H2 F H25 H26).
-------------- assert (* Cut *) (euclidean__axioms.Cong E C H2 F) as H28.
--------------- apply (@lemma__differenceofparts.lemma__differenceofparts A E C A H2 F H21 H20 H0 H27).
--------------- assert (* Cut *) (euclidean__axioms.Cong E G H2 F) as H29.
---------------- apply (@lemma__congruencetransitive.lemma__congruencetransitive E G E C H2 F H19 H28).
---------------- assert (* Cut *) (euclidean__axioms.BetS B H2 F) as H30.
----------------- apply (@lemma__3__7a.lemma__3__7a B A H2 F H4 H27).
----------------- assert (* Cut *) (euclidean__defs.Lt B G B F) as H31.
------------------ apply (@lemma__lessthanadditive.lemma__lessthanadditive B E B H2 G F H7 H18 H30 H29).
------------------ assert (* Cut *) (euclidean__defs.TG B A A C B G) as H32.
------------------- exists F.
split.
-------------------- exact H13.
-------------------- split.
--------------------- exact H14.
--------------------- exact H31.
------------------- assert (* Cut *) (euclidean__defs.TT B A A C B E E C) as H33.
-------------------- exists G.
split.
--------------------- exact H18.
--------------------- split.
---------------------- exact H19.
---------------------- exact H32.
-------------------- exact H33.
Qed.


Require Import List Arith Lia Morphisms Setoid.
From Undecidability.HOU Require Import calculus.calculus.
From Undecidability.HOU Require Import
        unification.higher_order_unification unification.nth_order_unification
        concon.conservativity_constants concon.conservativity concon.constants.
Import ListNotations.

(* ** Goldfarb sharp *)

From Undecidability.HOU Require Import
   second_order.diophantine_equations second_order.goldfarb.reduction.

Definition gonly : Const :=
  {|
    const_type := option False;
    ctype := fun o => match o with
                  | None => alpha → alpha → alpha
                  | Some f => match f with end
                  end

  |}.

#[export]
Program Instance RE_ag_gonly : retract gonly ag :=
  {|
    I := fun _ => None;
    R := fun x => match x with None => Some None | _ => None end
  |}.
Next Obligation.
  now destruct x as [[]|].
Qed.

Lemma Goldfarb_remove:
  H10 ⪯ OU 2 ag /\ OU 2 ag ⪯ OU 2 gonly.
Proof.
  split. eapply Goldfarb.
  eapply (@remove_constants_reduction ag gonly); eauto.
  intros [[]|]; cbn; eauto.
  intros [[[]|]|]; cbn; eauto.
  destruct eq_dec; intuition  discriminate.
Qed.

Lemma Goldfarb_sharp (C: Const) (re: retract gonly C):
  ctype C (I None) = alpha → alpha → alpha -> OU 2 gonly ⪯ OU 2 C.
Proof.
  intros. eapply unification_constants_monotone; eauto.
  intros [[]|]; cbn; eauto.
Qed.

Definition cfree : Const :=
  {|
    const_type := False;
    ctype := fun f => match f with end
  |}.

#[export]
Program Instance RE_cfree X : retract cfree X :=
  {|
    I := fun f => match f with end;
    R := fun x => None
  |}.

Lemma Goldfarb_Huet X:
  OU 2 gonly ⪯ OU 3 gonly /\
  OU 3 gonly ⪯ OU 3 cfree /\
  OU 3 cfree ⪯ OU 3 X.
Proof.
  repeat split.
  eapply unification_step; eauto.
  eapply remove_constants_reduction; eauto.
  intros []. intros [[]|]; cbn; eauto.
  eapply unification_constants_monotone; eauto.
  intros [].
Qed.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

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

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

Theorem pipo_6 : (forall C D P Q Dprime S Y : Universe, ((wd_ C D /\ (wd_ P C /\ (wd_ D Dprime /\ (wd_ C Dprime /\ (wd_ P Q /\ (wd_ P D /\ (wd_ C Q /\ (wd_ S C /\ (wd_ P S /\ (col_ C Y S /\ (col_ D C Dprime /\ col_ C S D))))))))))) -> col_ C D Y)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import Functors.
Require Import List.
Require Import FunctionalExtensionality.
Require Import MonadLib.
Require Import Names.

Section EffectPure.

  (** SuperFunctor for Types. **)
  Variable DT : Set -> Set.
  Context {Fun_DT : Functor DT}.

  (** SuperFunctor for Values. **)
  Variable V : Set -> Set.
  Context {Fun_V : Functor V}.

  (** TYPING **)
  Variable MT : Set -> Set.
  Context {Fun_MT : Functor MT}.
  Context {Mon_MT : Monad MT}.
  Context {Fail_MT : FailMonad MT}.
  Context {MT_eq_dec : forall (A : Set) (mta : MT A),
    {exists a, mta = return_ a} + {mta = fail}}.
  Context {Inj_MT : InjMonad MT}.
  Context {Reasonable_MT : Reasonable_Monad MT}.

  (** EVALUATION **)
  Variable ME : Set -> Set.
  Context {Functor_ME : Functor ME}.
  Context {Monad_ME : Monad ME}.

  Section WFValue_Sec.

    (* ============================================== *)
    (* WELL-FORMED VALUES RELATION                     *)
    (* ============================================== *)

    Variable TypContext : Set.
    Variable WFV : (WFValue_i DT V TypContext -> Prop) -> WFValue_i DT V TypContext -> Prop.

    Inductive WFValueM_base (A : WFValueM_i DT V MT ME TypContext -> Prop) : WFValueM_i DT V MT ME TypContext -> Prop :=
    | WFVM_Return : forall Sigma v (T : DType DT) (mt : MT (DType DT)),
      WFValueC DT V TypContext WFV Sigma v T ->
      {mt' : MT {T' : DType DT | proj1_sig T = proj1_sig T'} &
        fmap (@proj1_sig _ _) mt' = mt} ->
      WFValueM_base A (mk_WFValueM_i DT V MT ME TypContext Sigma (return_ v) mt)
    | WFVM_Untyped : forall B Sigma me (mt : MT B),
      WFValueM_base A (mk_WFValueM_i DT V MT ME TypContext Sigma me (mt >> fail)).

    Definition ind_alg_WFVM_base (P : WFValueM_i DT V MT ME TypContext -> Prop)
      (H_Return : forall Sigma v T mt,
        WFValueC DT V TypContext WFV Sigma v T ->
        {mt' : MT {T' : DType DT | proj1_sig T = proj1_sig T'} &
          fmap (@proj1_sig _ _) mt' = mt} ->
        P (mk_WFValueM_i DT V MT ME TypContext Sigma (return_ v) mt))
      (H_Untyped : forall B Sigma me mt,
        P (mk_WFValueM_i DT V MT ME TypContext Sigma me (mt >> fail)))
      (i : WFValueM_i DT V MT ME TypContext)
      (e : WFValueM_base P i)
      :
      P i :=
      match e in WFValueM_base _ i return P i with
        | WFVM_Return Sigma v T mt WF_v_T WF_mt => H_Return Sigma v T mt WF_v_T WF_mt
        | WFVM_Untyped B Sigma me mt => H_Untyped B Sigma me mt
      end.

    Definition WFVM_base_ifmap
      (A B : WFValueM_i  DT V MT ME TypContext-> Prop)
      (i : WFValueM_i DT V MT ME TypContext)
      (f : forall i, A i -> B i)
      (wfvm_v : WFValueM_base A i)
      :
      WFValueM_base B i :=
      match wfvm_v in WFValueM_base _ i return WFValueM_base B i with
        | WFVM_Return Sigma v T mt WF_v_T WF_mt => WFVM_Return B Sigma v T mt WF_v_T WF_mt
        | WFVM_Untyped C Sigma me mt => WFVM_Untyped B C Sigma me mt
      end.

    Global Instance iFun_WFVM_base : iFunctor WFValueM_base.
      constructor 1 with (ifmap := WFVM_base_ifmap).
      destruct a; simpl; intros; reflexivity.
      destruct a; simpl; intros; auto.
    Defined.

    Lemma WFVM_Return_T : forall A Sigma v T,
      WFValueC DT V TypContext WFV Sigma v T ->
      WFValueM_base A (mk_WFValueM_i DT V MT ME TypContext Sigma (return_ v) (return_ T)).
    Proof.
      intros; constructor 1 with (T := T); auto.
      exists (return_ (exist (fun T' => proj1_sig T = proj1_sig T')
        T (refl_equal (proj1_sig T)))).
      rewrite fmap_m, <- left_unit; reflexivity.
    Qed.

    Lemma WFVM_Untyped_T : forall A Sigma v,
      WFValueM_base A (mk_WFValueM_i DT V MT ME TypContext Sigma (return_ v) fail).
    Proof.
      simpl; intros.
      rewrite left_unit with (a := tt) (f := fun _ => fail).
      intros; constructor 2.
    Qed.

  End WFValue_Sec.

  Section BindRule.

    Variable TypContext : Set.
    Context {TypContextCE : ConsExtensionC TypContext}.

    Variable WFV : (WFValue_i DT V TypContext -> Prop) -> WFValue_i DT V TypContext -> Prop.
    Context {funWFV : iFunctor WFV}.

    Variable WFVM : (WFValueM_i DT V MT ME TypContext -> Prop) -> WFValueM_i DT V MT ME TypContext -> Prop.
    (* Context {funWFVM : iFunctor WFVM}. *)

    Context {WFV_proj1_b_WFV : iPAlgebra WFV_proj1_b_Name (WFV_proj1_b_P DT V TypContext WFV) WFV}.
    Context {Sub_WFVM_Base'_WFVM : Sub_iFunctor (WFValueM_base _ WFV) WFVM}.

    Lemma wfvm_skip Sigma (me : ME (Value V)) (mt : MT (DType DT)) (kt : DType DT -> MT (DType DT))
         (WFVM_me_kt : forall T, WFValueMC DT V MT ME TypContext WFVM Sigma me (kt T)) :
      WFValueMC DT V MT ME TypContext WFVM Sigma me (mt >>= kt).
    Proof.
      destruct (MT_eq_dec _ mt) as [[T mt_eq] | mt_eq]; subst.
      rewrite <- left_unit.
      apply WFVM_me_kt.
      rewrite bind_fail.
      apply inject_i.
      rewrite left_unit with (a := tt) (f := fun _ => fail).
      constructor 2.
    Qed.

    Lemma wfvm_fail : forall Sigma ke,
      WFValueM DT V MT ME TypContext WFVM (mk_WFValueM_i DT V MT ME _ Sigma ke fail).
    Proof.
      intros.
      apply inject_i.
      rewrite left_unit with (a := tt) (f := fun _ => fail).
      constructor 2.
    Qed.

    Global Instance wfvm_bind_base' :
      iPAlgebra wfvm_bind_Name (wfvm_bind_P DT V MT ME TypContext WFV WFVM) (WFValueM_base _ WFV).
    Proof.
      econstructor.
      unfold iAlgebra; intros; apply ind_alg_WFVM_base with (WFV := WFV);
        try assumption; unfold wfvm_bind_P; simpl; intros.
      (* WFVM_Return' *)
      destruct (MT_eq_dec _ mt) as [[T0 mt_eq] | mt_eq]; subst.
      repeat rewrite <- left_unit; eapply WFVM_ke_kt; eauto.
      apply ConsExtension_id.
      destruct H1 as [mt' mt'_eq']; subst.
      destruct (MT_eq_dec _ mt') as [[T' mt'_eq] | mt'_eq]; subst.
      rewrite fmap_return in mt'_eq'.
      apply inj_return in mt'_eq'; subst.
      destruct T'.
      destruct x.
      apply (WFV_proj1_b DT V TypContext WFV _ _ H0); simpl; auto.
      destruct (fmap_exists _ _ _ _ _ mt'_eq') as [[T' T_eq] T'_eq].
      simpl in *; subst; auto.
      destruct T0.
      apply (WFV_proj1_b DT V TypContext WFV _ _ H0); simpl; auto.
      rewrite bind_fail.
      apply wfvm_fail.
      (* WFVM_Untyped' *)
      destruct (MT_eq_dec _ mt) as [[T0 mt_eq] | mt_eq]; subst.
      unfold wbind; rewrite <- left_unit.
      rewrite bind_fail.
      apply wfvm_fail.
      unfold wbind.
      rewrite <- associativity.
      rewrite bind_fail.
      apply wfvm_fail.
    Qed.

  End BindRule.

End EffectPure.

(*
*** Local Variables: ***
*** coq-prog-args: ("-emacs-U" "-impredicative-set") ***
*** End: ***
*)


Require Import BE_semantics.
Require Import BE_syntax.
Require Import BE_trans_set.
Require Import Coq.Lists.ListSet.
Require Import Coq.Lists.List.
Import Coq.Lists.List.ListNotations.
Require Import list_helper.
Require Import LTS.
Require Import PeanoNat.
Require Import String.

(* ======================== helper functions ================================ *)
Definition convertEvent (e : Event) : transition_label :=
  match e with
    | ExternalEvent name => event name
    | InternalEvent      => tau
  end.

Lemma convertEvent_inverse : forall e e',
  convertEvent e = convertEvent e' -> e = e'.
Proof.
  intros.
  destruct e, e'; inversion H; reflexivity.
Qed.

Fixpoint indexOf (B : ProcessBehaviour) (Lb : set ProcessBehaviour) : nat :=
  match Lb with
  | nil => 0
  | B' :: Lb' => if ProcessBehaviourDec B B' then 0 else S (indexOf B Lb')
  end.

Section Converter.

Variable ctx : BehaviourExpressions.
Variable behaviourTransitions : BehaviourTransSet.
Variable startProcess : ProcessName.
Hypothesis definitionOkWithTransition :
  BehaviourTransSetR ctx behaviourTransitions startProcess.

Fixpoint createBehaviourSet (T : BehaviourTransSet)
    : set ProcessBehaviour :=
  match T with
  | nil => nil
  | (B, _, B') :: T' =>
      set_add
        ProcessBehaviourDec
        B
        (set_add ProcessBehaviourDec B' (createBehaviourSet T'))
  end.

Definition behaviours := createBehaviourSet behaviourTransitions.

Definition idOf (B: ProcessBehaviour) : nat := indexOf B behaviours.

Definition startBehaviour : ProcessBehaviour :=
  match getProcessBehaviour startProcess ctx with
    | Some B => B
    | None   => stop
  end.

Fixpoint convertBehaviourTransitionsToLtsTransitions (L : BehaviourTransSet)
    : list transition  :=
  match L with
  | nil => nil
  | (B, e, B') :: L' =>
      (idOf B, convertEvent e, idOf B') ::
      (convertBehaviourTransitionsToLtsTransitions L')
  end.

Fixpoint createLabelSet (L : BehaviourTransSet) : set label :=
  match L with
  | (_, ExternalEvent l, _) :: L' => set_add string_dec l (createLabelSet L')
  | (_, InternalEvent, _) :: L'   => createLabelSet L'
  | nil                           => nil
  end.

(* ============================ LTS parameters ============================== *)
Definition transitions :=
  convertBehaviourTransitionsToLtsTransitions behaviourTransitions.
Definition states := seq 0 (List.length behaviours).
Definition labels := createLabelSet behaviourTransitions.
Definition startState := idOf startBehaviour.

(* =============================== LTS lemmas =============================== *)
Lemma StateSetNotEmpty : behaviourTransitions <> nil -> states <> nil.
Proof.
  intros transNotEmpty.
  unfold states.
  unfold behaviours.
  destruct behaviourTransitions as [| hd tl]; try easy.
  clear transNotEmpty.
  destruct (createBehaviourSet (hd :: tl)) eqn:H.
  - simpl in H.
    destruct hd, p.
    destruct (set_add ProcessBehaviourDec p0 (createBehaviourSet tl)).
    + simpl in H.
      easy.
    + simpl in H.
      destruct (ProcessBehaviourDec p p1); easy.
  - simpl.
    easy.
Qed.

Lemma StateRepresentingBehaviourInStateSet :
  forall B, In B behaviours -> In (idOf B) states.
Proof.
  clear.
  unfold idOf.
  intros.
  unfold states.
  apply in_seq.
  simpl. split; try apply Nat.le_0_l.
  induction behaviours.
  - intros. inversion H.
  - intros. simpl. destruct (ProcessBehaviourDec B a).
    + apply Nat.lt_0_succ.
    + apply Lt.lt_n_S. apply IHs. destruct H; try trivial.
      symmetry in H. easy.
Qed.

Lemma AllBehavioursInBehaviourSet :
  forall (B1 B2 : ProcessBehaviour) (e : Event) (T : BehaviourTransSet),
    In (B1, e, B2) T ->
    In B1 (createBehaviourSet T) /\ In B2 (createBehaviourSet T).
Proof.
  clear.
  intros.
  induction T.
  - inversion H.
  - destruct H.
    + simpl. destruct a, p. inversion H. subst. split; apply set_add_iff.
      * left. reflexivity.
      * right. apply set_add_iff. left. reflexivity.
    + apply IHT in H. destruct H. simpl. destruct a, p.
      split; repeat (apply set_add_iff; right); trivial.
Qed.

Lemma AllEventsInLabelsSet :
  forall (B1 B2 : ProcessBehaviour) (e : EventName),
    In (B1, ExternalEvent e, B2) behaviourTransitions ->
    In e labels.
Proof.
  unfold labels.
  unfold transitions.
  clear.
  intros.
  induction behaviourTransitions; trivial.
  simpl. destruct a, p, e0.
  - apply IHb.
    destruct H.
    + inversion H.
    + apply H.
  - destruct H.
    + inversion H. apply set_add_iff. left. reflexivity.
    + apply set_add_iff. right. apply IHb. apply H.
Qed.

Lemma StartBehaviourInBehaviourSet:
  behaviourTransitions <> nil ->
  In startBehaviour behaviours.
Proof.
  intros.
  unfold behaviours.
  pose proof AllBehavioursInBehaviourSet as inBehaviourSet.
  destruct behaviourTransitions as [ | hd tl]; try easy.
  clear H.
  inversion definitionOkWithTransition as [? ? ? ? Behaviour _ H].
  clear H0 H1 H2.
  subst.
  clear definitionOkWithTransition.
  unfold startBehaviour.
  rewrite <- Behaviour.
  inversion H. subst.
  destruct (transFromB B (hd::tl)) eqn:H'.
  - unfold T' in to_visit. simpl in to_visit. unfold to_visit in H6.
    inversion H6.
  - revert H'. revert inBehaviourSet. clear. intros inBehaviourSet H.
    assert (H' : transFromB B (hd :: tl) <> []).
    { unfold not. intros. rewrite H in H0. inversion H0. }
    apply transFromBNotEmpty in H'. destruct H' as [e [B' H']].
    apply inBehaviourSet in H'. destruct H' as [H' _]. apply H'.
Qed.

Local Open Scope type_scope.

Lemma EachLtsTransitionHasAnEquivalentBehaviour :
  forall (x : BehaviourTransSet) (b1 b2 : state) (l : transition_label) ,
    (forall t, In t x -> In t behaviourTransitions) ->
    In (b1, l, b2) (convertBehaviourTransitionsToLtsTransitions x) ->
    exists (B1 B2 : ProcessBehaviour) (e : Event),
      In (B1, e, B2) x /\ b1 = idOf B1 /\ b2 = idOf B2 /\ l = convertEvent e.
Proof.
  clear.
  unfold idOf.
  intros.
  induction x.
  - inversion H0.
  - simpl in H0.
    destruct a, p.
    simpl in H0.
    destruct H0.
    + exists p, p0, e. inversion H0.
      repeat split; try reflexivity.
      simpl. left. reflexivity.
    + assert((forall t : BehaviourTrans, In t x -> In t behaviourTransitions)).
      {  intros. apply H. right. apply H1. }
      apply IHx in H1; auto.
      destruct H1 as [B1 [B2 [ e' ]]].
      destruct H1 as [H1 [H2 [H3 ]]].
      exists B1, B2, e'.
      repeat split; auto.
      right. apply H1.
Qed.

Local Close Scope type_scope.

Lemma ValidTransitionsEquivalence :
forall (x : list transition) (st : list state) (lb : list label),
  (forall t, In t x -> In t transitions) ->
  (forall (b1 b2 : state) (l : label),
    In (b1, event l, b2) transitions -> In b1 st /\ In b2 st /\ In l lb) ->
  (forall (b1 b2 : state), In (b1, tau, b2) transitions -> In b1 st /\ In b2 st) ->
  each_transition_is_valid x st lb.
Proof.
  clear.
  intros.
  induction x.
  - simpl. apply I.
  - destruct a, p.
    destruct t.
    + simpl. pose proof (H0 s0 s l).
      assert (H3 : In (s0, event l, s) transitions).
      { apply H. simpl. left. reflexivity. }
      apply H2 in H3.
      destruct H3 as [H4 [H5 H6] ].
      repeat split; trivial.
      apply IHx.
      intros.
      apply H.
      simpl. right. apply H3.
    + simpl. pose proof (H1 s0 s).
      assert (H3 : In (s0, tau, s) transitions).
      { apply H. simpl. left. reflexivity. }
      apply H2 in H3.
      destruct H3 as [H4 H5].
      repeat split; trivial.
      apply IHx.
      intros.
      apply H.
      simpl. right. apply H3.
Qed.

Lemma AllEventTransitionsAreValid :
  forall (b1 b2 : state) (l : label),
    In (b1, event l, b2) transitions ->
    In b1 states /\ In b2 states /\ In l labels.
Proof.
  unfold transitions.
  unfold behaviours.
  intros.
  assert (forall x, In x behaviourTransitions -> In x behaviourTransitions).
  { trivial. }
  eapply EachLtsTransitionHasAnEquivalentBehaviour in H0; try apply H.
  destruct H0 as [B1 [B2 [e [H1 [H2 [H3] ] ] ] ] ].
  assert(H5 : In (B1, e, B2) behaviourTransitions). { apply H1. }
  apply AllBehavioursInBehaviourSet in H1.
  destruct H1 as [H1 H1'].
  apply StateRepresentingBehaviourInStateSet in H1.
  apply StateRepresentingBehaviourInStateSet in H1'.
  unfold behaviours in H1, H1'.
  destruct e; inversion H0.
  apply AllEventsInLabelsSet in H5.
  subst.
  repeat split; trivial.
Qed.

Lemma AllInternalTransitionsAreValid :
  forall (b1 b2 : state),
    In (b1, tau, b2) transitions -> In b1 states /\ In b2 states.
Proof.
  unfold transitions.
  unfold behaviours.
  intros.
  assert (forall x, In x behaviourTransitions -> In x behaviourTransitions).
  { trivial. }
  eapply EachLtsTransitionHasAnEquivalentBehaviour in H0; try apply H.
  destruct H0 as [B1 [B2 [e [H1 [H2 [H3] ] ] ] ] ].
  apply AllBehavioursInBehaviourSet in H1.
  destruct H1 as [H1 H1'].
  apply StateRepresentingBehaviourInStateSet in H1.
  apply StateRepresentingBehaviourInStateSet in H1'.
  unfold behaviours in H1, H1'.
  destruct e; inversion H0.
  subst.
  repeat split; trivial.
Qed.

Lemma StartStateInStateSet :
  behaviourTransitions <> nil -> In startState states.
Proof.
  intros transNotEmpty.
  apply StateRepresentingBehaviourInStateSet.
  apply StartBehaviourInBehaviourSet.
  auto.
Qed.

Lemma NoRepetitionStates : NoDup states.
Proof.
  apply seq_NoDup.
Qed.

Lemma NoRepetitionLabels : NoDup labels.
Proof.
  clear.
  unfold labels.
  induction behaviourTransitions.
  - simpl. apply NoDup_nil.
  - simpl. destruct a, p.
    destruct e.
    + apply IHb.
    + apply set_add_nodup. apply IHb.
Qed.

Lemma idOf_inverse :
  forall (B1 B2 : ProcessBehaviour),
    In B1 behaviours -> idOf B1 = idOf B2 -> B1 = B2.
Proof.
  clear.
  unfold idOf.
  intros.
  induction behaviours.
  - inversion H.
  - simpl in H. destruct H.
    + simpl in H0. destruct (ProcessBehaviourDec B1 a); subst.
      * destruct (ProcessBehaviourDec B2 B1); easy.
      * easy.
    + simpl in H0. destruct (ProcessBehaviourDec B1 a); subst.
      * destruct (ProcessBehaviourDec B2 a); easy.
      * destruct (ProcessBehaviourDec B2 a); try easy.
        inversion H0.
        apply IHs; auto.
Qed.

Lemma NoRepetitionTransitions' :
forall (x : BehaviourTransSet),
  (forall t, In t x -> In t behaviourTransitions) ->
  (NoDup x -> NoDup (convertBehaviourTransitionsToLtsTransitions x)).
Proof.
  clear.
  intros.
  induction x.
  - simpl. apply NoDup_nil.
  - simpl. destruct a, p.
    apply NoDup_cons.
    + unfold not. intros.
      apply EachLtsTransitionHasAnEquivalentBehaviour in H1.
      * destruct H1 as [p' [p0' [e']]].
        destruct H1 as [H1 [H2 [H3]]].
        assert(H' : In (p', e', p0') behaviourTransitions).
        { apply H. right. auto. }
        apply AllBehavioursInBehaviourSet in H'.
        destruct H' as [H' H'' ].
        apply idOf_inverse with (B2 := p) in H'; auto.
        apply idOf_inverse with (B2 := p0) in H''; auto.
        apply convertEvent_inverse in H4.
        subst. inversion H0. apply H6 in H1. inversion H1.
      * intros. apply H. right. apply H2.
    + inversion H0. apply IHx; auto. intros. apply H. right. apply H5.
Qed.

Lemma NoRepetitionTransitions : NoDup transitions.
Proof.
  inversion definitionOkWithTransition as [? T P B _ H _].
  clear H0 H1 H2.
  clear definitionOkWithTransition startProcess ctx.
  unfold transitions.
  apply NoRepetitionTransitions'.
  - intros. apply H0.
  - apply H.
Qed.

Definition createLtsFromBehaviourTransSet : LTS.
Proof.
  destruct behaviourTransitions eqn:H.
  - clear.
    refine (mkLTS [0] [] [] 0 _ _ _ _ _ _); try apply NoDup_nil.
    + unfold not. intros. inversion H.
    + simpl. left. reflexivity.
    + simpl. apply I.
    + apply NoDup_cons.
      * unfold not. intros H. inversion H.
      * apply NoDup_nil.
  - refine (mkLTS states labels transitions startState _ _ _ _ _ _);
    rewrite <- H in definitionOkWithTransition.
    + apply StateSetNotEmpty. rewrite H. unfold not. intros H'. inversion H'.
    + apply StartStateInStateSet. rewrite H. unfold not. intros H'.
      inversion H'.
    + eapply ValidTransitionsEquivalence.
      * intros. apply H0.
      * apply AllEventTransitionsAreValid.
      * apply AllInternalTransitionsAreValid.
    + apply NoRepetitionStates.
    + apply NoRepetitionLabels.
    + apply NoRepetitionTransitions.
Defined.

(*behaviours
  In (B1, e, B2) T -> In B1 behaviours /\ In B2 behaviours
  In B behaviours -> exists B' e, In (B, e, B') T \/ In (B', e, B) T
states
  In x states -> exists B, In B behaviours /\ idOf B = x
  In B behaviours -> In (idOf B) states
  In B1 behaviour -> idOf B1 = idOf B2 <-> B1 = B2
labels
  In (B1, ExternalEvent e, B2) T -> In e labels
  In e labels -> exists B1 B2, In (B1, ExternalEvent e, B2) T
transitions
  In (B1, e, B2) T -> In (idOf B1, convert e, idOf B2) transitions
  In (b1, l, b2) transitions ->
    exists B1 e B2,
      In (B1, e, B2) T /\ idOf B1 = b1 /\ idOf B2 = b2 /\ convert e = l
startState
  P ::= B -> startState = idOf B *)

(* ========= createLtsFromBehaviourTransSet correctness theorems ============ *)

(* behaviours theorems *)

Theorem behaviours_complete:
  forall (B1 B2 : ProcessBehaviour) (e : Event),
    In (B1, e, B2) behaviourTransitions -> In B1 behaviours /\ In B2 behaviours.
Proof.
  unfold behaviours.
  intros.
  apply AllBehavioursInBehaviourSet with (e:=e).
  auto.
Qed.

Local Open Scope type_scope.

Theorem behaviours_correct:
  forall (B : ProcessBehaviour),
    In B behaviours ->
    exists (B' : ProcessBehaviour) (e : Event),
      In (B, e, B') behaviourTransitions \/ In (B', e, B) behaviourTransitions.
Proof.
  clear.
  unfold behaviours.
  intros B H.
  induction behaviourTransitions as [| a b IHb].
  - inversion H.
  - simpl in H. destruct a as [[B1 e] B2]. apply set_add_elim in H.
    destruct H as [H | H].
    + subst. exists B2, e. left. left. reflexivity.
    + apply set_add_elim in H. destruct H as [H | H].
      * subst. exists B1, e. right. left. reflexivity.
      * apply IHb in H. destruct H as [B' [e' H]]. exists B', e'.
        destruct H as [H | H]; [left | right]; right; apply H.
Qed.

(* states theorem *)

Lemma NoDup_behaviours: NoDup behaviours.
Proof.
  clear. unfold behaviours. induction behaviourTransitions.
  - simpl. apply NoDup_nil.
  -  simpl. destruct a, p. do 2 apply set_add_nodup. apply IHb.
Qed.

Theorem states_correct:
  forall (x : nat), In x states -> exists B, In B behaviours /\ idOf B = x.
Proof.
  clear.
  unfold states.
  unfold idOf.
  intros x H.
  pose proof (NoDup_behaviours) as H'''.
  remember behaviours as bs' eqn:H'. rewrite H' in H.
  assert(Heq: Datatypes.length behaviours = Datatypes.length bs').
  { rewrite H'. reflexivity. }
  clear H'. generalize dependent bs'. induction behaviours as [|B bs IHbs];
  intros bs' H''' Heq.
  - inversion H.
  - simpl Datatypes.length in H.
    pose proof (Nat.add_comm 1 (Datatypes.length bs)) as H'. simpl in H'.
    rewrite H' in H. rewrite seq_app in H. simpl in H. apply in_app_or in H.
    simpl in Heq.
    assert (H'': exists (B' : ProcessBehaviour) (bs'' : list ProcessBehaviour),
            bs' = bs'' ++ [B']).
    { clear IHbs H' H B H'''. generalize dependent bs.
      induction bs'; intros bs H; [inversion H |]. simpl in H. inversion H.
      destruct bs'; [exists a, []; reflexivity |]. destruct bs; [inversion H1 |].
      apply IHbs' in H1. destruct H1 as [B' [bs'' H']]. exists B', (a :: bs'').
      rewrite H'. simpl. reflexivity. }
    destruct H'' as [B' [bs'' H'']]. rewrite H'' in Heq. rewrite app_length in Heq.
    simpl in Heq. rewrite <- plus_n_Sm in Heq. rewrite Nat.add_comm in Heq.
    simpl in Heq.
    destruct H as [H | H].
    + clear B.
      rewrite H'' in H'''. apply NoDup_app in H'''. destruct H''' as [H''' _].
      inversion Heq. eapply IHbs in H; [| apply H''' | apply H1]. clear H'''.
      destruct H as [B H].
      rewrite H''. exists B. clear IHbs bs' Heq H'' H1 H'. destruct H as [H H'].
      split; [apply in_or_app; auto |]. generalize dependent x.
      induction bs''; [inversion H |]. intros x H'. simpl in H'. simpl in H.
      simpl. destruct (ProcessBehaviourDec B a); auto. destruct H as [H | H].
      * elim n. auto.
      * destruct x; [inversion H'|]. inversion H'. apply f_equal. apply IHbs''; auto.
    + destruct H; [| inversion H]. clear IHbs H'. inversion Heq. rewrite H in H1.
      rewrite H1. rewrite H''. rewrite H'' in H'''. clear H Heq bs H'' H1 x B.
      exists B'. induction bs''.
      * split; simpl; auto. destruct (ProcessBehaviourDec B' B'); easy.
      * simpl in H'''. inversion H'''. apply IHbs'' in H2.
        destruct H2 as [H' H'']. simpl. rewrite H''. split; auto.
        destruct (ProcessBehaviourDec B' a); auto. subst. easy.
Qed.

Theorem states_complete : forall B, In B behaviours -> In (idOf B) states.
Proof.
  apply StateRepresentingBehaviourInStateSet.
Qed.

(* idOf *)
Theorem idOf_injective:
  forall B1 B2, In B1 behaviours -> idOf B1 = idOf B2 <-> B1 = B2.
Proof.
  split.
  - apply idOf_inverse. apply H.
  - intros H'. rewrite H'. easy.
Qed.

(* labels *)
Theorem labels_complete:
  forall (B1 B2 : ProcessBehaviour) (e : EventName),
    In (B1, ExternalEvent e, B2) behaviourTransitions -> In e labels.
Proof.
  apply AllEventsInLabelsSet.
Qed.

Theorem labels_correct:
  forall e,
    In e labels -> exists B1 B2, In (B1, ExternalEvent e, B2) behaviourTransitions.
Proof.
  clear.
  unfold labels. intros e H. induction behaviourTransitions.
  - inversion H.
  - simpl in H. destruct a, p. destruct e0.
    + apply IHb in H. destruct H as [B1 [B2 H]]. exists B1, B2. right. auto.
    + apply set_add_elim in H. destruct H as [H | H].
      * exists p, p0. rewrite H. left. auto.
      * apply IHb in H. destruct H as [B1 [B2 H]]. exists B1, B2. right. auto.
Qed.

(* transitions *)
Theorem transitions_complete:
  forall (B1 B2 : ProcessBehaviour) (e : Event),
    In (B1, e, B2) behaviourTransitions ->
    In (idOf B1, convertEvent e, idOf B2) transitions.
Proof.
  clear. unfold transitions. induction behaviourTransitions.
  - intros B1 B2 e H. inversion H.
  - intros B1 B2 e H. destruct a, p. destruct H as [H | H].
    + inversion H. simpl. left. reflexivity.
    + simpl. right. apply IHb. apply H.
Qed.

Theorem transitions_correct:
  forall (b1 b2 : nat) (l : transition_label),
  In (b1, l, b2) transitions ->
    exists B1 B2 e,
      In (B1, e, B2) behaviourTransitions /\
      b1 = idOf B1 /\ b2 = idOf B2 /\ l = convertEvent e.
Proof.
  clear. unfold transitions. intros b1 b2 l H.
  apply EachLtsTransitionHasAnEquivalentBehaviour in H; auto.
Qed.

(* startState *)
Theorem startState_correct:
  forall B, Some B = getProcessBehaviour startProcess ctx -> startState = idOf B.
Proof.
  clear. intros B H. unfold startState. unfold startBehaviour. rewrite <- H. auto.
Qed.

End Converter.


Require Import Coq.Logic.FunctionalExtensionality.
Require Import Coq.Logic.Classical_Prop.
Require Import Coq.Logic.Classical_Pred_Type.
Require Import Logic.lib.Ensembles_ext.
Require Import Logic.lib.Bijection.
Require Import Logic.lib.Countable.
Require Import Logic.GeneralLogic.Base.
Require Import Logic.GeneralLogic.KripkeModel.
Require Import Logic.GeneralLogic.ProofTheory.BasicSequentCalculus.
Require Import Logic.GeneralLogic.Semantics.Kripke.
Require Import Logic.GeneralLogic.Complete.ContextProperty.
Require Import Logic.GeneralLogic.Complete.ContextProperty_Kripke.
Require Import Logic.GeneralLogic.Complete.Lindenbaum.
Require Import Logic.MinimunLogic.Syntax.
Require Import Logic.MinimunLogic.ProofTheory.Minimun.
Require Import Logic.MinimunLogic.Semantics.Kripke.
Require Import Logic.MinimunLogic.Complete.ContextProperty_Kripke.
Require Import Logic.PropositionalLogic.Syntax.
Require Import Logic.PropositionalLogic.ProofTheory.Intuitionistic.
Require Import Logic.PropositionalLogic.ProofTheory.DeMorgan.
Require Import Logic.PropositionalLogic.ProofTheory.GodelDummett.
Require Import Logic.PropositionalLogic.ProofTheory.Classical.
Require Import Logic.PropositionalLogic.Semantics.Kripke.
Require Import Logic.PropositionalLogic.Complete.ContextProperty_Kripke.
Require Import Logic.PropositionalLogic.Complete.Canonical_Kripke.
Require Import Logic.SeparationLogic.Syntax.
Require Import Logic.SeparationLogic.ProofTheory.SeparationLogic.
Require Import Logic.SeparationLogic.ProofTheory.RewriteClass.
Require Import Logic.SeparationLogic.ProofTheory.DerivedRules.
Require Import Logic.SeparationLogic.Model.SeparationAlgebra.
Require Import Logic.SeparationLogic.Model.OrderedSA.
Require Import Logic.SeparationLogic.Semantics.FlatSemantics.
Require Import Logic.SeparationLogic.Complete.ContextProperty_Flat.

Local Open Scope logic_base.
Local Open Scope syntax.
Local Open Scope kripke_model.
Import PropositionalLanguageNotation.
Import SeparationLogicNotation.
Import KripkeModelFamilyNotation.
Import KripkeModelNotation_Intuitionistic.

Section Canonical.

Context {L: Language}
        {minL: MinimunLanguage L}
        {pL: PropositionalLanguage L}
        {sL: SeparationLanguage L}
        {Gamma: ProofTheory L}
        {SC: NormalSequentCalculus L Gamma}
        {bSC: BasicSequentCalculus L Gamma}
        {minSC: MinimunSequentCalculus L Gamma}
        {ipSC: IntuitionisticPropositionalSequentCalculus L Gamma}
        {AX: NormalAxiomatization L Gamma}
        {minAX: MinimunAxiomatization L Gamma}
        {ipGamma: IntuitionisticPropositionalLogic L Gamma}
        {sGamma: SeparationLogic L Gamma}
        {MD: Model}
        {kMD: KripkeModel MD}
        {M: Kmodel}
        {R: Relation (Kworlds M)}
        {J: Join (Kworlds M)}
        {SM: Semantics L MD}
        {fsSM: SeparatingSemantics L MD M SM}.

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

Hypothesis H_R: forall m n Phi Psi, rel m Phi -> rel n Psi -> (m <= n <-> Included _ (proj1_sig Phi) (proj1_sig Psi)).

Hypothesis H_J: forall m1 m2 m Phi1 Phi2 Phi, rel m1 Phi1 -> rel m2 Phi2 -> rel m Phi -> (join m1 m2 m <-> Included _ (context_sepcon (proj1_sig Phi1) (proj1_sig Phi2)) (proj1_sig Phi)).

Instance SA
         (AL_DC: at_least derivable_closed cP)
         (LIN_SR: forall (Phi: context) (Psi: sig cP), Lindenbaum_constructable (context_sepcon_included_r Phi (proj1_sig Psi)) cP):
  SeparationAlgebra (Kworlds M).
Proof.
  constructor.
  + intros.
    destruct (im_bij _ _ rel m1) as [Phi1 ?].
    destruct (im_bij _ _ rel m2) as [Phi2 ?].
    destruct (im_bij _ _ rel m) as [Phi ?].
    erewrite H_J in H |- * by eauto.
    hnf; intros.
    destruct H3 as [y [z [? [? ?]]]].
    subst.
    rewrite derivable_closed_element_derivable by (apply AL_DC, (proj2_sig Phi)).
    rewrite sepcon_comm.
    rewrite <- derivable_closed_element_derivable by (apply AL_DC, (proj2_sig Phi)).
    apply H.
    exists z, y; split; [| split]; auto.
  + intros.
    destruct (im_bij _ _ rel mx) as [Phi_x ?].
    destruct (im_bij _ _ rel my) as [Phi_y ?].
    destruct (im_bij _ _ rel mz) as [Phi_z ?].
    destruct (im_bij _ _ rel mxy) as [Phi_xy ?].
    destruct (im_bij _ _ rel mxyz) as [Phi_xyz ?].
    erewrite H_J in H, H0 by eauto.
    assert (Included _ (context_sepcon (proj1_sig Phi_x)
             (context_sepcon (proj1_sig Phi_y) (proj1_sig Phi_z))) (proj1_sig Phi_xyz)).
    - hnf; intros xyz ?.
      destruct H6 as [x [yz [? [? ?]]]]; subst xyz.
      apply context_sepcon_derivable in H8.
      destruct H8 as [y [z [? [? ?]]]].
      rewrite derivable_closed_element_derivable by (apply AL_DC, (proj2_sig Phi_xyz)).
      rewrite <- H6, sepcon_assoc.
      rewrite <- derivable_closed_element_derivable by (apply AL_DC, (proj2_sig Phi_xyz)).
      apply H0.
      exists (x * y), z; split; [| split]; auto.
      rewrite <- derivable_closed_element_derivable by (apply AL_DC, (proj2_sig Phi_xy)).
      apply H.
      exists x, y; split; [| split]; auto.
    - apply LIN_SR in H6.
      destruct H6 as [Phi_yz [? ?]].
      unfold context_sepcon_included_r in H7.
      destruct (su_bij _ _ rel Phi_yz) as [myz ?].
      exists myz.
      erewrite !H_J by eauto.
      auto.
Qed.

Instance uSA
         (AL_DC: at_least derivable_closed cP):
  UpwardsClosedSeparationAlgebra (Kworlds M).
Proof.
  hnf; intros.
  exists m1, m2.
  destruct (im_bij _ _ rel n) as [Psi ?].
  destruct (im_bij _ _ rel m1) as [Phi1 ?].
  destruct (im_bij _ _ rel m2) as [Phi2 ?].
  destruct (im_bij _ _ rel m) as [Phi ?].
  erewrite H_J in H |- * by eauto.
  erewrite H_R in H0 by eauto.
  do 2 erewrite H_R by eauto.
  split; [| split].
  + eapply Included_trans; eauto.
  + hnf; intros; auto.
  + hnf; intros; auto.
Qed.

Instance dSA
         (AL_DC: at_least derivable_closed cP):
  DownwardsClosedSeparationAlgebra (Kworlds M).
Proof.
  hnf; intros.
  exists m.
  destruct (im_bij _ _ rel n1) as [Psi1 ?].
  destruct (im_bij _ _ rel n2) as [Psi2 ?].
  destruct (im_bij _ _ rel m1) as [Phi1 ?].
  destruct (im_bij _ _ rel m2) as [Phi2 ?].
  destruct (im_bij _ _ rel m) as [Phi ?].
  erewrite H_J in H |- * by eauto.
  erewrite H_R in H0, H1 |- * by eauto.
  split.
  + eapply Included_trans; eauto.
    hnf; intros z [x [y [? [? ?]]]]; subst.
    exists x, y.
    split; [| split]; auto.
    - eapply deduction_weaken; eauto.
    - eapply deduction_weaken; eauto.
  + hnf; intros; auto.
Qed.

Lemma garbage_collected_canonical_increaing
      {gcsGamma: GarbageCollectSeparationLogic L Gamma}
      (AL_DC: at_least derivable_closed cP):
  IncreasingSeparationAlgebra (Kworlds M).
Proof.
  constructor.
  intros m; hnf; intros n1 n2 ?.
  destruct (im_bij _ _ rel n1) as [Psi1 ?].
  destruct (im_bij _ _ rel n2) as [Psi2 ?].
  destruct (im_bij _ _ rel m) as [Phi ?].
  erewrite H_R by eauto.
  erewrite H_J in H by eauto.
  unfold Included, Ensembles.In; intros.
  rewrite derivable_closed_element_derivable in H3 by (apply AL_DC, (proj2_sig Psi1)).
  rewrite derivable_closed_element_derivable by (apply AL_DC, (proj2_sig Psi2)).
  rewrite <- (sepcon_elim2 TT).
  rewrite <- derivable_closed_element_derivable by (apply AL_DC, (proj2_sig Psi2)).
  apply H; auto.
  exists TT, x; split; [| split]; auto.
  apply derivable_impp_refl.
Qed.

Lemma ext_canonical_residual
      {ExtSGamma: ExtSeparationLogic L Gamma}
      (AL_DC: at_least derivable_closed cP)
      (LIN_SL: forall (Phi: context) (Psi: sig cP), Lindenbaum_constructable (context_sepcon_included_l Phi (proj1_sig Psi)) cP):
  ResidualSeparationAlgebra (Kworlds M).
Proof.
  constructor.
  intros.
  destruct (im_bij _ _ rel n) as [Phi ?].
  assert (Included _ (context_sepcon (Union _ empty_context (Singleton _ TT)) (proj1_sig Phi)) (proj1_sig Phi)).
  + hnf; intros.
    destruct H0 as [y [z [? [? ?]]]].
    rewrite deduction_theorem, <- provable_derivable in H1.
    rewrite derivable_closed_element_derivable by (apply AL_DC, (proj2_sig Phi)).
    subst; rewrite <- H1.
    rewrite <- sepcon_comm, <- sepcon_ext; auto.
  + apply LIN_SL in H0.
    destruct H0 as [Psi [? ?]].
    destruct (su_bij _ _ rel Psi) as [m ?].
    exists m.
    exists n; split.
    - erewrite H_J by eauto.
      auto.
    - erewrite H_R by eauto.
      hnf; intros; auto.
Qed.

Context {s'L: SeparationEmpLanguage L}
        {EmpsGamma: EmpSeparationLogic L Gamma}
        {feSM: EmpSemantics L MD M SM}.

Instance unitSA
         (AL_DC: at_least derivable_closed cP)
         (LIN_SR: forall (Phi: context) (Psi: sig cP), Lindenbaum_constructable (context_sepcon_included_r Phi (proj1_sig Psi)) cP)
         (TRUTH: forall x, forall m Phi, rel m Phi -> (KRIPKE: M, m |= x <-> proj1_sig Phi x)):
  UnitalSeparationAlgebra (Kworlds M).
Proof.
  intros.
  constructor.
  intros.
  destruct (im_bij _ _ rel n) as [Phi ?].
  assert (Included _ (context_sepcon (proj1_sig Phi) (Union _ empty_context (Singleton _ emp))) (proj1_sig Phi)).
  + hnf; intros.
    destruct H0 as [y [z [? [? ?]]]].
    rewrite deduction_theorem, <- provable_derivable in H2.
    rewrite derivable_closed_element_derivable by (apply AL_DC, (proj2_sig Phi)).
    subst; rewrite <- H2, sepcon_emp; auto.
  + apply LIN_SR in H0.
    destruct H0 as [Psi [? ?]].
    destruct (su_bij _ _ rel Psi) as [m ?].
    exists m.
    split; [exists n; split |].
    - apply (@join_comm _ _ (SA AL_DC LIN_SR)).
      erewrite H_J by eauto.
      auto.
    - erewrite H_R by eauto.
      hnf; intros; auto.
    - clear H1 n Phi H.
      specialize (H0 emp ltac:(right; constructor)).
      unfold Ensembles.In in H0.
      rewrite <- (TRUTH emp) in H0 by eauto.
      rewrite sat_emp in H0; auto.
Qed.

Lemma nonsplit_canonical_split_smaller
      {nssGamma: NonsplitEmpSeparationLogic L Gamma}
      (AL_DC: at_least derivable_closed cP)
      (TRUTH: forall x, forall m Phi, rel m Phi -> (KRIPKE: M, m |= x <-> proj1_sig Phi x)):
  IncreasingSplitSmallerSeparationAlgebra (Kworlds M).
Proof.
  hnf; intros.
  destruct (im_bij _ _ rel m1) as [Phi1 ?].
  destruct (im_bij _ _ rel m2) as [Phi2 ?].
  destruct (im_bij _ _ rel m) as [Phi ?].
  erewrite H_J in H0 by eauto.
  erewrite H_R by eauto.
  unfold Included, Ensembles.In; intros x ?.
  rewrite derivable_closed_element_derivable by (apply AL_DC, (proj2_sig Phi)).
  rewrite <- (emp_sepcon_truep_elim x).
  apply deduction_andp_intros.
  + apply derivable_assum; apply H0.
    exists x, TT; split; [| split]; auto.
    - apply derivable_assum; auto.
    - apply derivable_impp_refl.
  + rewrite <- derivable_closed_element_derivable by (apply AL_DC, (proj2_sig Phi)).
    rewrite <- (TRUTH emp) by eauto.
    rewrite sat_emp; auto.
Qed.

Lemma dup_canonical_incr_join
      {desGamma: DupEmpSeparationLogic L Gamma}
      (AL_DC: at_least derivable_closed cP)
      (TRUTH: forall x, forall m Phi, rel m Phi -> (KRIPKE: M, m |= x <-> proj1_sig Phi x)):
  IncreasingJoinSelfSeparationAlgebra (Kworlds M).
Proof.
  hnf; intros.
  destruct (im_bij _ _ rel m) as [Phi ?].
  erewrite H_J by eauto.
  intros z [x [y [? [? ?]]]]; subst.
  rewrite derivable_closed_element_derivable by (apply AL_DC, (proj2_sig Phi)); auto.
  rewrite <- (andp_elim1 x y).
  rewrite <- (andp_elim2 x y) at 2.
  rewrite <- emp_dup.
  apply deduction_andp_intros; [apply deduction_andp_intros |]; auto.
  rewrite <- derivable_closed_element_derivable by (apply AL_DC, (proj2_sig Phi)); auto.
  unfold Ensembles.In; rewrite <- (TRUTH emp) by eauto.
  rewrite sat_emp; auto.
Qed.

End Canonical.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

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

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

Theorem pipo_6 : (forall P Q A C R B : Universe, ((wd_ P Q /\ (wd_ A R /\ (wd_ B R /\ (wd_ C P /\ (wd_ C Q /\ (wd_ A P /\ (wd_ A Q /\ (col_ R P Q /\ (col_ P Q B /\ (col_ P B R /\ (col_ R P A /\ col_ R A B))))))))))) -> col_ A P Q)).
Proof.
  time tac.
Qed.

End FOFProblem.


From isla Require Import opsem.

Definition a18218 : isla_trace :=
  Smt (DeclareConst 38%Z (Ty_BitVec 64%N)) Mk_annot :t:
  ReadReg "R0" [] (RegVal_Base (Val_Symbolic 38%Z)) Mk_annot :t:
  Smt (DefineConst 39%Z (Val (Val_Symbolic 38%Z) Mk_annot)) Mk_annot :t:
  Smt (DefineConst 44%Z (Manyop (Bvmanyarith Bvadd) [Manyop (Bvmanyarith Bvadd) [Unop (ZeroExtend 64%N) (Val (Val_Symbolic 39%Z) Mk_annot) Mk_annot; Val (Val_Bits (BV 128%N 0xfffffffffffffffe%Z)) Mk_annot] Mk_annot; Val (Val_Bits (BV 128%N 0x1%Z)) Mk_annot] Mk_annot)) Mk_annot :t:
  Smt (DefineConst 48%Z (Unop (Extract 63%N 0%N) (Val (Val_Symbolic 44%Z) Mk_annot) Mk_annot)) Mk_annot :t:
  Smt (DefineConst 61%Z (Manyop Concat [Manyop Concat [Manyop Concat [Manyop (Bvmanyarith Bvor) [Manyop (Bvmanyarith Bvand) [Val (Val_Bits (BV 1%N 0x0%Z)) Mk_annot; Unop (Bvnot) (Val (Val_Bits (BV 1%N 0x1%Z)) Mk_annot) Mk_annot] Mk_annot; Unop (Extract 0%N 0%N) (Binop ((Bvarith Bvlshr)) (Val (Val_Symbolic 48%Z) Mk_annot) (Unop (Extract 63%N 0%N) (Val (Val_Bits (BV 128%N 0x3f%Z)) Mk_annot) Mk_annot) Mk_annot) Mk_annot] Mk_annot; Ite (Binop (Eq) (Val (Val_Symbolic 48%Z) Mk_annot) (Val (Val_Bits (BV 64%N 0x0%Z)) Mk_annot) Mk_annot) (Val (Val_Bits (BV 1%N 0x1%Z)) Mk_annot) (Val (Val_Bits (BV 1%N 0x0%Z)) Mk_annot) Mk_annot] Mk_annot; Ite (Binop (Eq) (Unop (ZeroExtend 64%N) (Val (Val_Symbolic 48%Z) Mk_annot) Mk_annot) (Val (Val_Symbolic 44%Z) Mk_annot) Mk_annot) (Val (Val_Bits (BV 1%N 0x0%Z)) Mk_annot) (Val (Val_Bits (BV 1%N 0x1%Z)) Mk_annot) Mk_annot] Mk_annot; Ite (Binop (Eq) (Unop (SignExtend 64%N) (Val (Val_Symbolic 48%Z) Mk_annot) Mk_annot) (Manyop (Bvmanyarith Bvadd) [Manyop (Bvmanyarith Bvadd) [Unop (SignExtend 64%N) (Val (Val_Symbolic 39%Z) Mk_annot) Mk_annot; Val (Val_Bits (BV 128%N 0xfffffffffffffffffffffffffffffffe%Z)) Mk_annot] Mk_annot; Val (Val_Bits (BV 128%N 0x1%Z)) Mk_annot] Mk_annot) Mk_annot) (Val (Val_Bits (BV 1%N 0x0%Z)) Mk_annot) (Val (Val_Bits (BV 1%N 0x1%Z)) Mk_annot) Mk_annot] Mk_annot)) Mk_annot :t:
  Smt (DefineConst 63%Z (Unop (Extract 3%N 3%N) (Val (Val_Symbolic 61%Z) Mk_annot) Mk_annot)) Mk_annot :t:
  WriteReg "PSTATE" [Field "N"] (RegVal_Struct [("N", RegVal_Base (Val_Symbolic 63%Z))]) Mk_annot :t:
  Smt (DefineConst 64%Z (Unop (Extract 2%N 2%N) (Val (Val_Symbolic 61%Z) Mk_annot) Mk_annot)) Mk_annot :t:
  WriteReg "PSTATE" [Field "Z"] (RegVal_Struct [("Z", RegVal_Base (Val_Symbolic 64%Z))]) Mk_annot :t:
  Smt (DefineConst 65%Z (Unop (Extract 1%N 1%N) (Val (Val_Symbolic 61%Z) Mk_annot) Mk_annot)) Mk_annot :t:
  WriteReg "PSTATE" [Field "C"] (RegVal_Struct [("C", RegVal_Base (Val_Symbolic 65%Z))]) Mk_annot :t:
  Smt (DefineConst 66%Z (Unop (Extract 0%N 0%N) (Val (Val_Symbolic 61%Z) Mk_annot) Mk_annot)) Mk_annot :t:
  WriteReg "PSTATE" [Field "V"] (RegVal_Struct [("V", RegVal_Base (Val_Symbolic 66%Z))]) Mk_annot :t:
  Smt (DeclareConst 67%Z (Ty_BitVec 64%N)) Mk_annot :t:
  ReadReg "_PC" [] (RegVal_Base (Val_Symbolic 67%Z)) Mk_annot :t:
  Smt (DefineConst 68%Z (Manyop (Bvmanyarith Bvadd) [Val (Val_Symbolic 67%Z) Mk_annot; Val (Val_Bits (BV 64%N 0x4%Z)) Mk_annot] Mk_annot)) Mk_annot :t:
  WriteReg "_PC" [] (RegVal_Base (Val_Symbolic 68%Z)) Mk_annot :t:
  tnil
.


(** The Rezk completion *)
Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.

Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.whiskering.

Require Import prelude.cubical_methods.

Local Open Scope cat.

Module Export rezk.
  Private Inductive rezk (C : category) : UU :=
  | rcl : ob C → rezk C.

  Axiom rcleq
    : ∏ (C : category) {x₁ x₂ : C} (f : z_iso x₁ x₂),
      rcl C x₁ = rcl C x₂.

  Axiom re
    : ∏ (C : category) (x : C),
      rcleq C (identity_z_iso x) = idpath (rcl C x).

  Axiom rconcat
    : ∏ (C : category)
        {x₁ x₂ x₃ : C}
        (f₁ : z_iso x₁ x₂) (f₂ : z_iso x₂ x₃),
      rcleq C (z_iso_comp f₁ f₂) = rcleq C f₁ @ rcleq C f₂.

  Definition rinv
    : ∏ (C : category) {x₁ x₂ : C} (f : z_iso x₁ x₂),
      rcleq C (z_iso_inv f) = !(rcleq C f).
  Proof.
    intros C x₁ x₂ f.
    apply path_inverse_from_right.
    rewrite pathsinv0inv0.
    rewrite <- rconcat.
    refine (_ @ re _ x₁).
    apply maponpaths.
    use subtypePath.
    {
      intro.
      apply isaprop_is_z_isomorphism.
    }
    exact (z_iso_inv_after_z_iso f).
  Qed.

  Axiom rtrunc
    : ∏ (C : category), isofhlevel 3 (rezk C).

  Section rezk_ind.
    Variable (C : category)
            (Y : rezk C → UU)
            (rclY : ∏ (x : C), Y(rcl C x))
            (rcleqY : ∏ (x₁ x₂ : C) (f : z_iso x₁ x₂),
                PathOver (rcleq C f) (rclY x₁) (rclY x₂))
            (reY : ∏ (x : C), globe_over
                                Y
                                (re C x)
                                (rcleqY x x (identity_z_iso x))
                                (idpath (rclY x)))
            (rconcatY : ∏ (x₁ x₂ x₃ : C)
                         (f₁ : z_iso x₁ x₂) (f₂ : z_iso x₂ x₃),
                globe_over
                  Y
                  (rconcat C f₁ f₂)
                  (rcleqY x₁ x₃ (z_iso_comp f₁ f₂))
                  (composePathOver
                     (rcleqY x₁ x₂ f₁)
                     (rcleqY x₂ x₃ f₂)))
            (truncY : ∏ (x : rezk C), isofhlevel 3 (Y x)).

    Fixpoint rezk_ind (x : rezk C) : Y x
      := (match x with
         | rcl _ a => fun _ _ _ _ => rclY a
          end) rcleqY reY rconcatY truncY.

    Axiom rezk_ind_beta_rcleq : ∏ (x₁ x₂ : C) (f : z_iso x₁ x₂),
        apd rezk_ind (rcleq C f)
        =
        rcleqY x₁ x₂ f.
  End rezk_ind.
End rezk.

Arguments rezk_ind {C} Y rclY rcleqY reY rconcatY truncY.


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

(***
Modulus : 2^129 - 25
Base: 32.25
***)

Definition curve : CurveParameters :=
  {|
    sz := 4%nat;
    base := 32 + 1/4;
    bitwidth := 64;
    s := 2^129;
    c := [(1, 25)];
    carry_chains := Some [seq 0 (pred 4); [0; 1]]%nat;

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

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

    mul_code := None;

    square_code := None;

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

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


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

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

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

Theorem pipo_6 : (forall O A B C Oprime Aprime Bprime Cprime X : Universe, ((wd_ O A /\ (wd_ Oprime Aprime /\ (wd_ A C /\ (wd_ Aprime Cprime /\ (wd_ B C /\ (wd_ Bprime Cprime /\ (wd_ O B /\ (wd_ A Aprime /\ (wd_ O Aprime /\ (wd_ A Cprime /\ (wd_ C Aprime /\ (wd_ C Cprime /\ (wd_ O Oprime /\ (wd_ A Oprime /\ (wd_ B Cprime /\ (wd_ Bprime C /\ (col_ O A B /\ (col_ O B C /\ (col_ O A C /\ (col_ Oprime Aprime Bprime /\ (col_ Oprime Bprime Cprime /\ (col_ Oprime Aprime Cprime /\ (col_ X B C /\ (col_ X Bprime Cprime /\ col_ X O B)))))))))))))))))))))))) -> col_ X O A)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import Coq.Strings.String.
Require Import Coq.Lists.List.
Require Import Coq.ZArith.ZArith.
Require Import bedrock2.Array.
Require Import bedrock2.Map.Separation.
Require Import bedrock2.Map.SeparationLogic.
Require Import bedrock2.ProgramLogic.
Require Import bedrock2.Semantics.
Require Import bedrock2.Syntax.
Require Import bedrock2.WeakestPrecondition.
Require Import bedrock2.WeakestPreconditionProperties.
Require Import bedrock2.ZnWords.
Require Import coqutil.Word.Interface.
Require Import coqutil.Word.Properties.
Require Import coqutil.Map.Interface.
Require Import coqutil.Map.Properties.
Require Import coqutil.Byte.
Require Import Bedrock2Experiments.StateMachineSemantics.
Require Import HmacSpec.SHA256.
Require Import HmacSoftware.HmacSemantics.
Require Import HmacSoftware.HmacProperties.
Require Import HmacSoftware.Sha256Example.
Import Syntax.Coercions List.ListNotations HList.
Local Open Scope string_scope.
Local Open Scope list_scope.
Local Open Scope Z_scope.

Section Proofs.
  Context {word: word.word 32} {mem: map.map word byte}
          {word_ok: word.ok word} {mem_ok: map.ok mem}.
  Context {timing: timing}.

  (* Plug in the right state machine parameters; typeclass inference struggles here *)
  Local Notation execution := (execution (M:=hmac_state_machine)).

  Notation bytearray := (array (mem := mem) ptsto (word.of_Z 1)).

  Definition sha256_post(input_addr: word)(input: list byte)(digest_addr: word)(R: mem -> Prop)
             (tr: trace)(m: mem)(rets: list word): Prop :=
    rets = [] /\
    execution tr (IDLE (sha256 input) (* digest has been read, but still in device *)
                       {| hmac_done := false; (* done flag was already cleared *)
                          intr_enable := word.of_Z 0;
                          hmac_en := false;
                          sha_en := true;
                          swap_endian := true;
                          swap_digest := false; |}) /\
    (* digest has been stored at correct memory location: *)
    (bytearray digest_addr (sha256 input) *
    (* input and rest of memory unmodified: *)
     bytearray input_addr input * R)%sep m.

  Global Instance spec_of_sha256 : spec_of b2_sha256 :=
    fun function_env =>
      forall tr (m: mem) (R : mem -> Prop) (idlebuffer: list byte) (idleconfig: idle_data)
             (input_addr input_len digest_addr: word) (input digest_trash: list byte),
      Z.of_nat (length input) = word.unsigned input_len ->
      Z.of_nat (length digest_trash) = 32 ->
      input_addr <> word.of_Z 0 ->
      digest_addr <> word.of_Z 0 ->
      (bytearray input_addr input * bytearray digest_addr digest_trash * R)%sep m ->
      execution tr (IDLE idlebuffer idleconfig) ->
      call function_env b2_sha256 tr m [digest_addr; input_addr; input_len]
           (sha256_post input_addr input digest_addr R).

  Lemma sha256_correct :
    program_logic_goal_for_function! b2_sha256.
  Proof.
    repeat straightline.
    straightline_call. 1: ecancel_assumption. 1: eassumption.
    repeat straightline.
    straightline_call. 1: symmetry; eassumption. 1: assumption. 1: ecancel_assumption. 1: eassumption.
    repeat straightline.
    straightline_call. 1: eassumption. 1: assumption. 1: ecancel_assumption. 1: eassumption.
    repeat straightline.
    unfold sha256_post.
    split; [reflexivity|]. split; [assumption|].
    rewrite List.app_nil_l in *. ecancel_assumption.
  Qed.
End Proofs.


Require Import Effects.

Set Universe Polymorphism.
Set Primitive Projections.

Module Type S.
Axiom E@{i} : Type@{i}.
End S.

Module Make(Import M : S).

Inductive M (A : Type) :=
| Ok : A -> M A
| Err : E -> M A.

Definition ret {A} (x : A) := Ok _ x.

Definition map {A B} (f : A -> B) (l : M A) : M B :=
match l with
| Ok _ x => Ok _ (f x)
| Err _ e => Err _ e
end.

Definition pointwise {A} (f : A -> Type) (l : M A) : Type :=
match l with
| Ok _ x => f x
| Err _ _ => unit
end.

Fixpoint bind {A B} (l : M A) (f : A -> M B) : M B :=
match l with
| Ok _ x => f x
| Err _ e => Err _ e
end.

(** Those are derived constructions. TODO: implement me automagically *)

Definition TYPE := sig Type (fun A => M A -> A).

Definition El (A : M TYPE) : TYPE :=
match A with
| Ok _ X => X
| Err _ e => exist Type (fun A => M A -> A) unit (fun _ => tt)
end.

(** To be defined *)

Definition hbind {A} {B : M TYPE} (x : M A) (f : A -> (El B).(wit)) : (El B).(wit) :=
match x with
| Ok _ x => f x
| Err _ e => (El B).(prf) (Err _ e)
end.

(** More derived stuff *)

Definition Free (A : Type) : M TYPE :=
  ret (exist Type (fun A => M A -> A) (M A) (fun x => bind x (fun x => x))).

Definition Typeᵉ : M TYPE := Free TYPE.

(* Check Typeᵉ : (El Typeᵉ).(wit). *)

Definition Prodᵉ (A : M TYPE) (B : (El A).(wit) -> M TYPE) : M TYPE.
Proof.
refine (ret (exist _ _ (forall x : (El A).(wit), (El (B x)).(wit)) _)).
refine (fun f x => hbind f (fun f => f x)).
Defined.

Notation "⌈ A ⌉" := (El A).(wit).

Notation "x →ᵉ y" := (Prodᵉ _ (fun (_ : x) => y))
  (at level 99, y at level 200, right associativity).

Notation "'Πᵉ'  x .. y , P" := (Prodᵉ _ (fun x => .. (Prodᵉ _ (fun y => P)) ..))
  (at level 200, x binder, y binder, right associativity).

End Make.


(* Copyright © 1998-2006
 * Henk Barendregt
 * Luís Cruz-Filipe
 * Herman Geuvers
 * Mariusz Giero
 * Rik van Ginneken
 * Dimitri Hendriks
 * Sébastien Hinderer
 * Bart Kirkels
 * Pierre Letouzey
 * Iris Loeb
 * Lionel Mamane
 * Milad Niqui
 * Russell O’Connor
 * Randy Pollack
 * Nickolay V. Shmyrev
 * Bas Spitters
 * Dan Synek
 * Freek Wiedijk
 * Jan Zwanenburg
 *
 * This work 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 2 of the License, or
 * (at your option) any later version.
 *
 * This work 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 this work; if not, write to the Free Software Foundation, Inc.,
 * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
 *)

(**
* Continuity of polynomials *)

Require Export CoRN.reals.RealFuncts.

Lemma plus_op_contin : forall f g h : CSetoid_un_op IR,
 contin f -> contin g -> (forall x, f x[+]g x [=] h x) -> contin h.
Proof.
 intros f g h f_contin g_contin f_g_h.
 unfold contin in f_contin.
 unfold continAt in f_contin.
 unfold funLim in f_contin.
 unfold contin in g_contin.
 unfold continAt in g_contin.
 unfold funLim in g_contin.
 unfold contin in |- *. unfold continAt in |- *. unfold funLim in |- *.
 intros x e H.
 elim (plus_contin _ (f x) (g x) e H). intro b. intros H0 H1.
 elim H1. clear H1. intro c. intros H1 H2.
 elim (f_contin x b H0). clear f_contin. intro d'. intros H3 H4.
 elim (g_contin x c H1). clear g_contin. intro d''. intros H5 H6.
 exists (Min d' d'').
  apply less_Min; auto. intro x'. intros H10.
 astepr (f x[+]g x[-](f x'[+]g x')).
 apply H2.
  apply H4. apply AbsSmall_leEq_trans with (Min d' d''); auto. apply Min_leEq_lft.
  apply H6. apply AbsSmall_leEq_trans with (Min d' d''); auto. apply Min_leEq_rht.
Qed.

Lemma mult_op_contin : forall f g h : CSetoid_un_op IR,
 contin f -> contin g -> (forall x, f x[*]g x [=] h x) -> contin h.
Proof.
 intros f g h f_contin g_contin f_g_h.
 unfold contin in f_contin.
 unfold continAt in f_contin.
 unfold funLim in f_contin.
 unfold contin in g_contin.
 unfold continAt in g_contin.
 unfold funLim in g_contin.
 unfold contin in |- *. unfold continAt in |- *. unfold funLim in |- *.
 intros x e H.
 elim (mult_contin _ (f x) (g x) e H). intro b. intros H0 H1.
 elim H1. clear H1. intro c. intros H1 H2.
 elim (f_contin x b H0). clear f_contin. intro d'. intros H3 H4.
 elim (g_contin x c H1). clear g_contin. intro d''. intros H5 H6.
 exists (Min d' d'').
  apply less_Min; auto. intro x'. intros.
 astepr (f x[*]g x[-]f x'[*]g x').
 apply H2.
  apply H4. apply AbsSmall_leEq_trans with (Min d' d''); auto. apply Min_leEq_lft.
  apply H6. apply AbsSmall_leEq_trans with (Min d' d''); auto. apply Min_leEq_rht.
Qed.

Lemma linear_op_contin : forall (f g : CSetoid_un_op IR) a,
 contin f -> (forall x, x[*]f x[+]a [=] g x) -> contin g.
Proof.
 intros f g a f_contin f_g.
 unfold contin in f_contin.
 unfold continAt in f_contin.
 unfold funLim in f_contin.
 unfold contin in |- *. unfold continAt in |- *. unfold funLim in |- *.
 intros.
 elim (mult_contin _ x (f x) e). intro d'. intros H0 H1.
  elim H1. clear H1. intro c. intros H1 H2.
  elim (f_contin x c). clear f_contin. intro d''. intros H3 H4.
   exists (Min d' d'').
    apply less_Min; auto. intro x'. intros H8.
   astepr (x[*]f x[+]a[-](x'[*]f x'[+]a)).
   rstepr (x[*]f x[-]x'[*]f x').
   apply H2. clear H2.
    apply AbsSmall_leEq_trans with (Min d' d''); auto. apply Min_leEq_lft.
    apply H4. clear H4.
   apply AbsSmall_leEq_trans with (Min d' d''); auto. apply Min_leEq_rht.
   auto. auto.
Qed.

Lemma cpoly_op_contin : forall g : cpoly IR, contin (cpoly_csetoid_op _ g).
Proof.
 intro g.
 elim g.
  unfold contin in |- *. unfold continAt in |- *. unfold funLim in |- *.
  intros.
  exists OneR. apply pos_one.
   intros.
  simpl in |- *.
  unfold AbsSmall in |- *.
  split; apply less_leEq.
   rstepr ([--]ZeroR). apply inv_resp_less. auto.
   astepl ZeroR. auto.
  intros a f. intros.
 apply linear_op_contin with (cpoly_csetoid_op _ f) a. auto.
  intros. simpl in |- *. rational.
Qed.


Require Import Template.All.
Require Import List.
Require Import Template.Ast.
Require Import String.

Open Scope string_scope.

(* Taken from the template-coq parametricity translation *)

Definition tsl_table := list (global_reference * term).

Fixpoint lookup_tsl_table (E : tsl_table) (gr : global_reference)
  : option term :=
  match E with
  | nil => None
  | hd :: tl =>
    if gref_eq_dec gr (fst hd) then Some (snd hd)
    else lookup_tsl_table tl gr
  end.

Definition default_term := tVar "constant_not_found".

Definition lookup_default (E : tsl_table) (gr : global_reference)
  : term :=
  match (lookup_tsl_table E gr) with
  | None => match gr with
            | ConstRef n => tVar ("Not_found_" ++ n)
            | _ => default_term
            end
  | Some t => t
  end.

Import ListNotations.

(* Partly taken from Template.Typing *)
Definition it_mkLambda_or_LetIn (t : term) (l : context) :=
  List.fold_left
    (fun acc d =>
       match d.(decl_body) with
       | None => tLambda d.(decl_name) d.(decl_relevance) d.(decl_type) acc
       | Some b => tLetIn d.(decl_name) d.(decl_relevance) b d.(decl_type) acc
       end) l t.

Definition it_mkProd_or_LetIn (t : term) (l : context) :=
  List.fold_left
    (fun acc d =>
       match d.(decl_body) with
       | None => tProd d.(decl_name) d.(decl_relevance) d.(decl_type) acc
       | Some b => tLetIn d.(decl_name) d.(decl_relevance) b d.(decl_type) acc
       end) l t.

Fixpoint fold_map_internal {A B C : Type} (f : A -> B -> A * C) (a : A)
         (cs : list C) (bs : list B) : A * (list C)
  := match bs with
     | [] => (a, rev cs)
     | hd :: tl => let (a_, c_) := f a hd in fold_map_internal f a_ (c_ :: cs) tl
     end.

Definition fold_map {A B C : Type} (f : A -> B -> A * C) (a : A)
           (bs : list B) : A * (list C) := fold_map_internal f a [] bs.

Fixpoint fold_map' {A B C : Type} (f : A -> B -> A * C) (a : A)
         (bs : list B) : A * (list C)
  := match bs with
     | [] => (a, [])
     | hd :: tl => let (a_, c_) := f a hd in
                   let (a__, cs) := fold_map' f a_ tl in
                   (a__, c_ :: cs)
     end.

Example ex_fold_map : fold_map (fun x y => (x+y, y+1)) 0 [1;2;3] = (6,[2;3;4]).
reflexivity.
Qed.

Example ex_fold_map_fold_map' :
  fold_map (fun x y => (x+y, y+1)) 0 [1;2;3] = fold_map' (fun x y => (x+y, y+1)) 0 [1;2;3].
reflexivity.
Qed.

Definition sect {A B} (s : A -> B) (r : B -> A) := forall (x : A), r (s x) = x.

Definition retract {A B} (s : A -> B) (r : B -> A) := sect r s.

(* Auxiliary definitions related to equality *)
Definition transport {A : Type} {F : A -> Type} {a b : A} (p : a = b) : F a -> F b.
Proof.
  destruct p. apply id.
Defined.

(** Concatenation of paths *)
Definition path_concat {A : Type} {x y z : A} : x = y -> y = z -> x = z.
  intros p q. destruct p. apply q. Defined.

(** Lemma 2.3.9 in the HoTT book *)
Definition transp_concat {A : Type} {B : A -> Type} {x y z : A} {u : B x}
           (p : x = y) (q : y = z) :
  transport q (transport p u) = transport (path_concat p q) u.
  destruct p. reflexivity. Defined.

Definition ap {A B} (f : A -> B) {x y} : x = y -> f x = f y.
    destruct 1. reflexivity.
Defined.

(* Lemma 2.3.10 in the HoTT book *)
Definition transp_naturality {A B : Type} {C : B -> Type} {x y : A} {f : A -> B}
           {u : C (f x)} (p : x = y) :
  transport (ap f p) u =  @transport _ (fun x => C (f x)) _ _ p u.
  destruct p. reflexivity. Defined.

(* Lemma 2.3.11 in the HoTT book *)
Definition move_transport {A : Type}{F G : A -> Type}(f : forall {a : A}, F a -> G a)
           {a a' : A} (u : F a) (p : a = a') : f (transport p u) = transport p (f u).
  destruct p. reflexivity. Defined.

Definition concat_inv_r {A : Type} {x y : A} (p : x = y) :
  path_concat p (eq_sym p) = eq_refl.
  destruct p. reflexivity. Defined.

Definition concat_inv_l {A : Type} {x y : A} (p : x = y) :
  path_concat (eq_sym p) p = eq_refl.
  destruct p. reflexivity. Defined.


Require Import Metalib.Metatheory.
Require Import Metalib.LibTactics.
Require Import Coq.Program.Equality.
Require Import Coq.Program.Tactics.
Require Import Strings.String.
Require Import Lia.

Require Import Language.
Require Import Tactical.
Require Import Subtyping.Subtyping.
Require Import Subtyping.Splitable.
Require Import Appsub.

Require Import Value.
Require Import PrincipalTyping.
Require Import Typing.
Require Import Casting.
Require Import LocallyNameless.

(** * Definition *)

(** instead of using principal typing to get the type, we can define a function
    atype : vl -> arg
    atype v = Some A
    atype l = Some l
 *)

(** value and label *)

Inductive vl : Set :=
| Av : term -> vl
| Al : label -> vl.

Hint Constructors vl : core.

(** I'm confused a little bit and try to think why not let merge to be general one (work both on type and label),
    Since we can't allow label to be merged, so merge case only account for types
*)

Inductive atype : vl -> arg -> Prop :=
| At_Ann : forall e A,
    atype (Av (Ann e A)) (Avt A)
| At_Rcd : forall e l A,
    atype (Av e) (Avt A) ->
    atype (Av (Fld l e)) (Avt (Rcd l A))
| At_Mrg : forall e1 e2 A1 A2,
    atype (Av e1) (Avt A1) ->
    atype (Av e2) (Avt A2) ->
    atype (Av (Mrg e1 e2)) (Avt (And A1 A2))
| At_Lbl : forall l,
    atype (Al l) (Alt l).

Hint Constructors atype : core.

Inductive papp : term -> vl -> term -> Prop :=
| Pa_Lam : forall A B C D v v' e,
    lc (Lam A e B) ->
    casting v A v' ->
    papp (Ann (Lam A e B) (Arr C D)) (Av v)
         (Ann (open e v') D)
| Pa_Rcd : forall v l,
    papp (Fld l v) (Al l) v
| Pa_Mrg_L : forall v1 v2 A B vl TA e,
    ptype v1 A -> ptype v2 B ->
    atype vl TA ->
    not (uunisub B (uV TA) None) ->
    papp v1 vl e ->
    papp (Mrg v1 v2) vl e
| Pa_Mrg_R : forall v1 v2 A B vl TA e,
    ptype v1 A -> ptype v2 B ->
    atype vl TA ->
    not (uunisub A (uV TA) None) ->
    papp v2 vl e ->
    papp (Mrg v1 v2) vl e
| Pa_Mrg_P : forall v1 v2 A B vl TA e1 e2,
    ptype v1 A -> ptype v2 B ->
    atype vl TA ->
    uunisub A (uV TA) None ->
    uunisub B (uV TA) None ->
    papp v1 vl e1 ->
    papp v2 vl e2 ->
    papp (Mrg v1 v2) vl (Mrg e1 e2).

Hint Constructors papp : core.

Notation "v · vl ⟹ e" := (papp v vl e) (at level 69).

(** * Determinism *)

Lemma atype_determinism :
  forall vl TA1 TA2,
    atype vl TA1 ->
    atype vl TA2 ->
    TA1 = TA2.
Proof.
  introv At1 At2. gen TA2.
  dependent induction At1; intros.
  - dependent destruction At2; eauto.
  - dependent destruction At2; eauto.
    pose proof (IHAt1 _ At2) as IH.
    dependent destruction IH; eauto.
  - dependent destruction At2.
    pose proof (IHAt1_1 _ At2_1) as IH1.
    pose proof (IHAt1_2 _ At2_2) as IH2.
    dependent destruction IH1. dependent induction IH2.
    auto.
  - dependent destruction At2; eauto.
Qed.

Ltac subst_atype :=
  match goal with
  | [H1: atype ?vl ?TA1, H2: atype ?vl ?TA2 |- _] =>
      (pose proof (atype_determinism _ _ _ H1 H2) as Eqs; subst; clear H2)
  end.

Lemma typing_to_atype :
  forall v A,
    value v ->
    typing nil v Inf A ->
    atype (Av v) (Avt A).
Proof.
  introv Val Typ. gen A.
  induction Val; intros.
  - dependent destruction Typ; eauto.
  - dependent destruction Typ; eauto.
  - dependent destruction Typ; eauto.
Qed.

Hint Resolve typing_to_atype : core.

(** * App & Value *)

Lemma papp_lc_v :
  forall v vl e,
    lc v -> lc vl ->
    papp v (Av vl) e ->
    lc e.
Proof.
  introv Lc Lcl Pa.
  dependent induction Pa; try solve [econstructor; eauto 3].
  - econstructor. eapply open_abs; eauto 3.
    eapply casting_lc; eauto.
  - dependent destruction Lc; eauto 3.
  - dependent destruction Lc; eauto 3.
Qed.

Lemma papp_lc_l :
  forall v vl e,
    lc v ->
    papp v (Al vl) e ->
    lc e.
Proof.
  introv Lc Pa.
  dependent induction Pa; try solve [econstructor; eauto 3].
  - dependent destruction Lc. assumption.
  - dependent destruction Lc; eauto 3.
  - dependent destruction Lc; eauto 3.
Qed.

(** * Weakening Lemma *)

Lemma typing_weakening_gen :
  forall G E F e A dir,
    typing (E ++ G) e dir A ->
    uniq (E ++ F ++ G) ->
    typing (E ++ F ++ G) e dir A.
Proof.
  introv Typ. gen F.
  dependent induction Typ; introv Env; eauto.
  pick fresh x and apply Ty_Lam.
  rewrite_env (([(x,A)] ++ E) ++ F ++ G).
  apply H0; eauto.
  solve_uniq.
Qed.

Lemma typing_weakening :
  forall E F e A dir,
    typing E e dir A ->
    uniq (F ++ E) ->
    typing (F ++ E) e dir A.
Proof.
  intros.
  rewrite_env (nil ++ F ++ E).
  eapply typing_weakening_gen; eauto.
Qed.

(** * Subsitution Lemma *)

Lemma typing_uniq :
  forall E e T,
    typing E e Inf T -> uniq E.
Proof.
  introv Typ.
  induction Typ; eauto.
  - pick fresh x.
    assert (J: uniq ((one (x,A)) ++ T)); eauto.
    dependent destruction J; eauto.
Qed.

Lemma fv_open_lower :
  forall e1 e2 k,
    fv e1 [<=] fv (open_rec k e2 e1).
Proof with auto.
  intros.
  generalize dependent k.
  induction e1; intros; simpl; try fsetdec...
  - specialize (IHe1_1 k).
    specialize (IHe1_2 k).
    fsetdec...
  - specialize (IHe1_1 k).
    specialize (IHe1_2 k).
    fsetdec...
Qed.

Lemma fv_in_dom :
  forall T e A dir,
    typing T e dir A -> fv e [<=] dom T.
Proof.
  introv Typ.
  dependent induction Typ; simpl; try fsetdec; eauto.
  - apply binds_In in H0.
    fsetdec.
  - pick fresh x.
    assert ((fv (open e x)) [<=] (dom ((one (x, A)) ++ T))) by eauto.
    simpl in *.
    assert (fv e [<=] fv (open e x)).
    eapply fv_open_lower.
    assert (fv e [<=] add x (dom T)).
    fsetdec.
    eapply add_notin_context; eauto.
Qed.

Lemma subst_value :
  forall e z u A ,
    typing nil e Inf A -> substitution z u e = e.
Proof with auto.
  intros.
  apply fv_in_dom in H...
  simpl in H...
  eapply subst_fresh; eauto.
  fsetdec.
Qed.

(** substitution lemma,
stating that substituting a (closed, well-typed) term s for a variable x in a term t preserves the type of t *)

Lemma substitution_lemma :
   forall F E x v e A B C dir,
    typing (F ++ [(x, A)] ++ E) e dir B ->
    typing nil v Inf C ->
    isosub C A ->
    (exists D, typing (F ++ E) (substitution x v e) dir D /\ isosub D B).
Proof.
  introv Typ Typv Isub. remember (F ++ [(x, A)] ++ E) as E'. gen F.
  induction Typ; intros; simpl; subst; eauto.
  - Case "Var".
    destruct (x0 == x); eauto. subst.
    eapply binds_mid_eq in H0; eauto. subst.
    exists C. split; eauto.
    eapply typing_weakening; eauto.
    rewrite_env (E ++ nil).
    eapply typing_weakening; eauto.
    solve_uniq.
  - Case "Lam".
    exists (Arr A0 B). split; eauto.
    eapply (Ty_Lam (union L (singleton x))); eauto. intros.
    pose proof (H0 x0) as IH.
    exploit IH; eauto. intros IH'. destruct_conjs.
    rewrite_env (([(x0, A0)] ++ F) ++ E).
    rewrite subst_open_var; eauto 3.
    eapply isosub_to_sub1 in H3.
    eapply typing_chk_sub; eauto.
  - Case "Rcd".
    pose proof (IHTyp F) as IH. exploit IH; eauto. intros IH'.
    destruct IH'. destruct H. exists (Rcd l x0). split; eauto.
  - Case "Ann".
    exists A0. split; eauto.
    pose proof (IHTyp F) as IH. destruct IH; eauto. destruct_conjs.
    eapply Ty_Ann; eauto. eapply isosub_to_sub1 in H0.
    eapply typing_chk_sub; eauto.
  - Case "App".
    pose proof (IHTyp1 F) as IH1. pose proof (IHTyp2 F) as IH2.
    destruct IH1; destruct IH2; eauto. destruct_conjs.
    eapply uunisub_sound_appsub in H.
    eapply appsub_iso_v in H; eauto. destruct H. destruct H.
    exists x2. split; eauto. eapply Ty_App; eauto.
    eapply uunisub_complete_appsub; eauto.
  - Case "Prj".
    pose proof (IHTyp F) as IH. exploit IH; eauto. intros IH'.
    destruct IH'. destruct H0.
    eapply uunisub_sound_appsub in H.
    eapply appsub_iso_l in H; eauto. destruct H. destruct H.
    exists x1. split; eauto. eapply Ty_Prj; eauto.
    eapply uunisub_complete_appsub; eauto.
  - Case "Merge".
    pose proof (IHTyp1 F) as IH1. pose proof (IHTyp2 F) as IH2.
    destruct IH1; destruct IH2; eauto. destruct_conjs. eauto.
  - Case "Sub".
    pose proof (IHTyp F). destruct H0; eauto. destruct H0.
    exists B. split; eauto. eapply isosub_to_sub1 in H1.
    eapply Ty_Sub; eauto. eapply sub_transitivity; eauto.
Qed.

(** * Preservation *)
Section papp_preservation.

Lemma papp_uvalue_v :
  forall v vl e A B,
    value v -> value vl ->
    typing nil v Inf A -> typing nil vl Inf B ->
    papp v (Av vl) e ->
    uvalue e.
Proof.
  introv Val Vall Typ Typl Pa. gen A B.
  dependent induction Pa; intros; eauto 3.
  - dependent destruction Val. dependent destruction Typ; eauto.
  - dependent destruction Val. dependent destruction Typ; eauto 3.
  - dependent destruction Val. dependent destruction Typ; eauto 3.
  - eapply Uv_Mrg;
    dependent destruction Val; dependent destruction Typ; eauto 3.
Qed.

Lemma papp_uvalue_l :
  forall v l e A,
    value v ->
    typing nil v Inf A ->
    papp v (Al l) e ->
    uvalue e.
Proof.
  introv Val Typ Pa. gen A.
  dependent induction Pa; intros; eauto 3.
  - dependent destruction Val. dependent destruction Typ; eauto.
  - dependent destruction Val. dependent destruction Typ; eauto 3.
  - dependent destruction Val. dependent destruction Typ; eauto 3.
  - eapply Uv_Mrg;
    dependent destruction Val; dependent destruction Typ; eauto 3.
Qed.

Ltac solver1 := repeat match goal with
                       | [Typ: typing nil ?v Inf ?A, Val: value ?v, Pt: ptype ?v _ |- _] =>
                           (pose proof (typing_to_ptype _ _ (value_is_uvalue _ Val) Typ); subst_ptype; clear Pt)
                       | Typ: typing nil ?v Inf ?A, Val: value ?v, At: atype (Av ?v) _ |- _ =>
                           pose proof (typing_to_atype _ _ Val Typ);
                           subst_atype; clear At
                       end.

Lemma papp_preservation_v :
  forall v vl e A B C,
    value v -> value vl ->
    typing nil v Inf A ->
    typing nil vl Inf B ->
    appsub (Some (Avt B)) A C ->
    papp v (Av vl) e ->
    (exists D, typing nil e Inf D /\ isosub D C).
Proof.
  introv Val Vall Typ Typl As Pa. gen A B C.
  dependent induction Pa; intros.
  - Case "Lam".
    repeat dependent destruction Typ. dependent destruction As.
    dependent destruction Val.
    match goal with
    | [H: sub (Arr _ _) (Arr _ _) |- _] => (dependent destruction H; eauto)
    end.
    exists D. split; eauto.
    match goal with
    | [H: casting _ _ _ |- _] => (eapply casting_preservation in H; eauto; destruct H; destruct H)
    end.
    pick fresh y. rewrite (subst_intro y); eauto.
    assert (Fr': y `notin` L) by eauto.
    pose proof (H3 y Fr').
    rewrite_env (nil ++ [(y, A)] ++ nil) in H7.
    pose proof (substitution_lemma nil nil y v' (open e y) A B x Chk) as Sl.
    destruct Sl as [x' Sl']; eauto. destruct Sl'.
    eapply Ty_Ann; eauto.
    eapply isosub_to_sub1 in H9; eauto.
    eapply typing_chk_sub; eauto.
    eapply sub_transitivity; eauto 3.
  - Case "Merge L".
    dependent destruction Val. dependent destruction Typ;
      dependent destruction As; eauto 3; solver1; eauto.
  - Case "Merge R".
    dependent destruction Val. dependent destruction Typ;
      dependent destruction As; eauto 3; solver1; eauto.
  - Case "Merge P".
    dependent destruction Val. dependent destruction Typ.
    solver1.
    dependent destruction As; eauto.
    exploit (IHPa1 Val1 _ Vall); eauto.
    exploit (IHPa2 Val2 _ Vall); eauto.
    intros IH2 IH1.
    destruct_conjs. exists (And IH1 IH2). split; eauto.
Qed.

Ltac solver2 := repeat match goal with
                       | [Typ: typing nil ?v Inf ?A, Val: value ?v, Pt: ptype ?v _ |- _] =>
                           (pose proof (typing_to_ptype _ _ (value_is_uvalue _ Val) Typ); subst_ptype; clear Pt)
                       | At: atype (Al _) _ |- _ =>
                           dependent destruction At
                  end.

Lemma papp_preservation_l :
  forall v l e A B,
    value v ->
    typing nil v Inf A ->
    appsub (Some (Alt l)) A B ->
    papp v (Al l) e ->
    (exists C, typing nil e Inf C /\ isosub C B).
Proof.
  introv Val Typ As Pa. gen A B.
  dependent induction Pa; intros.
  - Case "Prj".
    dependent destruction Typ. dependent destruction As.
    exists A. split; eauto.
  - Case "Merge L".
    dependent destruction Val. dependent destruction Typ;
      dependent destruction As; eauto 3; solver2; eauto.
  - Case "Merge R".
    dependent destruction Val. dependent destruction Typ;
      dependent destruction As; eauto 3; solver2; eauto.
  - Case "Merge P".
    dependent destruction Val. dependent destruction Typ.
    solver2.
    dependent destruction As; eauto.
    exploit (IHPa1 l Val1); eauto.
    exploit (IHPa2 l Val2); eauto.
    intros IH2 IH1.
    destruct_conjs. exists (And IH1 IH2). split; eauto.
Qed.

End papp_preservation.

(** * Progress *)

Lemma papp_progress_v :
  forall f v A B C,
    value f -> value v ->
    typing nil f Inf A -> typing nil v Inf B ->
    appsub (Some (Avt B)) A C ->
    exists e, papp f (Av v) e.
Proof.
  introv Vf Vv Tf Tv As. gen A B C v.
  induction Vf; intros.
  - Case "Anno".
    destruct H.
    + SCase "Lit".
      repeat dependent destruction Tf.
      dependent destruction H1; eauto.
    + SCase "Lam".
      repeat dependent destruction Tf.
      dependent destruction H2; eauto.
      dependent destruction As; eauto.
      assert (Sub: sub B1 A1) by (eapply sub_transitivity; eauto).
      pose proof (casting_progress' _ _ _ Vv Tv Sub) as Ct. destruct Ct.
      eexists. eapply Pa_Lam; eauto.
  - Case "Rcd".
    dependent destruction Tf; eauto.
  - Case "Merge".
    dependent destruction As.
    + inversion Tf.
    + dependent destruction Tf.
      pose proof (IHVf1 _ Tf1 _ _ As _ Vv Tv) as IH. destruct IH.
      eexists. eapply Pa_Mrg_L; eauto.
    + dependent destruction Tf.
      pose proof (IHVf2 _ Tf2 _ _ As _ Vv Tv) as IH. destruct IH.
      eexists. eapply Pa_Mrg_R; eauto.
    + dependent destruction Tf.
      pose proof (IHVf1 _ Tf1 _ _ As1 _ Vv Tv) as IH1. destruct IH1.
      pose proof (IHVf2 _ Tf2 _ _ As2 _ Vv Tv) as IH2. destruct IH2.
      eexists. eapply Pa_Mrg_P; eauto.
Qed.

Lemma papp_progress_l :
  forall v A B l,
    value v ->
    typing nil v Inf A ->
    appsub (Some (Alt l)) A B ->
    exists e, papp v (Al l) e.
Proof.
  introv Val Typ As. gen A B l.
  induction Val; intros.
  - Case "Ann". destruct H.
    + SCase "Lit".
      repeat dependent destruction Typ.
      dependent destruction H1; eauto.
    + SCase "Lam".
      repeat dependent destruction Typ.
      dependent destruction H2; eauto.
  - Case "Rcd".
    dependent destruction Typ; eauto.
    dependent destruction As. eauto.
  - Case "Merge".
    dependent destruction As.
    + inversion Typ.
    + dependent destruction Typ.
      pose proof (IHVal1 _ Typ1 _ _ As) as IH. destruct IH.
      eexists. eapply Pa_Mrg_L; eauto.
    + dependent destruction Typ.
      pose proof (IHVal2 _ Typ2 _ _ As) as IH. destruct IH.
      eexists. eapply Pa_Mrg_R; eauto.
    + dependent destruction Typ.
      pose proof (IHVal1 _ Typ1 _ _ As1) as IH1. destruct IH1.
      pose proof (IHVal2 _ Typ2 _ _ As2) as IH2. destruct IH2.
      eexists. eapply Pa_Mrg_P; eauto.
Qed.