Require Import LibTactics.
Require Import Coq.micromega.Lia.
Require Import LN_Lemmas.
Require Export ApplyTy.
Require Export Distinguishability.

(****************************************************************************)
(** Mergeability *)

Notation "A >><< B"        := (Mergeability A B)
                                (at level 65, B at next level, no associativity) : type_scope.
Lemma mergeability_symm : forall A B,
    A >><< B -> B >><< A.
Proof.
  introv H. induction~ H. all: eauto.
Qed.

#[export] Hint Immediate mergeability_symm : core.

(****************************************************************************)

(* Corollary of B.11 *)
Lemma distinguishability_downward_both : forall A A' B B',
    Distinguishability A B -> A' <: A -> B' <: B -> Distinguishability A' B'.
Proof.
  introv Dis Sub1 Sub2.
  applys distinguishability_downward.
  applys DistSym. apply DistSym in Dis.
  applys distinguishability_downward Dis.
  all: eauto.
Qed.

#[export] Hint Immediate distinguishability_downward_both : core.

(* Lemma B.12 Dispatch *)
Lemma dispatch : forall A1 A2 B B' C1 C2',
    ordu B -> ordu B' -> A1 >><< A2 ->
    ApplyTy A1 B C1 -> NApplyTy A1 B' -> ApplyTy A2 B' C2' ->
    Distinguishability B B'.
Proof with try eassumption; destruct_conj; subst.
 introv Ord1 Ord2 Meg App1 Napp1 App2. gen B B' C1 C2'.
 induction Meg; intros.
 - forwards: applyty_arrow_sound_2 App1...
   forwards: applyty_arrow_sound_2 App2...
   eauto.
 - forwards (?&(?&?)): applyty_arrow_sound_2 App2...
   false. applys~ napplyty_sub_inv Napp1.
 - solve_false.
 - forwards: napplyty_spliti_inv Napp1... now constructor*.
   inverts App1; solve_false.
   + forwards: IHMeg1 B0 B'...
   + forwards: IHMeg2 B0 B'...
   + forwards: IHMeg1 B0 B'...
 - inverts App2; solve_false.
   + forwards: IHMeg1 B0 B'...
   + forwards: IHMeg2 B0 B'...
   + forwards: IHMeg1 B0 B'...
 - forwards : applyty_splitu_inv App1... now constructor*.
   forwards [?|?]: napplyty_splitu_inv Napp1... now constructor*.
   + forwards: IHMeg1 B0 B'...
   + forwards: IHMeg2 B0 B'...
 - forwards : applyty_splitu_inv App2... now constructor*.
   forwards: IHMeg1 B0 B'...
 - (* MergeabilityAx *)
   inverts H; solve_false.
 - (* MergeabilityAx *)
   inverts H; solve_false.
Qed.

(****************************************************************************)
(* B.14 If apply(A, V) => C and V'/V => ok and apply(A, V')=>C' then C <: C' *)
Lemma applyty_valtyp_psub : forall (A V C V' C' : typ),
    TypeWF nil A -> isValTyp V -> isValTyp V' ->
    V' <p V -> ApplyTy A V C -> ApplyTy A V' C' -> C <: C'.
Proof with elia; solve_false.
  introv WF Val1 Val2 PSub App1 App2.
  indTypSize (size_typ V + size_typ V' + size_typ A).
  lets~ [Hu|(?&?&Hu)]: ordu_or_split V'.
  lets~ [Hu'|(?&?&Hu')]: ordu_or_split V.
  - (* V and V' ordu *)
    inverts App1; inverts WF... (* analysis the form of A *)
    + (* bot *) eauto.
    + (* arrow *) inverts~ App2...
    + (* union *) inverts~ App2...
      repeat match goal with
        H1: ApplyTy ?A _ _, H2: ApplyTy ?A _ _ |- _ =>
        forwards~: IH H1 H2; elia; clear H1
             end.
    + (* intersection *) inverts~ App2...
      * repeat match goal with
                 H1: ApplyTy ?A _ _, H2: ApplyTy ?A _ _ |- _ =>
                 forwards~: IH H1 H2; elia; clear H1
               end.
      * false.
        forwards: dispatch A1 A2 V V'; try eassumption.
        forwards~ : distinguishability_valtyp_not_psub V' V.
     *  false.
        forwards~: dispatch A2 A1 V' V; try eassumption.
        forwards~ : distinguishability_valtyp_not_psub V' V.
    + (* intersection again *) inverts~ App2...
      2: repeat match goal with
                 H1: ApplyTy ?A _ _, H2: ApplyTy ?A _ _ |- _ =>
                 forwards~: IH H1 H2; elia; clear H1
               end.
      * false.
        forwards: dispatch A1 A2 V' V; try eassumption.
        forwards~ : distinguishability_valtyp_not_psub V' V.
      * false.
        forwards~ : dispatch A1 A2 V' V; try eassumption.
        forwards~ : distinguishability_valtyp_not_psub V' V.
    + (* intersection again *) inverts~ App2...
      3: repeat match goal with
                 H1: ApplyTy ?A _ _, H2: ApplyTy ?A _ _ |- _ =>
                 forwards~: IH H1 H2; elia; clear H1
               end.
      * false.
        forwards~: dispatch A2 A1 V V'; try eassumption.
        forwards~ : distinguishability_valtyp_not_psub V' V.
      * false.
        forwards~ : dispatch A1 A2 V V'; try eassumption.
        forwards~ : distinguishability_valtyp_not_psub V' V.
  - forwards HS1: psub_trans PSub.
    applys~ psub_splu_valtyp_left Hu'.
    forwards HS2: psub_trans PSub.
    applys~ psub_splu_valtyp_right Hu'.
    forwards: applyty_splitu_arg_inv App1 Hu'. destruct_conj. subst.
    forwards: IH HS1; try eassumption. now eauto. now elia.
    forwards: IH HS2; try eassumption. now eauto. now elia.
    eauto.
  - forwards~ HS1: psub_trans (psub_splu_valtyp_left_rev _ _ _ Hu) PSub.
    forwards~ HS2: psub_trans (psub_splu_valtyp_right_rev _ _ _ Hu) PSub.
    forwards: applyty_splitu_arg_inv App2 Hu. destruct_conj. subst.
    forwards: IH HS1; try eassumption. now eauto. now elia.
    forwards: IH HS2; try eassumption. now eauto. now elia.
    eauto.
Qed.

(****************************************************************************)

(* B.15 (1) *)
Lemma applyty_andl_sub_1 : forall (A1 A2 B B1 B2 : typ) (V:Fty),
    TypeWF nil (A1&A2) -> isValFty V ->
    ApplyTy (A1&A2) V B -> ApplyTy A1 V B1 -> ApplyTy A2 V B2 -> B1&B2 <: B.
Proof with try eassumption; elia; destruct_conj; subst.
  introv WF Val AppA App1 App2.
  indTypFtySize (size_typ A1 + size_typ A2 + size_Fty V).
  lets~ [Hu|(?&?&Hu)]: ordu_or_split_Fty V... now eauto.
  - inverts AppA; solve_false.
    forwards: applyty_unique App1...
    forwards: applyty_unique App2...
    convert2asub. match_and; eauto.
  - assert (HS: similar x0 x1). {
      inverts Val. unfold similar; exists; split; eassumption.
    }
    apply sim2similar in HS.
    forwards HS1: sim_psub HS. forwards HS2: sim_psub_2 HS.
    forwards (?&?) : applyty_splitu_arg_inv App1...
    forwards (?&?) : applyty_splitu_arg_inv App2...
    forwards (?&?) : applyty_splitu_arg_inv AppA...
    forwards: IH (fty_StackArg x0) A1 A2... now eauto.
    forwards: IH (fty_StackArg x1) A1 A2... now eauto.
    inverts WF.
    forwards: applyty_valtyp_psub A2 HS1... 1-2: eauto.
    forwards: applyty_valtyp_psub A1 HS1... 1-2: eauto.
    applys DSub_Trans ((x2 | x2) & (x4 | x4)).
    applys DSub_Trans.
    applys DSub_CovInterL. now eauto.
    applys DSub_CovUnionR... now eauto.
    applys DSub_CovInterR. now eauto.
    applys DSub_CovUnionR... now eauto.
    applys DSub_Trans (x2 & x4).
    all: convert2asub.
    2: use_left_r; easy.
    split_l; swap_and_l. all: auto_lc.
    all: split_l; swap_and_l. all: auto_lc.
    all: eauto.
Qed.

(* B.15 (2) *)
Lemma applyty_andl_sub_2 : forall (A1 A2 B B1 : typ) (V:Fty),
    TypeWF nil (A1&A2) -> isValFty V ->
    ApplyTy (A1&A2) V B -> ApplyTy A1 V B1 -> NApplyTy A2 V -> B1 <: B.
Proof with try eassumption; elia; destruct_conj; subst.
  introv WF Val AppA App1 App2.
  indTypFtySize (size_typ A1 + size_typ A2 + size_Fty V).
  lets~ [Hu|(?&?&Hu)]: ordu_or_split_Fty V... now eauto.
  - inverts AppA; solve_false.
    forwards: applyty_unique App1...
    convert2asub. eauto.
  - assert (HS: similar x0 x1). {
      inverts Val. unfold similar; exists; split; eassumption.
    }
    apply sim2similar in HS.
    forwards HS1: sim_psub HS. forwards HS2: sim_psub_2 HS.
    forwards (?&?) : applyty_splitu_arg_inv App1...
    forwards (?&?) : applyty_splitu_arg_inv AppA...
    forwards [?|?] : napplyty_splitu_arg_inv App2...
    1: forwards: IH (fty_StackArg x0) A1 A2... now eauto.
    2: forwards: IH (fty_StackArg x1) A1 A2... 2: now eauto.
    all: inverts WF.
    + forwards: applyty_valtyp_psub A1 HS1... 1-2: eauto.
      forwards: applyty_valtyp_psub (A1 & A2) HS1... 1-3: eauto.
      applys* DSub_Trans x4.
    + forwards: applyty_valtyp_psub A1 HS2... 1-2: eauto.
      forwards: applyty_valtyp_psub (A1 & A2) HS1... 1-3: eauto.
      applys~ DSub_Trans x3.
Qed.

(* B.15 (3) *)
Lemma applyty_andl_sub_3 : forall (A1 A2 B B2 : typ) (V:Fty),
    TypeWF nil (A1&A2) -> isValFty V ->
    ApplyTy (A1&A2) V B -> NApplyTy A1 V -> ApplyTy A2 V B2 -> B2 <: B.
Proof with try eassumption; elia; destruct_conj; subst.
  introv WF Val AppA App1 App2.
  indTypFtySize (size_typ A1 + size_typ A2 + size_Fty V).
  lets~ [Hu|(?&?&Hu)]: ordu_or_split_Fty V... now eauto.
  - inverts AppA; solve_false.
    forwards: applyty_unique App2...
    convert2asub. eauto.
  - assert (HS: similar x0 x1). {
      inverts Val. unfold similar; exists; split; eassumption.
    }
    apply sim2similar in HS.
    forwards HS1: sim_psub HS. forwards HS2: sim_psub_2 HS.
    forwards (?&?) : applyty_splitu_arg_inv App2...
    forwards (?&?) : applyty_splitu_arg_inv AppA...
    forwards [?|?] : napplyty_splitu_arg_inv App1...
    1: forwards: IH (fty_StackArg x0) A1 A2... now eauto.
    2: forwards: IH (fty_StackArg x1) A1 A2... 2: now eauto.
    all: inverts WF.
    + forwards: applyty_valtyp_psub A2 HS1... 1-2: eauto.
      forwards: applyty_valtyp_psub (A1 & A2) HS1... 1-3: eauto.
      applys~ DSub_Trans x2.
    + forwards: applyty_valtyp_psub A2 HS2... 1-2: eauto.
      forwards: applyty_valtyp_psub (A1 & A2) HS1... 1-3: eauto.
      applys~ DSub_Trans x3.
Qed.

(* B.15 (4) *)
Lemma applyty_orl_sub : forall (A1 A2 B B1 B2 : typ) (V:Fty),
    ApplyTy (A1|A2) V B -> ApplyTy A1 V B1 -> ApplyTy A2 V B2 -> B <: B1 | B2.
Proof with try eassumption; elia; destruct_conj; subst.
  introv AppA App1 App2.
  forwards : applyty_splitu_inv AppA... now eauto.
  forwards: applyty_unique App1...
  forwards: applyty_unique App2...
  destruct~ H.
Qed.

(******************************************************************************)

(* Two types are sim iff they are splu from a value type *)
Lemma sim_isvaltyp : forall A B,
    sim A B -> isValTyp A /\ isValTyp B.
Proof.
  introv H. induction* H.
Qed.

Lemma sim_split_1 : forall A B A1 A2,
    sim A B -> splu A A1 A2 -> sim A1 A2.
Proof.
  introv H S. apply sim_isvaltyp in H.
  applys sim2similar.
  unfolds. exists*.
Qed.

Lemma sim_split_2 : forall A B A1 A2,
    sim A B -> splu A A1 A2 -> sim A1 B.
Proof.
  introv H S. gen A1 A2.
  induction H; intros.
  - inverts_typ. eauto.
  - inverts* S.
Qed.

Lemma sim_split_3 : forall A B A1 A2,
    sim A B -> splu A A1 A2 -> sim A2 B.
Proof.
  introv H S. gen A1 A2.
  induction H; intros.
  - inverts_typ. eauto.
  - inverts* S.
Qed.

Lemma sim_split_4 : forall A B A1 A2,
    sim B A -> splu A A1 A2 -> sim B A1.
Proof.
  introv H S. gen A1 A2.
  induction H; intros.
  - inverts_typ. eauto.
  - inverts* S.
Qed.

Lemma sim_split_5 : forall A B A1 A2,
    sim B A -> splu A A1 A2 -> sim B A2.
Proof.
  introv H S. gen A1 A2.
  induction H; intros.
  - inverts_typ. eauto.
  - inverts* S.
Qed.

#[local] Hint Immediate sim_split_1 sim_split_2 sim_split_3 sim_split_4 sim_split_5 : core.

Lemma applyty_and_sim_inv : forall A A' B B' x1 x2,
    TypeWF nil (A&A') ->
    sim B B' -> ApplyTy A B x1 -> ApplyTy A' B' x2 ->
    NApplyTy A B' -> NApplyTy A' B -> False.
Proof with auto_lc; elia; try eassumption; destruct_conj; subst.
  introv WF HS App1 App2 Napp1 Napp2.
  indTypSize (size_typ B + size_typ B').
  lets~ [Hu|(?&?&Hu)]: ordu_or_split B. auto_lc.
  lets~ [Hu'|(?&?&Hu')]: ordu_or_split B'. auto_lc.
  - applys sim_no_distinguishability HS. applys dispatch...
    inverts~ WF.
  - forwards : applyty_splitu_arg_inv App2...
    forwards [(?&?)|Napp11]: applyty_total A x... now eauto.
    forwards [(?&?)|Napp12]: applyty_total A x0... now eauto.
    * applys* applyty_contradication A B'.
    * applys IH A A' B x0... eauto.
    * applys IH A A' B x... eauto.
  - forwards : applyty_splitu_arg_inv App1...
    forwards [(?&?)|Napp11]: applyty_total A' x... now eauto.
    forwards [(?&?)|Napp12]: applyty_total A' x0... now eauto.
    * applys* applyty_contradication A' B.
    * applys IH A A' x0 B'... eauto.
    * applys IH A A' x B'... eauto.
Qed.

Lemma lemma_for_B16 : forall A A' V B1 B2 x1 x2,
    TypeWF nil (A&A') -> isValTyp V
    -> splu V B1 B2 -> ApplyTy A B1 x1 -> ApplyTy A' B2 x2 ->
    exists y, ApplyTy A' B1 y \/ ApplyTy A B2 y.
Proof.
  intros.
  forwards* [(?&?)|Napp1]: applyty_total A B2.
  forwards* [(?&?)|Napp2]: applyty_total A' B1.
  false. applys* applyty_and_sim_inv A A' B1 B2.
  applys sim2similar.
  unfold similar. exists*.
Qed.

(* B.16 Inversion of Dispatch on Value Types *)
(* Here we only consider V to be StackArg. *)
Lemma applyty_valtyp_inter_inv : forall (A A' V B : typ),
    ApplyTy (A&A') V B -> isValTyp V -> TypeWF nil (A&A') ->
    exists B', ApplyTy A V B' \/ ApplyTy A' V B'.
Proof with solve_false.
  introv HA HV WF.
  indTypSize (size_typ V).
  lets~ [Hu|(?&?&Hu)]: ordu_or_split V.
  - inverts HA... all: exists*.
  - inverts_typ.
    inverts* HA.
    forwards~ (?&[?|?]): IH H3; elia; forwards~ (?&[?|?]): IH H5; elia.
    1,4: exists*.
    * inverts WF. forwards~ (?&[?|?]): lemma_for_B16 H2 H1 H4.
      all: exists*.
    * inverts WF. forwards~ (?&[?|?]): lemma_for_B16 H2 H1 H4.
      all: exists*.
Qed.

(* B.16 Inversion of Dispatch on Value Types *)
(* Here we only consider V to be StackTypArg. *)
Lemma applyty_inter_inv : forall A1 A2 B C,
    ApplyTy (A1&A2) [|B|] C ->
    exists C', ApplyTy A1 [|B|] C' \/ ApplyTy A2 [|B|] C'.
Proof with destruct_conj; try subst; try solve [exists*].
  introv HA.
  inverts HA; solve_false...
Qed.

Lemma sub_sim_distinguishability_sub_inv : forall A B C D,
    sim A B -> C <<>> D -> A <: C -> B <: D -> False.
Proof with try eassumption.
  intros.
  applys sim_no_distinguishability H.
  applys distinguishability_downward_both...
Qed.

#[export] Hint Immediate sub_sim_distinguishability_sub_inv : FalseHd.

(* Inversion of Disjoint Union Subtyping *)
Lemma sub_inv_distinguishable_union : forall A B1 B2,
    isValTyp A -> A <:: B1 | B2 -> B1 <<>> B2 -> A <:: B1 \/ A <:: B2.
Proof with try eassumption; elia; try solve [false; applys sub_sim_distinguishability_sub_inv; convert2dsub; eassumption ].
  introv Val Sub Dis.
  indTypSize (size_typ A + size_typ (B1|B2)).
  lets~ [Hu|(C1&C2&Hu)]: ordu_or_split A.
  - auto_inv.
  - assert (Sim: sim C1 C2). {
      applys sim2similar. unfold similar. eauto.
    }
    auto_inv. inverts_typ.
    forwards [?|?]: IH C1 B1 B2...
    all: forwards [?|?]: IH C2 B1 B2...
    all: try solve [left; applys ASub_or; [eassumption |..]; eauto].
    all: try solve [right; applys ASub_or; [eassumption |..]; eauto].
    apply DistSym in Dis...
Qed.

(* Some results about negtyp; were proved for the above lemma *)
Lemma distinguishability_negtyp_bot : forall V U,
    Distinguishability V U -> isNegTyp V -> U <:: t_bot.
Proof with solve_false.
  introv Dis Neg.
  indTypSize (size_typ V + size_typ U).
  inverts Neg; inverts Dis; inverts_all_spl; inverts_typ...
  all: try solve [match goal with | H: DistinguishabilityAx _ _ |- _ => inverts~ H end].
  all: repeat match goal with
         | H: _ <<>> _ |- _ => forwards: IH H; [ now eauto | .. ]; elia; clear H
         end.
  all: try solve [solve_algo_sub; try eassumption; auto].
  all: auto.
Qed.

Lemma sub_inv_distinguishable_bot : forall A B1 B2,
    isNegTyp A -> A <: B1 -> B1 <<>> B2 -> B2 <: t_bot.
Proof.
  introv Val Sub Dis.
  forwards: distinguishability_downward_both Dis Sub.
  applys* DSub_Refl.
  convert2asub.
  applys~ distinguishability_negtyp_bot H.
Qed.

#[export] Hint Resolve negtyp_sub_rcd_inv : FalseHd.

Lemma botlike_or_inv_1 : forall A B,
    A | B <:: t_bot -> A <:: t_bot.
Proof.
  introv H. applys algo_trans H. use_left_r. eauto.
Qed.
Lemma botlike_or_inv_2 : forall A B,
    A | B <:: t_bot -> B <:: t_bot.
Proof.
  introv H. applys algo_trans H. use_right_r. eauto.
Qed.

#[export] Hint Immediate botlike_or_inv_1 botlike_or_inv_2 : core.

Lemma botlike_spli_inv : forall C A B,
    C <:: t_bot -> spli C A B -> A <:: t_bot \/ B <:: t_bot.
Proof with inverts_all_spl; solve_false.
  introv Sub Spl.
  inductions Spl...
  - applys~ botlike_inv.
  - forwards* [?|?]: IHSpl.
  - forwards* [?|?]: IHSpl; intuition eauto.
Qed.

Lemma botlike_splu_inv : forall A B C,
    C <:: t_bot -> splu C A B -> A <:: t_bot /\ B <:: t_bot.
Proof.
  introv H. split; applys algo_trans H.
  2: use_right_r. 1: use_left_r. 1, 3: eassumption.
  all: eauto.
Qed.

Ltac inv_botlike :=
    repeat try lazymatch goal with
         | H1: ?A <:: t_bot , H2: spli ?A _ _ |- _ =>
           forwards [?|?]: botlike_spli_inv H1 H2; clear H1
         | H1: _ & _ <:: t_bot |- _ =>
           forwards [?|?]: botlike_inv H1; clear H1
         | H1: _ | _ <:: t_bot |- _ =>
           forwards : botlike_or_inv_1 H1; forwards : botlike_or_inv_2 H1; clear H1
         | H1: ?A <:: t_bot , H2: splu ?A _ _ |- _ =>
           forwards (?&?): botlike_splu_inv H1 H2; clear H1
      end.

Lemma negtyp_sub_bot_inv : forall Aneg,
    isNegTyp Aneg -> Aneg <: t_bot -> False.
Proof with try eassumption; solve_false.
  introv Neg Sub. convert2asub.
  induction Neg; inv_botlike...
Qed.

#[export] Hint Immediate negtyp_sub_bot_inv : FalseHd.

Lemma sub_trans_bot : forall A B,
    A <:: t_bot -> lc_typ B -> A <:: B.
Proof.
  introv Sub Lc.
  applys* algo_trans Sub.
Qed.

#[export] Hint Immediate sub_trans_bot : core.

Lemma sub_union_bot_inv : forall A B C,
    A <:: B | C -> B <:: t_bot -> A <:: C.
Proof with try eassumption; elia.
  introv Sub SubB.
  indTypSize (size_typ A + size_typ B + size_typ C).
  lets~ [Hu|(C1&C2&Hu)]: ordu_or_split A.
  - assert (lc_typ C) by eauto.
    auto_inv. applys~ algo_trans B.
  - inverts Sub; inverts_all_spl.
    all: auto.
    all: inv_botlike.
    all: try (forwards: IH; [eassumption | eassumption | .. ]; [ now elia | ] ).
    all: auto.
    + applys~ ASub_or.
    + applys~ ASub_and H7. applys IH...
    + use_left_l...
    + use_right_l...
    + clear H1. forwards: IH; [eassumption | eassumption | .. ]; [ now elia | ].
      applys ASub_or...
    + forwards~ : algo_trans H0 SubB.
Qed.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal33.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj23eqsynthconj1 : forall  (lv0 : natural), (@eq natural (Succ lv0) (Succ (plus Zero lv0))).
Admitted.
QuickChick conj23eqsynthconj1.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal33.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj2synthconj5 : forall  (lv0 : natural) (lv1 : natural), (@eq natural (lv0) (plus lv0 lv1)).
Admitted.
QuickChick conj2synthconj5.


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

(***
Modulus : 2^488 - 17
Base: 48.8
***)

Definition curve : CurveParameters :=
  {|
    sz := 10%nat;
    base := 48 + 4/5;
    bitwidth := 64;
    s := 2^488;
    c := [(1, 17)];
    carry_chains := Some [seq 0 (pred 10); [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.


(* -*- coq-prog-name: "coqtop"; -*- *)
Require Import ssreflect ssrfun ssrbool .

From Modules Require Import PreSyntaxOnlyContr HomotopicalEquality lib WfSyntaxBrunerieOnlyContr FunctionalRelation.
Set Bullet Behavior "Strict Subproofs".

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Section TypeRl.
  Variable (T: Type).
  Variable (fibT: Fib T).

Record rfC (Γ : Con) (wΓ : WC Γ) :=
  { fC_C : rC T ;
    fC_r : rl_C fibT wΓ fC_C
  }.

Record rfT (Γ : Con) (A : Ty) (wΓ : WC Γ) (wA : (Γ ⊢ A)) :=
  { fT_C : rC T;
    fT_T : rT fT_C;
    fT_r : rl_T fibT wΓ wA (mkpT fT_T)
  }.

Record rft (Γ : Con) (A : Ty) (t : Tm) (wΓ : WC Γ) (wA : (Γ ⊢ A)) (wt : Γ ⊢ t : A) :=
  { ft_C : rC T;
    ft_T : rT ft_C;
    ft_t : rtm ft_T;
    ft_r :  rl_t fibT wΓ wA wt (mkpt ft_t );
    (* ft_rT :  rl_T fibT wΓ wA (mkpT ft_T)  *)
  }.
Definition ft_rT (Γ : Con) (A : Ty) (t : Tm) (wΓ : WC Γ) (wA : (Γ ⊢ A)) (wt : Γ ⊢ t : A)
      (ft : rft wΓ wA wt) : rl_T fibT wΓ wA (mkpT (ft_T ft)) := rl_t_Tη (ft_r ft).

Record rfV (Γ : Con) (A : Ty) (x : Var) (wΓ : WC Γ) (wA : (Γ ⊢ A)) (wx : WVar Γ A x) :=
  { fV_C : rC T;
    fV_T : rT fV_C;
    fV_t : rtm fV_T;
    fV_r :  rl_V fibT wΓ wA wx (mkpt fV_t );
    (* fV_rT :  rl_T fibT wΓ wA (mkpT fV_T) ; *)
    (* fV_rC T :  rl_C fibT wΓ fV_C  *)
  }.
Definition fV_rT (Γ : Con) (A : Ty) (x:Var) (wΓ : WC Γ) (wA : (Γ ⊢ A)) ( wx : WVar Γ A x)
      (fx : rfV wΓ wA wx) : rl_T fibT wΓ wA (mkpT (fV_T fx)) := rl_V_Tη (fV_r fx).
Definition fV_rC  (Γ : Con) (A : Ty) (x:Var) (wΓ : WC Γ) (wA : (Γ ⊢ A)) ( wx : WVar Γ A x)
      (fx : rfV wΓ wA wx) : rl_C fibT wΓ  ((fV_C fx)) := rl_V_Cη (fV_r fx).

Record rfS (Γ Δ : Con) (σ : sub) (wΓ : WC Γ) (wΔ : WC Δ) (wσ : Γ ⊢ σ ⇒ Δ) :=
  { fS_Γ : rC T;
    fS_Δ : rC T;
    fS_S : rS fS_Γ fS_Δ;
    fS_r : rl_S fibT wΓ wΔ wσ (mkpS fS_S)}.

  Lemma eqf_CC_TC (Γ : Con) (A : Ty) (wΓ : WC Γ) (wA : Γ ⊢ A)
        (fΓ : rfC wΓ) (fA : rfT wΓ wA) : fC_C fΓ = fT_C fA.
  Proof.
    apply:rl_hpC.
    + apply:fC_r.
    + apply:rl_T_Cη.
      apply:fT_r.
  Qed.
  Lemma eqf_tC_TC (Γ : Con) (A : Ty) t (wΓ : WC Γ) (wA : Γ ⊢ A) (wt : Γ ⊢ t : A)
         (fA : rfT wΓ wA)(ft : rft wΓ wA wt) : ft_C ft = fT_C fA .
  Proof.
    apply:rl_hpC.
    + apply:rl_t_Cη.
      apply:ft_r.
    + apply:rl_T_Cη.
      apply:fT_r.
  Qed.

  Lemma eqf_tC_tC (Γ : Con) (A : Ty) t u (wΓ : WC Γ) (wA : Γ ⊢ A) (wt : Γ ⊢ t : A)
        (wu : Γ ⊢ u : A)
         (ft : rft wΓ wA wt)(fu : rft wΓ wA wu) : ft_C ft = ft_C fu .
  Proof.
    apply:rl_hpC.
    + apply:(rl_t_Cη).
      apply:ft_r.
    + apply:(rl_t_Cη).
      apply:ft_r.
  Qed.
  Lemma eqf_tT_tT (Γ : Con) (A : Ty) t u (wΓ : WC Γ) (wA : Γ ⊢ A) (wt : Γ ⊢ t : A)
        (wu : Γ ⊢ u : A)
         (ft : rft wΓ wA wt)(fu : rft wΓ wA wu) : ft_T ft ≅ ft_T fu .
  Proof.
    apply:π_eq_pTη'.
    apply:rl_hpT.
    + apply:ft_rT.
    + apply:ft_rT.
  Qed.
  Lemma eqf_tT_TT (Γ : Con) (A : Ty) t (wΓ : WC Γ) (wA : Γ ⊢ A) (wt : Γ ⊢ t : A)
         (fA : rfT wΓ wA)(ft : rft wΓ wA wt) : ft_T ft ≅ fT_T fA .
  Proof.
    apply:π_eq_pTη'.
    apply:rl_hpT.
    + apply:ft_rT.
    + apply:fT_r.
  Qed.
  Lemma eqf_SC1_CC (Γ : Con)  (wΓ : WC Γ)
        (Δ : Con) (wΔ : WC Δ) (σ : sub) (wσ : Γ ⊢ σ ⇒ Δ)
        (fΓ : rfC wΓ)(fσ : rfS wΓ wΔ wσ) :
    fS_Γ fσ = fC_C fΓ.
  Proof.
    apply:rl_hpC.
    + apply:(rl_S_C1 (pσ := mkpS (fS_S fσ))).
      apply:fS_r.
    + apply:fC_r.
  Qed.
  Lemma eqf_SC2_CC (Γ : Con)  (wΓ : WC Γ)
        (Δ : Con) (wΔ : WC Δ) (σ : sub) (wσ : Γ ⊢ σ ⇒ Δ)
        (fΔ : rfC wΔ)(fσ : rfS wΓ wΔ wσ) :
    fS_Δ fσ = fC_C fΔ.
  Proof.
    apply:rl_hpC.
    + apply:(rl_S_C2 (pσ := mkpS (fS_S fσ))).
      apply:fS_r.
    + apply:fC_r.
  Qed.

Fixpoint semC (Γ : Con) (wΓ : WC Γ) {struct wΓ} : rfC wΓ
with semT (Γ : Con) (A : Ty) (wΓ : WC Γ) (wA : Γ ⊢ A) : rfT wΓ wA
with semt  (Γ : Con)  (A : _) (t : Tm)
             (wΓ : WC Γ)(wA : Γ ⊢ A) (wt : Γ ⊢ t : A) : rft wΓ wA wt
with semV  (Γ : Con)  (A : _) (x : Var)
           (wΓ : WC Γ)
           (wA : Γ ⊢ A)
           (wx : WVar Γ A x) : rfV wΓ wA wx
with semS (Γ Δ : Con)  (σ : sub)
            (wΓ : WC Γ)(wΔ : WC Δ) (wσ : Γ ⊢ σ ⇒ Δ) : rfS wΓ wΔ wσ .
- destruct wΓ.
  + unshelve econstructor.
    * apply :r_rl_astar => //.
    * constructor.
  + specialize (semt _ _ _ wΓ w w0).
    unshelve econstructor.
    * apply:r_rl_ext.
      apply:(ft_t semt).
    * constructor => //.
      -- apply:(rl_t_C (ft_r semt)).
      -- apply:ft_rT.
      -- apply:ft_r.
- destruct wA.
  + specialize (semC _ w).
    unshelve econstructor.
    * exact (fC_C semC).
    * apply:r_rl_star=> //.
    * abstract (clear_hprop; by move/rl_star:(fC_r semC)).
  + specialize (semT _ _ wΓ wA).
    have st := (semt _ _ _ wΓ wA w).
    have su := (semt _ _ _ wΓ wA w0).
    unshelve econstructor.
    * apply:ft_C.
      exact:st.
    * apply:r_rl_ar.
      -- apply:ft_t.
      -- move: (ft_t su).
         apply:transport2.
         ** apply:eqf_tC_tC.
         ** apply:eqf_tT_tT.
    * constructor.
      -- apply:(rl_t_C (ft_r st)).
      -- apply:ft_rT.
      -- apply:ft_r.
      -- cbn .
         move:(ft_r su).
         apply:transport.
         ++ apply:pt_eq.
            ** apply:eqf_tC_tC.
            ** apply:eqf_tT_tT.
            ** apply:JMeq_sym.
               apply:JMeq_transport2.
- destruct wt.
  + specialize (semV _ _ _ wΓ wA w).
    econstructor.
    * constructor.
      exact:(fV_r semV).
  + specialize (semS _ _ _ wΓ w w1).
    move/semT:(w0).
    move/(_ w) => IHA.
    assert ( e : fT_C IHA = fS_Δ semS).
    {
      apply:rl_hpC.
      - apply:(rl_T_C (fT_r IHA)).
      - apply:(rl_S_C2 (fS_r semS)).
    }
    econstructor.
    * constructor; revgoals.
      -- apply:(fS_r semS).
      -- assert (h' : rl_T fibT w w0 (mkpT (eq_rect _ (@rT T) (fT_T IHA) _ e))).
         { move: (fT_r IHA).
           apply:transport.
           move:(fT_T IHA).
           pattern (fT_C IHA),e.
           by apply:J.
         }
         exact:h'.
      -- apply:(rl_S_C2 (fS_r semS)).
      -- apply:(rl_S_C1 (fS_r semS)).
- destruct wx.
  +
    have e : wΓ = w_astar by   apply:WC_hp.
    subst.
    have e : wA = w_star w_astar by   apply:WTy_hp.
    subst.
    repeat econstructor.
  + (* weakening *)
    rename w into wu.
    move/semt:(wu) => IHu.
    move/semV:(wx) => IHx.
    rename wA into wB.
    assert ( wA : Γ ⊢ A).
    { abstract (by inversion wΓ).  }
    assert ( wΓ' :WC Γ).
    { abstract (by inversion wΓ).  }
    have e : wΓ = w_ext wΓ' wA wu by apply:WC_hp.
    subst.
    specialize (IHx wΓ' (WVar_Ty wΓ' wx)).
    specialize (IHu wΓ' wA).
    have rx := fV_r IHx.
    have rA := fV_rT IHx.
    have ru := ft_r IHu.
    have eΓ : fV_C IHx = ft_C IHu.
    {
      apply:rl_hpC.
      -  exact:(rl_V_C rx).
      -  exact:(rl_t_C ru).
    }
    have rAu : rl_T fibT wΓ' wA {| pT_C := fV_C IHx; pT_T :=
                                                       eq_rect_r (@rT T) (ft_T IHu) eΓ |}.
    {
      move:(ft_rT IHu).
      apply:transport.
      move:(ft_T IHu).
      pattern (ft_C IHu),eΓ.
        by apply:J_r.
    }
    have ru' :
      rl_t fibT wΓ' wA wu
           {|
             pt_C := fV_C IHx;
             pt_T := eq_rect_r (@rT T) (ft_T IHu) eΓ;
             pt_t := transport2 (Logic.eq_sym eΓ)
                                (JMeq_sym (JMeq_eq_rect_r (ft_T IHu) eΓ)) (ft_t IHu) |}.
    {
      move:(ft_r IHu).
      apply:transport.
      move:(ft_t IHu).
      move:(ft_T IHu).
      pattern (ft_C IHu),eΓ.
      apply:J_r.
      cbn.
      intros.
      cbn.
      erewrite (uip (uip _ _ ) erefl) .
      reflexivity.
    }

    (* destruct IHx,IHu; subst; simpl in *. *)
    (* subst. *)
    econstructor.
    * apply:rl_vwk; last by apply:rx.
      -- rewrite eΓ. exact:(rl_t_C ru).
      -- exact:rAu.
      -- move:ru.
         apply:transport.
         symmetry.
         apply:pt_eq => //.
         ++ apply:JMeq_eq_rect_r.
         ++ apply:JMeq_transport2 => //.
            apply:JMeq_sym.
            apply:JMeq_eq_rect_r.

      -- assumption.
  + rename w into wu.
    assert ( wA' : Γ ⊢ A).
    { abstract (by inversion wΓ).  }
    assert ( wΓ' :WC Γ).
    { abstract (by inversion wΓ).  }
    move/semt:(wu).
    move/(_ wΓ' wA') => IHu.
    have e : wΓ = w_ext wΓ' wA' wu by apply:WC_hp.
    subst.
    have ru := ft_r IHu.
    (* have r :  rl_C fibT wΓ' (ft_C IHu) *)

    econstructor.
    * constructor; last by apply:ru.
      -- exact:(rl_t_C ru).
      -- exact:(ft_rT IHu).
  + rename w into wu.
    inversion wΓ; subst.
    rename X0 into wA'.
    rename X into wΓ'.
    clear X1.
    move/semt:(wu).
    move/(_ wΓ' wA') => IHu.
    have e : wΓ = w_ext wΓ' wA' wu by apply:WC_hp.
    subst.
    have ru := ft_r IHu.

    inversion wA; subst.
    rename X into wAe.
    rename X1 into wue.
    have e : wA = w_ar wAe (w_va (w_v1 wu)) wue by apply:WTy_hp.
    subst.
    (* have r :  rl_C fibT wΓ' (ft_C IHu) *)

    econstructor.
    * apply:rl_v0 ; last by apply:ru.
      -- exact:(rl_t_C ru).
      -- exact:(ft_rT IHu).
- destruct wσ.
  + move/semt:(w) => /(_ wΓ (w_star wΓ)) IHt.
    have e : wΔ = w_astar by apply:WC_hp.
    have rt := (ft_r IHt).

    subst wΔ.
    econstructor.
    constructor.
    * exact:(rl_t_C rt).
    * simpl.
      apply:tp_rTm1; last by exact:rt.
      -- reflexivity.
      -- unshelve eapply pt_eq1.
         ++   apply:π_eq_pTη.
              apply:rl_hpT.
              ** constructor.
                 exact:(rl_t_C rt).
              ** apply :(ft_rT IHt).
         ++  apply eq_rect_inv.
  +
    have wΔ' : WC Δ by inversion wΔ.
    move/semS:(wσ) => /(_ wΓ wΔ') IHσ.
    move/semT:(w) => /(_  wΔ') IHA.
    move/semt:(w0) => /(_  wΔ' w) IHu.
    have wAσ := WTy_sb wΓ wΔ' wσ w.
    have wuσ := Wtm_sb wΓ wΔ' wσ w0.
    move/semt:(w2) => /(_  wΓ (w_ar wAσ w1 wuσ)) IHf.
    move/semt:(w1) => /(_  wΓ wAσ) IHt.
    have e : wΔ = w_ext wΔ' w w0 by apply:WC_hp.
    subst.
    have rσ := fS_r IHσ.
    have rA := fT_r IHA.
    have ru := ft_r IHu.
    have rt := ft_r IHt.
    have rf := ft_r IHf.
    have esΔ : fT_C IHA = fS_Δ IHσ.
    {
      apply:rl_hpC.
      - exact:(rl_T_C rA).
      - exact:(rl_S_C2 rσ).
    }

    have esΔ' : fS_Δ IHσ = ft_C IHu.
    {
      apply:rl_hpC.
      - exact:(rl_S_C2 rσ).
      - exact:(rl_t_C ru).
    }
    have e :   fS_Γ IHσ  = ft_C IHt.
    {
      apply:rl_hpC.
      - exact:(rl_S_C1 rσ).
      - apply:(rl_t_C rt).
    }

    destruct IHσ,IHu,IHA,IHf,IHt; simpl in *; subst.
    have ft_rT2 := rl_t_Tη ft_r2.
    have ft_rT1 := rl_t_Tη ft_r1.
    have e :   fT_T0  = ft_T0.
    { apply:π_eq_pTη; apply:rl_hpT.
      - eassumption.
      - apply:rl_t_Tη.
        eassumption.
    }
    subst.
    have e :   ft_C1  = ft_C2.
    {
      apply:rl_hpC.
      - exact:(rl_t_C rf).
      - exact:(rl_t_C rt).
    }
    subst.
    have e : ft_T2 = r_sbT fS_S0 ft_T0.
    {
      apply:π_eq_pTη.
      apply:rl_hpT; last first.
      + apply:(rl_sbT (pA := mkpT ft_T0)); eassumption.
      + apply:tp_rT1; last by exact:ft_rT2.
        * reflexivity.
        * reflexivity.
    }
    subst.

  (* {| pt_C := fS_Γ0; pt_T := r_sbT fS_S0 (eq_rect_r rT ft_T0 (erefl ft_C0)); pt_t := ?Goal2 |} = *)
  (* {| pt_C := ft_C2; pt_T := ft_T2; pt_t := ft_t2 |} *)

    econstructor.
    apply:rl_to_ext.
    * apply:(rl_S_C1 rσ).
    * apply:(rl_S_C2 rσ).
    * simpl.
      apply:tp_rT1; last by exact:rA.
      -- reflexivity.
      -- unshelve eapply pT_eq1.
         ++ now symmetry.
         ++ reflexivity.
    * simpl.

      apply:tp_rTm1; last by exact:ru.
      -- reflexivity.
      -- reflexivity.
    * simpl. exact:rσ.
    * simpl.
      apply:tp_rTm1; last by exact:ft_r2.
      -- reflexivity.
      -- unshelve eapply pt_eq1.
         ++ reflexivity.
         ++  reflexivity.
            (* apply:eq_rect_inv. *)
    * simpl.
      apply:tp_rTm1; last by exact:rf.
      -- reflexivity.
      -- unshelve eapply pt_eq1.
         ++ cbn.
            apply:π_eq_pTη.
            apply:rl_hpT; last first.
            **  eassumption.
            ** cbn.
               apply:rl_ar.
               --- apply :(rl_T_C ft_rT1).
               --- assumption.
               --- exact:rt.
               --- apply:tp_rTm1; last first.
                   +++ apply: (rl_sbt (pt := mkpt ft_t0)); eassumption.
                   +++ reflexivity.
                   +++ reflexivity.
         ++ cbn.
            apply:eq_rect_inv.
    Unshelve.
    assumption.
    assumption.
Defined.

End TypeRl.


Require Export featuremodel_spl_proofs.
Require Export featuremodel_spl_int.
Require Export featuremodel_spl_def.
Import FeatureModelSPL.

Require Import Coq.Lists.ListSet.
Require Import Coq.Arith.Arith.
Require Import Coq.Init.Specif.
Require Export Coq.Lists.List.

Program Instance Ins_FeatureModel: FeatureModel FM Conf :=
{
  FMRef := FMRef_Func;
  FMRefinement := FMRefinement_func;
  equivalentFMs := equivalentFMs_func;
}.
 Next Obligation.
  { (* eqFM*)
    intros.
    split.
      + rewrite fm1. apply equals. reflexivity.
      + split.
        - intros. rewrite fm0, fm2. rewrite fm0, fm2 in H. apply H.
        - intros. destruct H. rewrite fm0, fm3. rewrite fm2, fm3 in H0. apply H0.
} Qed. Next Obligation. { (*refFM*)
      intros. rewrite fm3, fm1. rewrite fm1 in H. rewrite fm2 in H. apply H.
}  Qed.


Require Import Coq.Program.Basics.

Require Import Tactics Algebra.Utils SetoidUtils Algebra.SetoidCat Algebra.SetoidCat.ListUtils Algebra.Monad Algebra.SetoidCat.PairUtils Algebra.SetoidCat.MaybeUtils Algebra.Monad.Maybe QAL.Definitions QAL.Command QAL.AbstractHeap QAL.AbstractStore.

Require Import FMapWeakList Coq.Lists.List RelationClasses Relation_Definitions Morphisms SetoidClass.

Section Assert.
  Context
    {builtin : Type}.

  Inductive assertion :=
  | emp : assertion
  | primitive : builtin -> assertion
  | sepConj : assertion -> assertion -> assertion
  | sepImp : assertion -> assertion -> assertion
  | atrue : assertion
  | aAnd : assertion -> assertion -> assertion
  | aNot : assertion -> assertion
  | aExists : var -> assertion -> assertion
  .

  Program Instance assertionS : Setoid assertion.

End Assert.

  Notation "a ∧ b" := (aAnd a b) (left associativity, at level 81).
  Notation "¬ a" := (aNot a) (at level 80).
(*  Notation "[[ addr , p ]] ⟼ val" := (singleton addr p val) (at level 79). *)
  Notation "a ∗ b" := (sepConj a b) (left associativity, at level 83).
  Notation "a -∗ b" := (sepImp a b) (right associativity, at level 84).
  Notation "∃ v , a" := (aExists v a) (at level 85).
  Notation "⊤" := (atrue) (at level 85).

  Module Type PrimitiveAssertion (PT : PredType) (VT : ValType) (S : AbstractStore VT) (H : AbstractHeap PT VT).
    Parameter primitiveAssertion : Type.
    Parameter primitiveAssertionS : Setoid primitiveAssertion.
    Parameter interpretPrimitiveAssertion : primitiveAssertionS ~> S.tS ~~> H.tS ~~> iff_setoid.
  End PrimitiveAssertion.

  Module AssertModel  (PT : PredType) (VT : ValType) (S : AbstractStore VT) (H : AbstractHeap PT VT) (PA: PrimitiveAssertion PT VT S H).
  Import S H PA.
  Definition assertion := @assertion primitiveAssertion.
  Instance assertionS : Setoid assertion := @assertionS primitiveAssertion.

  Fixpoint _models (a : assertion) (s : S.t) (h : H.t) {struct a} : Prop :=
    match a with
      | emp => isEmpty @ h
      | primitive pa => interpretPrimitiveAssertion @ pa @ s @ h
      | a0 ∗ a1 => exists h0 h1,
                     h0 ⊥ h1 /\ h0 ⋅ h1 == h /\ _models a0 s h0  /\ _models a1 s h1
      | a0 -∗ a1 => forall h',
                      h ⊥ h' -> _models a0 s h' -> _models a1 s (h ⋅ h')
      | ¬ a => ~ _models a s h
      | a0 ∧ a1 => _models a0 s h /\ _models a1 s h
      | ⊤ => True
      | ∃ v, a => exists val, _models a (S.update @ v @ val @ s) h
    end.

  Definition models : assertionS ~> S.tS ~~> H.tS ~~> iff_setoid.
    simple refine (injF3 _models _).
    Lemma models_1 : Proper (equiv ==> equiv ==> equiv ==> equiv) _models.
    Proof.
      autounfold. intros x y H. rewrite H. clear x H. induction y.
      intros. unfold _models.  rewritesr.
      intros. unfold _models. rewritesr.
      intros. simpl. split.
      intros. destruct H1. destruct H1. exists x1. exists x2. rewrite <- (IHy1 x y H x1 x1 (reflexivity x1)) , <- (IHy2 x y H x2 x2 (reflexivity x2)). rewrite <- H0. auto.
      intros. destruct H1. destruct H1. exists x1. exists x2. rewrite (IHy1 x y H x1 x1 (reflexivity x1)) , (IHy2 x y H x2 x2 (reflexivity x2)). rewrite H0. auto.
      intros. unfold _models. fold _models. split.
      intros. rewrite <- (IHy2 _ _ H (x0 ⋅ h') (y0 ⋅ h')). apply H1. rewrite H0. auto. rewrite (IHy1 _ _ H h' h'). auto. reflexivity. rewrite H0. reflexivity.
      intros. rewrite (IHy2 _ _ H (x0 ⋅ h') (y0 ⋅ h')). apply H1. rewrite <- H0. auto. rewrite <- (IHy1 _ _ H h' h'). auto. reflexivity. rewrite H0. reflexivity.
      intros. simpl. tauto.
      intros. simpl. rewrite (IHy1 _ _ H _ _ H0), (IHy2 _ _ H _ _ H0). tauto.
      intros. simpl. rewrite (IHy _ _ H _ _ H0). tauto.
      intros. simpl. split.
      intros. destruct H1. exists x1. assert (x [v ↦ x1 ]s == y0 [v ↦ x1 ]s). rewrite H. reflexivity. rewrite <- (IHy (x [v ↦ x1 ]s) (y0 [v ↦ x1 ]s) H2 x0 y1 H0).  auto.
      intros. destruct H1. exists x1. assert (x [v ↦ x1 ]s == y0 [v ↦ x1 ]s). rewrite H. reflexivity. rewrite (IHy (x [v ↦ x1 ]s) (y0 [v ↦ x1 ]s) H2 x0 y1 H0). auto.
    Qed.
    apply models_1.
  Defined.
  Notation "⟦ a ⟧" := (fun s h => models @ a @ s @ h) (at level 50, left associativity).
  Definition simply a a2 := forall s h, ⟦ a ⟧ s h -> ⟦ a2 ⟧ s h.
  Notation "a ⇒ a2" := (simply a a2) (at level 50).
End AssertModel.


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

Require Export repere_ortho_plan.
Set Implicit Arguments.
Unset Strict Implicit.
Parameter AV : Type.
Parameter cons_AV : PP -> PP -> AV.
Parameter plus : AV -> AV -> AV.
Parameter opp : AV -> AV.

Axiom
  existence_AB_unitaire : exists A : PO, (exists B : PO, distance A B = 1).
(* Tout angle a un représentant non unique parmi les angles orientés de vecteurs unitaires*)

Axiom
  existence_representant_cons :
    forall (a : AV) (A B C : PO),
    distance A B = 1 ->
    exists D : PO, distance C D = 1 /\ a = cons_AV (vec A B) (vec C D).
(* Tout angle orienté de vecteurs non nuls est égal à l'angle orienté des vecteurs unitaires correspondants*)

Axiom
  angles_representants_unitaires :
    forall A B C D E F : PO,
    A <> B ->
    C <> D ->
    cons_AV (vec A B) (vec C D) =
    cons_AV (representant_unitaire (vec A B))
      (representant_unitaire (vec C D)).

Axiom
  Chasles :
    forall A B C D E F : PO,
    A <> B ->
    C <> D ->
    E <> F ->
    plus (cons_AV (vec A B) (vec C D)) (cons_AV (vec C D) (vec E F)) =
    cons_AV (vec A B) (vec E F).

Axiom
  def_opp :
    forall A B C D : PO,
    A <> B ->
    C <> D -> opp (cons_AV (vec A B) (vec C D)) = cons_AV (vec C D) (vec A B).
Parameter AV0 : AV.
(* Enroulement de R sur le cercle trigonométrique*)
Parameter image_angle : R -> AV.

Axiom AV0_zero : AV0 = image_angle 0.

Axiom
  unicite_representant_angle_nul :
    forall A B C : PO,
    distance A B = 1 ->
    distance A C = 1 -> cons_AV (vec A B) (vec A C) = image_angle 0 -> C = B.

Axiom
  tout_angle_a_une_mesure :
    forall A B C D : PO,
    A <> B :>PO ->
    C <> D :>PO ->
    exists x : R, image_angle x = cons_AV (vec A B) (vec C D) :>AV.
(* Compatibilité des opérations *)

Axiom
  add_mes_compatible :
    forall x y : R,
    image_angle (x + y) = plus (image_angle x) (image_angle y).

Axiom mes_opp : forall x : R, image_angle (- x) = opp (image_angle x).
(* Cas particuliers : angles plats et angles droits*)
Parameter pisurdeux : R.

Definition pi := pisurdeux + pisurdeux.

Definition deuxpi := pi + pi.

Axiom
  angle_plat :
    forall A B : PO, A <> B -> image_angle pi = cons_AV (vec A B) (vec B A).

Axiom
  pisurdeux_droit :
    forall A B C : PO,
    image_angle pisurdeux = cons_AV (vec A B) (vec A C) ->
    orthogonal (vec A B) (vec A C).

Axiom
  droit_direct_ou_indirect :
    forall A B C : PO,
    A <> B ->
    A <> C ->
    orthogonal (vec A B) (vec A C) ->
    image_angle pisurdeux = cons_AV (vec A B) (vec A C) \/
    image_angle (- pisurdeux) = cons_AV (vec A B) (vec A C).

Lemma existence_representant_angle :
 forall (A B C : PO) (x : R),
 distance A B = 1 ->
 exists D : PO,
   distance C D = 1 /\ image_angle x = cons_AV (vec A B) (vec C D).
intros.
apply existence_representant_cons; auto.
Qed.

Lemma tout_angle_mesure : forall a : AV, exists x : R, a = image_angle x :>AV.
intros.
elim existence_AB_unitaire;
 [ intros A H; elim H;
    [ intros B H0; try clear H existence_AB_unitaire; try exact H0 ] ].
elim existence_representant_cons with (a := a) (A := A) (B := B) (C := A);
 [ intros D H1; elim H1;
    [ intros H2 H3; try clear H1 existence_representant_cons; try exact H3 ]
 | auto ].
elim (tout_angle_a_une_mesure (A:=A) (B:=B) (C:=A) (D:=D)); auto with geo;
 intros.
exists x.
rewrite H4; auto.
Qed.
#[export] Hint Resolve mes_opp add_mes_compatible: geo.

Ltac mes a :=
  elim (tout_angle_mesure a); intros;
   match goal with
   | h:(a = image_angle ?X1) |- _ =>
       try rewrite h; repeat rewrite <- mes_opp;
        repeat rewrite <- add_mes_compatible; repeat rewrite <- mes_opp
   end.
#[export] Hint Resolve def_opp Chasles angles_representants_unitaires: geo.

Ltac mesure A B C D :=
  elim (tout_angle_a_une_mesure (A:=A) (B:=B) (C:=C) (D:=D)); auto with geo;
   intros;
   match goal with
   | h:(image_angle ?X1 = cons_AV (vec A B) (vec C D)) |- _ =>
       try rewrite <- h; repeat rewrite <- mes_opp;
        repeat rewrite <- add_mes_compatible; repeat rewrite <- mes_opp
   end.

Lemma plus_commutative : forall a b : AV, plus a b = plus b a :>AV.
intros.
mes a.
mes b.
repeat rewrite <- add_mes_compatible.
replace (x + x0) with (x0 + x); [ auto | ring ].
Qed.

Lemma plus_angle_zero : forall a : AV, plus a (image_angle 0) = a.
intros.
mes a.
replace (x + 0) with x; [ auto | ring ].
Qed.

Lemma plus_associative :
 forall a b c : AV, plus a (plus b c) = plus (plus a b) c :>AV.
intros.
mes a.
mes b.
mes c.
replace (x + (x0 + x1)) with (x + x0 + x1); [ auto | ring ].
Qed.
#[export] Hint Resolve plus_angle_zero: geo.

Lemma opp_angle :
 forall a b : AV, plus a b = image_angle 0 :>AV -> b = opp a :>AV.
intros.
mes a.
mes b.
replace (image_angle (- x)) with (plus (image_angle (- x)) (image_angle 0));
 auto with geo.
rewrite <- H.
rewrite H1; rewrite H0.
repeat rewrite <- add_mes_compatible.
pattern x0 at 1 in |- *.
replace x0 with (- x + (x + x0)); auto.
ring.
Qed.

Lemma plus_angle_oppose : forall a : AV, plus a (opp a) = image_angle 0.
intros.
mes a.
replace (x + - x) with 0; [ auto | ring ].
Qed.

Lemma mes_oppx :
 forall (A B C D : PO) (x : R),
 A <> B ->
 C <> D ->
 image_angle x = cons_AV (vec A B) (vec C D) ->
 image_angle (- x) = cons_AV (vec C D) (vec A B).
intros.
rewrite <- def_opp; auto.
rewrite <- H1; rewrite <- mes_opp; auto with geo.
Qed.

Lemma mes_opp_opp :
 forall (A B C D E F G I : PO) (a b : R),
 A <> B ->
 C <> D ->
 E <> F ->
 G <> I ->
 image_angle a = cons_AV (vec A B) (vec C D) ->
 image_angle b = cons_AV (vec E F) (vec G I) ->
 image_angle b = image_angle (- a) ->
 cons_AV (vec E F) (vec G I) = opp (cons_AV (vec A B) (vec C D)).
intros A B C D E F G I a b H H0 H1 H2 H3 H4 H5; try assumption.
rewrite <- H4; rewrite def_opp; auto.
rewrite <- (mes_oppx (A:=A) (B:=B) (C:=C) (D:=D) (x:=a)); auto.
Qed.

Lemma permute_angles :
 forall A B C D E F G I : PO,
 A <> B :>PO ->
 C <> D :>PO ->
 E <> F :>PO ->
 G <> I :>PO ->
 cons_AV (vec A B) (vec C D) = cons_AV (vec E F) (vec G I) :>AV ->
 cons_AV (vec C D) (vec A B) = cons_AV (vec G I) (vec E F) :>AV.
intros A B C D E F G I H H0 H1 H2 H3; try assumption.
rewrite <- def_opp; auto.
rewrite <- (def_opp (A:=E) (B:=F) (C:=G) (D:=I)); auto.
rewrite <- H3; auto.
Qed.
#[export] Hint Resolve permute_angles: geo.

Lemma opp_plus_plus_opp :
 forall A B C D E F G I : PO,
 A <> B :>PO ->
 C <> D :>PO ->
 E <> F :>PO ->
 G <> I :>PO ->
 opp (plus (cons_AV (vec A B) (vec C D)) (cons_AV (vec E F) (vec G I))) =
 plus (opp (cons_AV (vec A B) (vec C D))) (opp (cons_AV (vec E F) (vec G I)))
 :>AV.
intros A B C D E F G I H H0 H1 H2; try assumption.
mesure A B C D.
mesure E F G I.
replace (- (x + x0)) with (- x + - x0); auto.
ring.
Qed.
#[export] Hint Resolve opp_plus_plus_opp: geo.

Lemma Chasles_diff :
 forall A B C D E F : PO,
 A <> B :>PO ->
 C <> D :>PO ->
 E <> F :>PO ->
 plus (cons_AV (vec A B) (vec C D)) (opp (cons_AV (vec A B) (vec E F))) =
 cons_AV (vec E F) (vec C D) :>AV.
intros.
rewrite def_opp; auto.
rewrite plus_commutative; auto with geo.
Qed.
#[export] Hint Resolve pisurdeux_droit: geo.

Lemma pisurdeux_scalaire_nul :
 forall A B C : PO,
 image_angle pisurdeux = cons_AV (vec A B) (vec A C) ->
 scalaire (vec A B) (vec A C) = 0.
intros.
apply def_orthogonal.
apply pisurdeux_droit; auto.
Qed.
#[export] Hint Resolve pisurdeux_scalaire_nul: geo.

Lemma orthogonal_pisurdeux_or :
 forall A B C D : PO,
 A <> B ->
 C <> D ->
 orthogonal (vec A B) (vec C D) ->
 image_angle pisurdeux = cons_AV (vec A B) (vec C D) \/
 image_angle (- pisurdeux) = cons_AV (vec A B) (vec C D).
intros A B C D H H0; try assumption.
elim existence_representant_vecteur with (A := A) (B := C) (C := D);
 [ intros E H2; rewrite <- H2; intros ].
apply droit_direct_ou_indirect; auto.
apply distinct_egalite_vecteur with (2 := H2); auto.
Qed.

Lemma angle_nul :
 forall A B : PO, A <> B -> image_angle 0 = cons_AV (vec A B) (vec A B).
intros.
elim existence_representant_unitaire with (A := A) (B := B);
 [ intros C H0; try clear existence_representant_unitaire; try exact H0
 | auto ].
rewrite angles_representants_unitaires; auto.
rewrite <- H0.
cut (A <> C); intros.
cut (image_angle (- pi) = cons_AV (vec C A) (vec A C)); intros.
replace 0 with (pi + - pi).
rewrite add_mes_compatible; rewrite H2; rewrite (angle_plat (A:=A) (B:=C));
 auto.
rewrite Chasles; auto.
ring.
apply mes_oppx; auto.
rewrite (angle_plat (A:=A) (B:=C)); auto.
elim (def_representant_unitaire2 (A:=A) (B:=B) (C:=C)); auto; intros.
elim H2; auto with geo.
Qed.

Lemma pi_plus_pi : image_angle deuxpi = image_angle 0.
unfold deuxpi in |- *; intros.
elim existence_AB_unitaire; intros A H; elim H; intros B H0; try clear H;
 try exact H0.
cut (A <> B); intros.
rewrite add_mes_compatible.
pattern (image_angle pi) at 1 in |- *.
rewrite (angle_plat (A:=A) (B:=B)); auto.
rewrite (angle_plat (A:=B) (B:=A)); auto.
rewrite Chasles; auto.
rewrite <- angle_nul; auto.
auto with geo.
Qed.

Lemma mesure_mod_deuxpi :
 forall (x : R) (A B C D : PO),
 A <> B ->
 C <> D ->
 image_angle x = cons_AV (vec A B) (vec C D) ->
 image_angle (x + deuxpi) = cons_AV (vec A B) (vec C D).
intros.
rewrite add_mes_compatible.
rewrite pi_plus_pi.
rewrite H1.
rewrite (angle_nul (A:=C) (B:=D)); auto.
apply Chasles; auto.
Qed.

Lemma angle_oppu_oppv :
 forall A B C D : PO,
 A <> B :>PO ->
 C <> D :>PO ->
 cons_AV (vec B A) (vec D C) = cons_AV (vec A B) (vec C D) :>AV.
intros.
replace (cons_AV (vec B A) (vec D C)) with
 (plus (cons_AV (vec B A) (vec A B))
    (plus (cons_AV (vec A B) (vec C D)) (cons_AV (vec C D) (vec D C)))).
rewrite <- angle_plat; auto.
rewrite <- angle_plat; auto.
mesure A B C D.
replace (pi + (x + pi)) with (x + deuxpi); try ring; auto.
rewrite (mesure_mod_deuxpi (x:=x) (A:=A) (B:=B) (C:=C) (D:=D)); auto.
unfold deuxpi in |- *; ring.
repeat rewrite Chasles; auto.
Qed.
#[export] Hint Resolve angle_oppu_oppv: geo.

Theorem somme_triangle :
 forall A B C : PO,
 A <> B :>PO ->
 A <> C :>PO ->
 B <> C :>PO ->
 plus (cons_AV (vec A B) (vec A C))
   (plus (cons_AV (vec B C) (vec B A)) (cons_AV (vec C A) (vec C B))) =
 image_angle pi :>AV.
intros A B C H H0 H1; try assumption.
rewrite <- (angle_oppu_oppv (A:=C) (B:=A) (C:=C) (D:=B)); auto.
mesure A B A C.
mesure B C B A.
mesure A C B C.
replace (x + (x0 + x1)) with (x + x1 + x0).
repeat rewrite add_mes_compatible.
rewrite H4; rewrite H3; rewrite H2; repeat rewrite Chasles; auto.
rewrite <- angle_plat; auto.
ring.
Qed.

Lemma angle_triangle :
 forall A B C : PO,
 A <> B ->
 A <> C ->
 B <> C ->
 plus (image_angle pi)
   (opp (plus (cons_AV (vec A B) (vec A C)) (cons_AV (vec B C) (vec B A)))) =
 cons_AV (vec C A) (vec C B).
intros.
rewrite <- (somme_triangle (A:=A) (B:=B) (C:=C)); auto.
rewrite opp_plus_plus_opp; auto.
mesure B C B A.
mesure C A C B.
mesure A B A C.
replace (x1 + (x + x0) + (- x1 + - x)) with x0; auto.
ring.
Qed.
#[export] Hint Resolve angle_triangle: geo.

Lemma angles_complementaires_triangle_rectangle :
 forall (A B C : PO) (a : R),
 A <> B ->
 A <> C ->
 B <> C ->
 orthogonal (vec B A) (vec B C) ->
 image_angle a = cons_AV (vec A B) (vec A C) ->
 image_angle (pisurdeux + - a) = cons_AV (vec C A) (vec C B) \/
 image_angle (- pisurdeux + - a) = cons_AV (vec C A) (vec C B).
intros.
generalize (somme_triangle (A:=A) (B:=B) (C:=C)); intros.
replace (cons_AV (vec C A) (vec C B)) with
 (plus (image_angle pi)
    (opp (plus (cons_AV (vec A B) (vec A C)) (cons_AV (vec B C) (vec B A)))));
 auto with geo.
rewrite opp_plus_plus_opp; auto.
rewrite <- H3.
elim orthogonal_pisurdeux_or with (A := B) (B := C) (C := B) (D := A);
 [ intros H10; try clear orthogonal_pisurdeux_or
 | intros H10; try clear orthogonal_pisurdeux_or
 | auto
 | auto
 | auto with geo ].
rewrite <- H10.
repeat rewrite <- mes_opp.
repeat rewrite <- add_mes_compatible.
left; try assumption.
replace (pisurdeux + - a) with (pi + (- a + - pisurdeux)); auto.
unfold pi in |- *; ring.
rewrite <- H10.
repeat rewrite <- mes_opp.
repeat rewrite <- add_mes_compatible.
right; try assumption.
rewrite <- (plus_angle_zero (image_angle (- pisurdeux + - a))).
rewrite <- pi_plus_pi.
repeat rewrite <- add_mes_compatible.
replace (- pisurdeux + - a + deuxpi) with (pi + (- a + - - pisurdeux)); auto.
unfold deuxpi, pi in |- *; ring.
Qed.

Lemma angle_produit_positif_r :
 forall (k : R) (A B C D E : PO),
 A <> B :>PO ->
 D <> E :>PO ->
 k > 0 ->
 vec A C = mult_PP k (vec A B) :>PP ->
 cons_AV (vec D E) (vec A C) = cons_AV (vec D E) (vec A B).
intros.
cut (A <> C); intros.
2: apply distinct_produit_vecteur with (3 := H2); auto.
rewrite angles_representants_unitaires; auto.
rewrite angles_representants_unitaires; auto.
rewrite (produit_positif_representant_unitaire (k:=k) (A:=A) (B:=B) (C:=C));
 auto.
auto with real.
Qed.
#[export] Hint Resolve angles_representants_unitaires: geo.

Lemma angle_produit_negatif_r :
 forall (k : R) (A B C D E : PO),
 A <> B ->
 D <> E ->
 k < 0 ->
 vec A C = mult_PP k (vec A B) ->
 cons_AV (vec D E) (vec A C) =
 plus (cons_AV (vec D E) (vec A B)) (image_angle pi).
intros.
cut (A <> C); intros.
2: apply distinct_produit_vecteur with (3 := H2); auto.
rewrite angles_representants_unitaires; auto.
rewrite angles_representants_unitaires; auto.
rewrite (produit_negatif_representant_unitaire (k:=k) (A:=A) (B:=B) (C:=C));
 auto.
elim existence_representant_unitaire with (A := A) (B := B);
 [ intros B' H4 | auto ].
rewrite <- H4.
elim def_representant_unitaire2 with (A := A) (B := B) (C := B');
 [ intros; elim H6; intros H7 H8; try clear H6; try exact H7 | auto | auto ].
cut (A <> B'); intros; auto with geo.
replace (mult_PP (-1) (vec A B')) with (vec B' A); [ idtac | Ringvec ].
rewrite (angle_plat (A:=A) (B:=B')); auto.
elim existence_representant_unitaire with (A := D) (B := E);
 [ intros F H9 | auto ].
elim def_representant_unitaire2 with (A := D) (B := E) (C := F);
 [ intros; elim H11; intros H12 H13; try clear H11; try exact H12
 | auto
 | auto ].
cut (D <> F); intros; auto with geo.
rewrite <- H9; rewrite Chasles; auto.
auto with real.
Qed.

Lemma angle_produit_negatif_r2 :
 forall (k : R) (A B C D : PO),
 A <> B ->
 C <> D ->
 k < 0 ->
 cons_AV (vec C D) (mult_PP k (vec A B)) =
 plus (cons_AV (vec C D) (vec A B)) (image_angle pi).
intros.
elim
 existence_representant_mult_vecteur with (A := A) (B := A) (C := B) (k := k);
 intros E H2; try clear existence_representant_mult_vecteur;
 rewrite <- H2.
rewrite (angle_produit_negatif_r (k:=k) (A:=A) (B:=B) (C:=E) (D:=C) (E:=D));
 auto.
Qed.

Lemma angle_produit_negatif_l :
 forall (k : R) (A B C D : PO),
 A <> B ->
 C <> D ->
 k < 0 ->
 cons_AV (mult_PP k (vec A B)) (vec C D) =
 plus (cons_AV (vec A B) (vec C D)) (image_angle pi).
intros.
elim
 existence_representant_mult_vecteur with (A := A) (B := A) (C := B) (k := k);
 intros E H2; try clear existence_representant_mult_vecteur;
 rewrite <- H2.
cut (A <> E); intros.
cut
 (cons_AV (vec C D) (vec A E) =
  plus (cons_AV (vec C D) (vec A B)) (image_angle pi));
 intros.
2: rewrite
    (angle_produit_negatif_r (k:=k) (A:=A) (B:=B) (C:=E) (D:=C) (E:=D))
    ; auto.
rewrite (angle_plat (A:=C) (B:=D)); auto.
rewrite Chasles; auto.
apply permute_angles; auto.
rewrite H4.
rewrite (angle_plat (A:=D) (B:=C)); auto.
rewrite plus_commutative; rewrite Chasles; auto.
apply distinct_produit_vecteur with (3 := H2); auto with real.
Qed.

Lemma angle_produit_positif_r2 :
 forall (k : R) (A B C D : PO),
 A <> B ->
 C <> D ->
 k > 0 ->
 cons_AV (vec C D) (mult_PP k (vec A B)) = cons_AV (vec C D) (vec A B).
intros.
elim
 existence_representant_mult_vecteur with (A := A) (B := A) (C := B) (k := k);
 intros E H2; try clear existence_representant_mult_vecteur;
 rewrite <- H2.
rewrite (angle_produit_positif_r (k:=k) (A:=A) (B:=B) (C:=E) (D:=C) (E:=D));
 auto.
Qed.

Lemma angle_produit_positif_l :
 forall (k : R) (A B C D : PO),
 A <> B ->
 C <> D ->
 k > 0 ->
 cons_AV (mult_PP k (vec A B)) (vec C D) = cons_AV (vec A B) (vec C D).
intros.
elim
 existence_representant_mult_vecteur with (A := A) (B := A) (C := B) (k := k);
 intros E H2; try clear existence_representant_mult_vecteur;
 rewrite <- H2.
cut (A <> E); intros.
cut (cons_AV (vec C D) (vec A E) = cons_AV (vec C D) (vec A B)); intros.
2: rewrite
    (angle_produit_positif_r (k:=k) (A:=A) (B:=B) (C:=E) (D:=C) (E:=D))
    ; auto.
apply permute_angles; auto.
apply distinct_produit_vecteur with (3 := H2); auto with real.
Qed.

Lemma angle_nul_positif_colineaire :
 forall A B C : PO,
 A <> B ->
 A <> C ->
 cons_AV (vec A B) (vec A C) = image_angle 0 ->
 exists k : R, k > 0 /\ vec A C = mult_PP k (vec A B).
intros A B C H H0; try assumption.
cut
 (cons_AV (vec A B) (vec A C) =
  cons_AV (representant_unitaire (vec A B)) (representant_unitaire (vec A C)));
 auto with geo.
elim existence_representant_unitaire with (A := A) (B := B);
 [ intros B' H3; try clear existence_representant_unitaire; rewrite <- H3
 | auto ].
elim existence_representant_unitaire with (A := A) (B := C);
 [ intros C' H4; rewrite <- H4 | auto ].
intros H1; rewrite H1; intros.
elim def_representant_unitaire2 with (A := A) (B := B) (C := B');
 [ intros | auto | auto ].
elim def_representant_unitaire2 with (A := A) (B := C) (C := C');
 [ intros | auto | auto ].
elim H8; intros H9 H10; try clear H8; try exact H10.
elim H6; intros H8 H11; try clear H6; try exact H11.
cut (C' = B'); intros.
2: apply unicite_representant_angle_nul with A; auto with geo.
apply egalite_representant_unitaire; auto with geo.
rewrite <- H4; rewrite <- H3; rewrite <- H6; auto.
Qed.

Lemma angles_milieu :
 forall A B C I : PO,
 B <> C :>PO ->
 B <> A :>PO ->
 I = milieu B C :>PO ->
 cons_AV (vec B C) (vec B A) = cons_AV (vec B I) (vec B A) :>AV.
intros.
replace (vec B C) with (mult_PP 2 (vec B I)); auto with geo.
apply angle_produit_positif_l; auto.
rewrite H1; apply milieu_distinct; auto.
lra.
rewrite <- (milieu_vecteur_double (A:=B) (B:=C) (M:=I)); auto.
Qed.

Lemma angles_milieu2 :
 forall A B C I : PO,
 B <> C :>PO ->
 C <> A :>PO ->
 I = milieu B C :>PO ->
 cons_AV (vec C A) (vec C B) = cons_AV (vec C A) (vec C I) :>AV.
intros.
replace (vec C B) with (mult_PP 2 (vec C I)); auto with geo.
apply angle_produit_positif_r2; auto.
rewrite H1; apply milieu_distinct2; auto.
lra.
rewrite <- (milieu_vecteur_double (A:=C) (B:=B) (M:=I)); auto with geo.
Qed.

Lemma milieu_angles :
 forall A B M N : PO,
 A <> B ->
 M <> N ->
 M = milieu A B ->
 cons_AV (vec M A) (vec M N) =
 plus (cons_AV (vec M B) (vec M N)) (image_angle pi) :>AV.
intros.
VReplace (vec M A) (mult_PP (-1) (vec A M)).
rewrite <- (milieu_vecteur H1); auto.
apply angle_produit_negatif_l; auto.
cut (B <> M); intros; auto.
rewrite H1; apply milieu_distinct; auto.
rewrite H1; apply milieu_distinct2; auto.
lra.
Qed.

Axiom
  milieu_angles_orthogonaux :
    forall A B M N : PO,
    A <> B ->
    M <> N ->
    M = milieu A B ->
    orthogonal (vec A B) (vec M N) ->
    cons_AV (vec M A) (vec M N) = cons_AV (vec M N) (vec M B) :>AV.

Lemma alignes_distance_positif_colineaire :
 forall (k : R) (A B C : PO),
 A <> B ->
 A <> C ->
 cons_AV (vec A B) (vec A C) = image_angle 0 ->
 distance A C = k * distance A B -> vec A C = mult_PP k (vec A B).
intros.
elim angle_nul_positif_colineaire with (A := A) (B := B) (C := C);
 [ intros k0 H3; elim H3; intros H4 H5; try clear H3; try exact H5
 | auto
 | auto
 | auto ].
replace k with k0; auto.
cut (distance A C = k0 * distance A B); intros.
apply Rmult_eq_reg_l with (distance A B); auto with geo real.
replace (distance A B * k0) with (distance A C) by (rewrite H3 in |- *;  ring).
rewrite H2 in |- *;  ring.
replace k0 with (Rabs k0); auto with geo real.
apply Rabs_right; auto with real.
lra.
Qed.

Lemma angle_pi_negatif_colineaire :
 forall A B C : PO,
 A <> B ->
 A <> C ->
 cons_AV (vec A B) (vec A C) = image_angle pi ->
 exists k : R, k < 0 /\ vec A C = mult_PP k (vec A B).
intros A B C H H0; try assumption.
cut
 (cons_AV (vec A B) (vec A C) =
  cons_AV (representant_unitaire (vec A B)) (representant_unitaire (vec A C)));
 auto with geo.
elim existence_representant_unitaire with (A := A) (B := B);
 [ intros B' H3; try clear existence_representant_unitaire; rewrite <- H3
 | auto ].
elim existence_representant_unitaire with (A := A) (B := C);
 [ intros C' H4; rewrite <- H4 | auto ].
intros H1; rewrite H1; intros.
elim def_representant_unitaire2 with (A := A) (B := B) (C := B');
 [ intros | auto | auto ].
elim def_representant_unitaire2 with (A := A) (B := C) (C := C');
 [ intros | auto | auto ].
elim H8; intros H9 H10; try clear H8; try exact H10.
elim H6; intros H8 H11; try clear H6; try exact H11.
cut (A <> B'); intros; auto with geo.
cut (A <> C'); intros; auto with geo.
apply oppose_representant_unitaire; auto.
rewrite <- H4; rewrite <- H3.
elim
 existence_representant_mult_vecteur
  with (A := A) (B := A) (C := B') (k := -1); intros D;
 intros.
rewrite <- H13.
replace D with C'; auto.
cut (scalaire (vec A D) (vec A D) = 1); intros.
apply unicite_representant_angle_nul with A; auto with geo.
replace (vec A D) with (vec B' A).
replace (cons_AV (vec B' A) (vec A C')) with
 (plus (cons_AV (vec B' A) (vec A B')) (cons_AV (vec A B') (vec A C'))).
rewrite <- angle_plat; [ idtac | auto ].
rewrite H2; rewrite <- add_mes_compatible.
replace (pi + pi) with deuxpi; auto.
rewrite pi_plus_pi; auto.
rewrite Chasles; auto.
rewrite H13; Ringvec.
rewrite H13; Simplscal; auto.
Qed.

Lemma alignes_distance_negatif_colineaire :
 forall (k : R) (A B C : PO),
 A <> B ->
 A <> C ->
 cons_AV (vec A B) (vec A C) = image_angle pi ->
 distance A C = k * distance A B -> vec A C = mult_PP (- k) (vec A B).
intros.
elim angle_pi_negatif_colineaire with (A := A) (B := B) (C := C);
 [ intros k0 H3; elim H3; intros H4 H5; try clear H3; try exact H5
 | auto
 | auto
 | auto ].
replace k with (- k0).
replace (- - k0) with k0; try ring; auto.
cut (distance A C = - k0 * distance A B); intros; auto.
apply Rmult_eq_reg_l with (distance A B); auto with geo.
replace (distance A B * -k0) with (distance A C)
 by (rewrite H3 in |- *;  ring).
rewrite H2 in |- *;  ring.
replace (- k0) with (Rabs k0); auto with geo.
apply Rabs_left; auto with real.
Qed.
#[export] Hint Resolve plus_angle_zero: geo.


Require Import LibTactics.
Require Import Metalib.Metatheory.

Require Import
        syntax_ott
        rules_inf
        Infrastructure
        Subtyping_inversion
        Deterministic
        Type_Safety
        rules_inf2.
Require Import Coq.Strings.String.

Fixpoint erase_anno (e:exp) : dexp :=
  match e with
  | e_var_b nat => de_var_b nat
  | e_var_f x => de_var_f x
  | e_top => de_top
  | e_lit i5 => de_lit i5
  | e_abs A e B => de_abs (erase_anno e)
  | e_fixpoint A e => de_fixpoint (erase_anno e)
  | e_app e1 e2 => de_app (erase_anno e1) (erase_anno e2)
  | e_merge e1 e2 => de_merge (erase_anno e1) (erase_anno e2)
  | e_pair e1 e2 => de_pair (erase_anno e1) (erase_anno e2)
  | e_projl e => (erase_anno e)
  | e_projr e => (erase_anno e)
  | e_anno e A => erase_anno e
  end.

Notation "| e |" := (erase_anno e) (at level 30, e at level 39).

Require Import Lia.

Ltac size_ind_auto :=
  ( eapply_first_lt_hyp ;
    try reflexivity;
    try lia ;
    try eauto ).

Lemma erasure_open_aux : forall i,
    forall e, (size_exp e = i -> forall t n, | open_exp_wrt_exp_rec n t e | = open_dexp_wrt_dexp_rec n (| t |) (| e |)).
Proof.
  intros i. pattern i. apply lt_wf_rec.
    clear i; intros i H;
      apply_mutual_ind exp_mutind;
      default_simp; size_ind_auto.
Qed.

Lemma erasure_open : forall e t,
    | e ^^ t | = open_dexp_wrt_dexp (| e |)  (| t |).
Proof.
  intros e v.
  pose proof (erasure_open_aux (size_exp e)).
  intuition eauto.
Qed.

Lemma erasure_lc_aux : forall i,
   forall e, (size_exp e = i -> lc_exp e -> lc_dexp (| e |) ).
Proof.
  intros i. pattern i. apply lt_wf_rec.
    clear i; intros i H;
      apply_mutual_ind exp_mutind;
      default_simp;
      try solve [ size_ind_auto ];
      try solve [
            constructor;
            size_ind_auto
          ].
  - (* abs *)
    pick fresh x.
    apply (lc_de_abs_exists x).
    assert ( |e_var_f x| = de_var_f x ) by auto.
    rewrite <- H1.
    rewrite <- erasure_open.
    eapply_first_lt_hyp;
    try (apply size_exp_open_exp_wrt_exp_var);
    try lia.
    apply H3.
  - (* fix *)
    pick fresh x.
    apply (lc_de_fixpoint_exists x).
    assert ( |e_var_f x| = de_var_f x ) by auto.
    rewrite <- H1.
    rewrite <- erasure_open.
    eapply_first_lt_hyp;
    try (apply size_exp_open_exp_wrt_exp_var);
    try lia.
    apply H3.
Qed.

Lemma erasure_lc : forall e,
    lc_exp e -> lc_dexp (erase_anno e).
Proof.
  intros e H.
  pose proof erasure_lc_aux (size_exp e).
  intuition eauto.
Qed.
(*
Lemma erasure_val : forall v,
    value v -> DValue (erase_anno v).
Proof.
  intros v H.
  induction H;
    simpl;
    try constructor*;
    try forwards*: erasure_lc H.
Qed.

Lemma D_value_lc : forall v,
    DValue v -> lc_dexp v.
Proof.
  intros v H.
  induction H;
    simpl;
    try solve [constructor*].
  auto.
Qed.

Lemma TypedReduce_lc: forall v A v',
    TypedReduce v A v'-> lc_exp v /\ lc_exp v'.
Proof.
  introv Red.
  induction Red;
    try solve [constructor*].
  - Case "absv".
    inverts H.
    auto.
Qed.

Hint Resolve erasure_lc TypedReduce_lc : core.

Lemma star_onestep : forall a b,
    DunfieldStep a b -> a ->>*  b.
Proof.
  intros a b H.
  eapply star_trans.
  apply star_refl.
  auto.
Qed.

(* eval ctxt *)
Lemma step_mergel : forall e1 e2 e1',
    e1 ->>* e1' -> lc_dexp e2 -> (de_merge e1 e2) ->>* (de_merge e1' e2).
Proof.
  intros e1 e2 e1' H LC.
  induction H.
  auto.
  eapply star_trans.
  apply star_onestep.
  apply DStep_mergel.
  auto.
  apply H.
  auto.
Qed.

Lemma step_merger : forall v1 e2 e2',
    e2 ->>* e2' -> lc_dexp v1 -> DValue v1 -> (de_merge v1 e2) ->>* (de_merge v1 e2').
Proof.
  intros v1 e2 e2' H LC Val.
  induction~ H.
  applys* star_trans.
Qed.

Lemma step_appl : forall e1 e1' e2,
    e1 ->>* e1' -> lc_dexp e2 -> (de_app e1 e2) ->>* (de_app e1' e2).
Proof.
  intros e1 e1' e2 H LC.
  induction~ H.
  applys* star_trans.
Qed.

Lemma step_appr : forall v1 e2 e2',
    e2 ->>* e2' -> DValue v1 -> (de_app v1 e2) ->>* (de_app v1 e2').
Proof.
  intros v1 e2 e2' H Val.
  induction~ H.
  applys* star_trans.
Qed.

Lemma tred_soundness : forall v A v',
    value v -> TypedReduce v A v' -> (erase_anno v) ->>* (erase_anno v').
Proof.
  intros v A v' Val Red.
  lets Red': Red.
  induction Red;
    lets [Lc Lc']: TypedReduce_lc Red';
    simpl; auto;
      try solve [inverts Val; inverts* Lc].
  - lets : erasure_lc Lc.
    lets : erasure_val Val.
    eapply star_trans.
    apply star_onestep.
    applys* DStep_top.
    apply star_refl.
  - lets : erasure_lc Lc.
    lets : erasure_val Val.
    eapply star_trans.
    apply star_onestep.
    eapply DStep_split.
    auto.
    eapply star_trans.
    apply step_mergel.
    forwards*: IHRed1.
    auto.
    inverts* Lc'.
    forwards*: erasure_lc H3.
    apply~ step_merger.
    apply~ erasure_val.
    forwards*: TypedReduce_prv_value Red1.
Qed.

Theorem reduction_soundness : forall e e',
    step e e' -> (erase_anno e) ->>* (erase_anno e').
Proof.
  intros e e' Red.
  induction Red;
    try solve [
        simpl;
        apply star_refl ].
  - simpl.
    econstructor.
    apply DStep_toparr. lets* : erasure_val H.
    apply star_refl.
  -
    simpl.
    lets : tred_soundness H0 H1.
    lets Lc: erasure_lc H.
    lets Val: erasure_val H0.
    simpl in Lc.
    lets [Lc_v Lc_v']: TypedReduce_lc H1.
    eapply star_trans.
    eapply step_appr.
    apply H2.
    auto. auto.

    apply star_onestep.
    assert (| e ^^ v'| = open_dexp_wrt_dexp (| e |)  (| v' |)) by apply erasure_open.
    simpl.
    rewrite H3.
    apply~ DStep_beta.
    apply~ erasure_val.
    forwards*: TypedReduce_prv_value H1.
  -
    simpl.
    lets* : tred_soundness H.
  -
    simpl.
    apply~ step_appl.
  -
    simpl.
    lets Val: erasure_val H.
    lets Lc: erasure_lc.
    apply~ step_appr.
  -
    simpl.
    apply~ step_mergel.
  -
    simpl.
    lets Val: erasure_val H.
    apply~ step_merger.
    apply~ D_value_lc.
  -
    simpl.
    auto.
  -
    apply erasure_lc in H.
    apply star_onestep.
    assert (| e ^^ e_fixpoint A e | = open_dexp_wrt_dexp (| e |)  (| e_fixpoint A e |)) by apply erasure_open.
    simple. rewrite H0.
    apply~ DStep_fix.
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.     *)
(*                                                                     *)
(* *********************************************************************)

(** Branch tunneling (optimization of branches to branches). *)

Require Import FunInd.
Require Import Coqlib Maps UnionFind.
Require Import AST.
Require Import LTL.

(** Branch tunneling shortens sequences of branches (with no intervening
  computations) by rewriting the branch and conditional branch instructions
  so that they jump directly to the end of the branch sequence.
  For example:
<<
     L1: branch L2;                       L1: branch L3;
     L2; branch L3;            becomes    L2: branch L3;
     L3: instr;                           L3: instr;
     L4: if (cond) goto L1;               L4: if (cond) goto L3;
>>
  This optimization can be applied to several of our intermediate
  languages.  We choose to perform it on the [LTL] language,
  after register allocation but before code linearization.
  Register allocation can delete instructions (such as dead
  computations or useless moves), therefore there are more
  opportunities for tunneling after allocation than before.
  Symmetrically, prior tunneling helps linearization to produce
  better code, e.g. by revealing that some [branch] instructions are
  dead code (as the "branch L3" in the example above).
*)

(** The naive implementation of branch tunneling would replace
  any branch to a node [pc] by a branch to the node
  [branch_target f pc], defined as follows:
<<
  branch_target f pc = branch_target f pc'  if f(pc) = branch pc'
                     = pc                   otherwise
>>
  However, this definition can fail to terminate if
  the program can contain loops consisting only of branches, as in
<<
     L1: branch L1;
>>
  or
<<
     L1: branch L2;
     L2: branch L1;
>>
  Coq warns us of this fact by not accepting the definition
  of [branch_target] above.

  To handle this problem, we proceed in two passes:

- The first pass populates a union-find data structure, adding equalities
  between PCs of blocks that are connected by branches and no other
  computation.

- The second pass rewrites the code, replacing every branch to a node [pc]
  by a branch to the canonical representative of the equivalence class of [pc].
*)

(** * Construction of the union-find data structure *)

Module U := UnionFind.UF(PTree).

(** We start populating the union-find data structure by adding
    equalities [pc = pc'] for every block [pc: branch pc'] in the function. *)

Definition record_branch (uf: U.t) (pc: node) (b: bblock) : U.t :=
  match b with
  | Lbranch s :: _ => U.union uf pc s
  | _ => uf
  end.

Definition record_branches (f: LTL.function) : U.t :=
  PTree.fold record_branch f.(fn_code) U.empty.

(** An additional optimization opportunity comes from conditional branches.
    Consider a block [pc: cond ifso ifnot].  If the [ifso] case
    and the [ifnot] case jump to the same block [pc']
    (modulo intermediate branches), the block can be simplified into
    [pc: branch pc'], and the equality [pc = pc'] can be added to the
    union-find data structure. *)

(** In rare cases, the extra equation [pc = pc'] introduced by the
    simplification of a conditional branch can trigger further simplifications
    of other conditional branches.  We therefore iterate the analysis
    until no optimizable conditional branch remains. *)

(** The code [c] (first component of the [st] triple) starts identical
    to the code [fn.(fn_code)] of the current function, but each time
    conditional branch at [pc] is optimized, we remove the block at
    [pc] from the code [c].  This guarantees termination of the
    iteration. *)

Definition record_cond (st: code * U.t * bool) (pc: node) (b: bblock) : code * U.t * bool :=
   match b with
  | Lcond cond args s1 s2 :: _ =>
      let '(c, u, _) := st in
      if peq (U.repr u s1) (U.repr u s2)
      then (PTree.remove pc c, U.union u pc s1, true)
      else st
  | _ =>
      st
  end.

Definition record_conds_1 (cu: code * U.t) : code * U.t * bool :=
  let (c, u) := cu in PTree.fold record_cond c (c, u, false).

Definition measure_state (cu: code * U.t) : nat :=
  PTree_Properties.cardinal (fst cu).

Function record_conds (cu: code * U.t) {measure measure_state cu} : U.t :=
  let (cu', changed) := record_conds_1 cu in
  if changed then record_conds cu' else snd cu.
Proof.
  intros [c0 u0] [c1 u1].
  set (P := fun (c: code) (s: code * U.t * bool) =>
              (forall pc, c!pc = None -> (fst (fst s))!pc = c0!pc) /\
              (PTree_Properties.cardinal (fst (fst s))
               + (if snd s then 1 else 0)
               <= PTree_Properties.cardinal c0)%nat).
  assert (A: P c0 (PTree.fold record_cond c0 (c0, u0, false))).
  { apply PTree_Properties.fold_rec; unfold P.
  - intros. destruct H0; split; auto. intros. rewrite <- H in H2. auto.
  - simpl; split; intros. auto.  simpl; lia.
  - intros cd [[c u] changed] pc b NONE SOME [HR1 HR2]. simpl. split.
    + intros p EQ. rewrite PTree.gsspec in EQ. destruct (peq p pc); try discriminate.
      unfold record_cond. destruct b as [ | [] b ]; auto.
      destruct (peq (U.repr u s1) (U.repr u s2)); auto.
      simpl. rewrite PTree.gro by auto. auto.
    + unfold record_cond. destruct b as [ | [] b ]; auto.
      destruct (peq (U.repr u s1) (U.repr u s2)); auto.
      simpl in *.
      assert (SOME': c!pc = Some (Lcond cond args s1 s2 :: b)).
      { rewrite HR1 by auto. auto. }
      generalize (PTree_Properties.cardinal_remove SOME').
      destruct changed; lia.
  }
  unfold record_conds_1, measure_state; intros.
  destruct A as [_ A]. rewrite teq in A. simpl in *.
  lia.
Qed.

Definition record_gotos (f: LTL.function) : U.t :=
  record_conds (f.(fn_code), record_branches f).

(** * Code transformation *)

(** The code transformation rewrites all LTL instruction, replacing every
  successor [s] of every instruction by the canonical representative
  of its equivalence class in the union-find data structure.
  Additionally, [Lcond] conditional branches are turned into [Lbranch]
  unconditional branches whenever possible. *)

Definition tunnel_instr (u: U.t) (i: instruction) : instruction :=
  match i with
  | Lbranch s => Lbranch (U.repr u s)
  | Lcond cond args s1 s2 =>
      let s1' := U.repr u s1 in let s2' := U.repr u s2 in
      if peq s1' s2'
      then Lbranch s1'
      else Lcond cond args s1' s2'
  | Ljumptable arg tbl => Ljumptable arg (List.map (U.repr u) tbl)
  | _ => i
  end.

Definition tunnel_block (u: U.t) (b: bblock) : bblock :=
  List.map (tunnel_instr u) b.

Definition tunnel_function (f: LTL.function) : LTL.function :=
  let u := record_gotos f in
  mkfunction
    (fn_sig f)
    (fn_stacksize f)
    (PTree.map1 (tunnel_block u) (fn_code f))
    (U.repr u (fn_entrypoint f)).

Definition tunnel_fundef (f: LTL.fundef) : LTL.fundef :=
  transf_fundef tunnel_function f.

Definition tunnel_program (p: LTL.program) : LTL.program :=
  transform_program tunnel_fundef p.


(** * Stlc: The Simply Typed Lambda-Calculus *)

Require Import Maps.
Require Import Smallstep.
Require Import Types.

(* ###################################################################### *)
(** * The Simply Typed Lambda-Calculus *)

(** The simply typed lambda-calculus (STLC) is a tiny core calculus
    embodying the key concept of _functional abstraction_, which shows
    up in pretty much every real-world programming language in some
    form (functions, procedures, methods, etc.).

    We will follow exactly the same pattern as in the previous
    chapter when formalizing this calculus (syntax, small-step
    semantics, typing rules) and its main properties (progress and
    preservation).  The new technical challenges (which will take some
    work to deal with) all arise from the mechanisms of _variable
    binding_ and _substitution_. *)

(* ###################################################################### *)
(** ** Overview *)

(** The STLC is built on some collection of _base types_ -- booleans,
    numbers, strings, etc.  The exact choice of base types doesn't
    matter -- the construction of the language and its theoretical
    properties work out pretty much the same -- so for the sake of
    brevity let's take just [Bool] for the moment.  At the end of the
    chapter we'll see how to add more base types, and in later
    chapters we'll enrich the pure STLC with other useful constructs
    like pairs, records, subtyping, and mutable state.

    Starting from the booleans, we add three things:
        - variables
        - function abstractions
        - application

    This gives us the following collection of abstract syntax
    constructors (written out here in informal BNF notation -- we'll
    formalize it below).

*)

(** Informal concrete syntax:
       t ::= x                       variable
           | \x:T1.t2                abstraction
           | t1 t2                   application
           | true                    constant true
           | false                   constant false
           | if t1 then t2 else t3   conditional
*)

(** The [\] symbol (backslash, in ascii) in a function abstraction
    [\x:T1.t2] is generally written as a greek letter "lambda" (hence
    the name of the calculus).  The variable [x] is called the
    _parameter_ to the function; the term [t2] is its _body_.  The
    annotation [:T] specifies the type of arguments that the function
    can be applied to. *)

(** Some examples:

      - [\x:Bool. x]

        The identity function for booleans.

      - [(\x:Bool. x) true]

        The identity function for booleans, applied to the boolean [true].

      - [\x:Bool. if x then false else true]

        The boolean "not" function.

      - [\x:Bool. true]

        The constant function that takes every (boolean) argument to
        [true]. *)
(**
      - [\x:Bool. \y:Bool. x]

        A two-argument function that takes two booleans and returns
        the first one.  (Note that, as in Coq, a two-argument function
        is really a one-argument function whose body is also a
        one-argument function.)

      - [(\x:Bool. \y:Bool. x) false true]

        A two-argument function that takes two booleans and returns
        the first one, applied to the booleans [false] and [true].

        Note that, as in Coq, application associates to the left --
        i.e., this expression is parsed as [((\x:Bool. \y:Bool. x)
        false) true].

      - [\f:Bool->Bool. f (f true)]

        A higher-order function that takes a _function_ [f] (from
        booleans to booleans) as an argument, applies [f] to [true],
        and applies [f] again to the result.

      - [(\f:Bool->Bool. f (f true)) (\x:Bool. false)]

        The same higher-order function, applied to the constantly
        [false] function. *)

(** As the last several examples show, the STLC is a language of
    _higher-order_ functions: we can write down functions that take
    other functions as arguments and/or return other functions as
    results.

    Another point to note is that the STLC doesn't provide any
    primitive syntax for defining _named_ functions -- all functions
    are "anonymous."  We'll see in chapter [MoreStlc] that it is easy
    to add named functions to what we've got -- indeed, the
    fundamental naming and binding mechanisms are exactly the same.

    The _types_ of the STLC include [Bool], which classifies the
    boolean constants [true] and [false] as well as more complex
    computations that yield booleans, plus _arrow types_ that classify
    functions. *)
(**
      T ::= Bool
          | T1 -> T2
    For example:

      - [\x:Bool. false] has type [Bool->Bool]

      - [\x:Bool. x] has type [Bool->Bool]

      - [(\x:Bool. x) true] has type [Bool]

      - [\x:Bool. \y:Bool. x] has type [Bool->Bool->Bool] (i.e. [Bool -> (Bool->Bool)])

      - [(\x:Bool. \y:Bool. x) false] has type [Bool->Bool]

      - [(\x:Bool. \y:Bool. x) false true] has type [Bool]
*)

(* ###################################################################### *)
(** ** Syntax *)

Module STLC.

(* ################################### *)
(** *** Types *)

Inductive ty : Type :=
  | TBool  : ty
  | TArrow : ty -> ty -> ty.

(* ################################### *)
(** *** Terms *)

Inductive tm : Type :=
  | tvar : id -> tm
  | tapp : tm -> tm -> tm
  | tabs : id -> ty -> tm -> tm
  | ttrue : tm
  | tfalse : tm
  | tif : tm -> tm -> tm -> tm.

(** Note that an abstraction [\x:T.t] (formally, [tabs x T t]) is
    always annotated with the type [T] of its parameter, in contrast
    to Coq (and other functional languages like ML, Haskell, etc.),
    which use _type inference_ to fill in missing annotations.  We're
    not considering type inference here, to keep things simple. *)

(** Some examples... *)

Definition x := (Id 0).
Definition y := (Id 1).
Definition z := (Id 2).
Hint Unfold x.
Hint Unfold y.
Hint Unfold z.

(** [idB = \x:Bool. x] *)

Notation idB :=
  (tabs x TBool (tvar x)).

(** [idBB = \x:Bool->Bool. x] *)

Notation idBB :=
  (tabs x (TArrow TBool TBool) (tvar x)).

(** [idBBBB = \x:(Bool->Bool) -> (Bool->Bool). x] *)

Notation idBBBB :=
  (tabs x (TArrow (TArrow TBool TBool)
                      (TArrow TBool TBool))
    (tvar x)).

(** [k = \x:Bool. \y:Bool. x] *)

Notation k := (tabs x TBool (tabs y TBool (tvar x))).

(** [notB = \x:Bool. if x then false else true] *)

Notation notB := (tabs x TBool (tif (tvar x) tfalse ttrue)).

(** (We write these as [Notation]s rather than [Definition]s to make
    things easier for [auto].) *)

(* ###################################################################### *)
(** ** Operational Semantics *)

(** To define the small-step semantics of STLC terms, we begin -- as
    always -- by defining the set of values.  Next, we define the
    critical notions of _free variables_ and _substitution_, which are
    used in the reduction rule for application expressions.  And
    finally we give the small-step relation itself. *)

(* ################################### *)
(** *** Values *)

(** To define the values of the STLC, we have a few cases to consider.

    First, for the boolean part of the language, the situation is
    clear: [true] and [false] are the only values.  An [if]
    expression is never a value. *)

(** Second, an application is clearly not a value: It represents a
    function being invoked on some argument, which clearly still has
    work left to do. *)

(** Third, for abstractions, we have a choice:

      - We can say that [\x:T.t1] is a value only when [t1] is a
        value -- i.e., only if the function's body has been
        reduced (as much as it can be without knowing what argument it
        is going to be applied to).

      - Or we can say that [\x:T.t1] is always a value, no matter
        whether [t1] is one or not -- in other words, we can say that
        reduction stops at abstractions.

    Coq, in its built-in functional programming langauge, makes the
    first choice -- for example,
         Compute (fun x:bool => 3 + 4)
    yields [fun x:bool => 7].

    Most real-world functional programming languages make the second
    choice -- reduction of a function's body only begins when the
    function is actually applied to an argument.  We also make the
    second choice here. *)

Inductive value : tm -> Prop :=
  | v_abs : forall x T t,
      value (tabs x T t)
  | v_true :
      value ttrue
  | v_false :
      value tfalse.

Hint Constructors value.

(** Finally, we must consider what constitutes a _complete_ program.

  Intuitively, a "complete" program must not refer to any undefined
  variables.  We'll see shortly how to define the "free" variables
  in a STLC term.  A program is "closed", that is, it contains no
  free variables.

*)

(** Having made the choice not to reduce under abstractions,
    we don't need to worry about whether variables are values, since
    we'll always be reducing programs "from the outside in," and that
    means the [step] relation will always be working with closed
    terms (ones with no free variables).  *)

(* ###################################################################### *)
(** *** Substitution *)

(** Now we come to the heart of the STLC: the operation of
    substituting one term for a variable in another term.

    This operation will be used below to define the operational
    semantics of function application, where we will need to
    substitute the argument term for the function parameter in the
    function's body.  For example, we reduce
       (\x:Bool. if x then true else x) false
    to
       if false then true else false
    by substituting [false] for the parameter [x] in the body of the
    function.

    In general, we need to be able to substitute some given
    term [s] for occurrences of some variable [x] in another term [t].
    In informal discussions, this is usually written [ [x:=s]t ] and
    pronounced "substitute [x] with [s] in [t]." *)

(** Here are some examples:

      - [[x:=true] (if x then x else false)] yields [if true then true else false]

      - [[x:=true] x] yields [true]

      - [[x:=true] (if x then x else y)] yields [if true then true else y]

      - [[x:=true] y] yields [y]

      - [[x:=true] false] yields [false] (vacuous substitution)

      - [[x:=true] (\y:Bool. if y then x else false)] yields [\y:Bool. if y then true else false]
      - [[x:=true] (\y:Bool. x)] yields [\y:Bool. true]

      - [[x:=true] (\y:Bool. y)] yields [\y:Bool. y]

      - [[x:=true] (\x:Bool. x)] yields [\x:Bool. x]

    The last example is very important: substituting [x] with [true] in
    [\x:Bool. x] does _not_ yield [\x:Bool. true]!  The reason for
    this is that the [x] in the body of [\x:Bool. x] is _bound_ by the
    abstraction: it is a new, local name that just happens to be
    spelled the same as some global name [x]. *)

(** Here is the definition, informally...
   [x:=s]x = s
   [x:=s]y = y                                   if x <> y
   [x:=s](\x:T11.t12)   = \x:T11. t12
   [x:=s](\y:T11.t12)   = \y:T11. [x:=s]t12      if x <> y
   [x:=s](t1 t2)        = ([x:=s]t1) ([x:=s]t2)
   [x:=s]true           = true
   [x:=s]false          = false
   [x:=s](if t1 then t2 else t3) =
                   if [x:=s]t1 then [x:=s]t2 else [x:=s]t3
*)

(**    ... and formally: *)

Reserved Notation "'[' x ':=' s ']' t" (at level 20).

Fixpoint subst (x:id) (s:tm) (t:tm) : tm :=
  match t with
  | tvar x' =>
      if beq_id x x' then s else t
  | tabs x' T t1 =>
      tabs x' T (if beq_id x x' then t1 else ([x:=s] t1))
  | tapp t1 t2 =>
      tapp ([x:=s] t1) ([x:=s] t2)
  | ttrue =>
      ttrue
  | tfalse =>
      tfalse
  | tif t1 t2 t3 =>
      tif ([x:=s] t1) ([x:=s] t2) ([x:=s] t3)
  end

where "'[' x ':=' s ']' t" := (subst x s t).

(** _Technical note_: Substitution becomes trickier to define if we
    consider the case where [s], the term being substituted for a
    variable in some other term, may itself contain free variables.
    Since we are only interested here in defining the [step] relation
    on closed terms (i.e., terms like [\x:Bool. x], that do not mention
    variables are not bound by some enclosing lambda), we can skip
    this extra complexity here, but it must be dealt with when
    formalizing richer languages. *)

(** **** Exercise: 3 stars (substi)  *)

(** The definition that we gave above uses Coq's [Fixpoint] facility
    to define substitution as a _function_.  Suppose, instead, we
    wanted to define substitution as an inductive _relation_ [substi].
    We've begun the definition by providing the [Inductive] header and
    one of the constructors; your job is to fill in the rest of the
    constructors. *)

Inductive substi (s:tm) (x:id) : tm -> tm -> Prop :=
  | s_var1 :
      substi s x (tvar x) s
  (* FILL IN HERE *)
.

Hint Constructors substi.

Theorem substi_correct : forall s x t t',
  [x:=s]t = t' <-> substi s x t t'.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(* ################################### *)
(** *** Reduction *)

(** The small-step reduction relation for STLC now follows the same
    pattern as the ones we have seen before.  Intuitively, to reduce a
    function application, we first reduce its left-hand side until it
    becomes a literal function; then we reduce its right-hand
    side (the argument) until it is also a value; and finally we
    substitute the argument for the bound variable in the body of the
    function.  This last rule, written informally as
      (\x:T.t12) v2 ==> [x:=v2]t12
    is traditionally called "beta-reduction". *)

(**
                               value v2
                     ----------------------------                   (ST_AppAbs)
                     (\x:T.t12) v2 ==> [x:=v2]t12

                              t1 ==> t1'
                           ----------------                           (ST_App1)
                           t1 t2 ==> t1' t2

                              value v1
                              t2 ==> t2'
                           ----------------                           (ST_App2)
                           v1 t2 ==> v1 t2'
*)
(** ... plus the usual rules for booleans:
                    --------------------------------                (ST_IfTrue)
                    (if true then t1 else t2) ==> t1

                    ---------------------------------              (ST_IfFalse)
                    (if false then t1 else t2) ==> t2

                              t1 ==> t1'
         ----------------------------------------------------           (ST_If)
         (if t1 then t2 else t3) ==> (if t1' then t2 else t3)
*)

Reserved Notation "t1 '==>' t2" (at level 40).

Inductive step : tm -> tm -> Prop :=
  | ST_AppAbs : forall x T t12 v2,
         value v2 ->
         (tapp (tabs x T t12) v2) ==> [x:=v2]t12
  | ST_App1 : forall t1 t1' t2,
         t1 ==> t1' ->
         tapp t1 t2 ==> tapp t1' t2
  | ST_App2 : forall v1 t2 t2',
         value v1 ->
         t2 ==> t2' ->
         tapp v1 t2 ==> tapp v1  t2'
  | ST_IfTrue : forall t1 t2,
      (tif ttrue t1 t2) ==> t1
  | ST_IfFalse : forall t1 t2,
      (tif tfalse t1 t2) ==> t2
  | ST_If : forall t1 t1' t2 t3,
      t1 ==> t1' ->
      (tif t1 t2 t3) ==> (tif t1' t2 t3)

where "t1 '==>' t2" := (step t1 t2).

Hint Constructors step.

Notation multistep := (multi step).
Notation "t1 '==>*' t2" := (multistep t1 t2) (at level 40).

(* ##################################### *)

(* ##################################### *)
(** *** Examples *)

(** Example:
    ((\x:Bool->Bool. x) (\x:Bool. x)) ==>* (\x:Bool. x)
i.e.
    (idBB idB) ==>* idB
*)

Lemma step_example1 :
  (tapp idBB idB) ==>* idB.
Proof.
  eapply multi_step.
    apply ST_AppAbs.
    apply v_abs.
  simpl.
  apply multi_refl.  Qed.

(** Example:
((\x:Bool->Bool. x) ((\x:Bool->Bool. x) (\x:Bool. x)))
      ==>* (\x:Bool. x)
i.e.
  (idBB (idBB idB)) ==>* idB.
*)

Lemma step_example2 :
  (tapp idBB (tapp idBB idB)) ==>* idB.
Proof.
  eapply multi_step.
    apply ST_App2. auto.
    apply ST_AppAbs. auto.
  eapply multi_step.
    apply ST_AppAbs. simpl. auto.
  simpl. apply multi_refl.  Qed.

(** Example:
((\x:Bool->Bool. x) (\x:Bool. if x then false
                              else true)) true)
      ==>* false
i.e.
  ((idBB notB) ttrue) ==>* tfalse.
*)

Lemma step_example3 :
  tapp (tapp idBB notB) ttrue ==>* tfalse.
Proof.
  eapply multi_step.
    apply ST_App1. apply ST_AppAbs. auto. simpl.
  eapply multi_step.
    apply ST_AppAbs. auto. simpl.
  eapply multi_step.
    apply ST_IfTrue. apply multi_refl.  Qed.

(** Example:
((\x:Bool -> Bool. x) ((\x:Bool. if x then false
                               else true) true))
      ==>* false
i.e.
  (idBB (notB ttrue)) ==>* tfalse.
*)

Lemma step_example4 :
  tapp idBB (tapp notB ttrue) ==>* tfalse.
Proof.
  eapply multi_step.
    apply ST_App2. auto.
    apply ST_AppAbs. auto. simpl.
  eapply multi_step.
    apply ST_App2. auto.
    apply ST_IfTrue.
  eapply multi_step.
    apply ST_AppAbs. auto. simpl.
  apply multi_refl.  Qed.

(** A more automatic proof *)

Lemma step_example1' :
  (tapp idBB idB) ==>* idB.
Proof. normalize.  Qed.

(** Again, we can use the [normalize] tactic from above to simplify
    the proof. *)

Lemma step_example2' :
  (tapp idBB (tapp idBB idB)) ==>* idB.
Proof.
  normalize.
Qed.

Lemma step_example3' :
  tapp (tapp idBB notB) ttrue ==>* tfalse.
Proof. normalize.  Qed.

Lemma step_example4' :
  tapp idBB (tapp notB ttrue) ==>* tfalse.
Proof. normalize.  Qed.

(** **** Exercise: 2 stars (step_example3)  *)
(** Try to do this one both with and without [normalize]. *)

Lemma step_example5 :
       (tapp (tapp idBBBB idBB) idB)
  ==>* idB.
Proof.
  (* FILL IN HERE *) Admitted.

(* FILL IN HERE *)
(** [] *)

(* ###################################################################### *)
(** ** Typing *)

(* ################################### *)
(** *** Contexts *)

(** _Question_: What is the type of the term "[x y]"?

    _Answer_: It depends on the types of [x] and [y]!

    I.e., in order to assign a type to a term, we need to know
    what assumptions we should make about the types of its free
    variables.

    This leads us to a three-place "typing judgment", informally
    written [Gamma |- t \in T], where [Gamma] is a
    "typing context" -- a mapping from variables to their types. *)

(** Informally, we'll write [Gamma, x:T] for "extend the partial
    function [Gamma] to also map [x] to [T]."  Formally, we use the
    function [extend] to add a binding to a partial map. *)

Definition context := partial_map ty.

(* ################################### *)
(** *** Typing Relation *)

(**
                             Gamma x = T
                            --------------                              (T_Var)
                            Gamma |- x \in T

                      Gamma , x:T11 |- t12 \in T12
                     ----------------------------                       (T_Abs)
                     Gamma |- \x:T11.t12 \in T11->T12

                        Gamma |- t1 \in T11->T12
                          Gamma |- t2 \in T11
                        ----------------------                          (T_App)
                         Gamma |- t1 t2 \in T12

                         --------------------                          (T_True)
                         Gamma |- true \in Bool

                        ---------------------                         (T_False)
                        Gamma |- false \in Bool

       Gamma |- t1 \in Bool    Gamma |- t2 \in T    Gamma |- t3 \in T
       --------------------------------------------------------          (T_If)
                  Gamma |- if t1 then t2 else t3 \in T

    We can read the three-place relation [Gamma |- t \in T] as:
    "to the term [t] we can assign the type [T] using as types for
    the free variables of [t] the ones specified in the context
    [Gamma]." *)

Reserved Notation "Gamma '|-' t '\in' T" (at level 40).

Inductive has_type : context -> tm -> ty -> Prop :=
  | T_Var : forall Gamma x T,
      Gamma x = Some T ->
      Gamma |- tvar x \in T
  | T_Abs : forall Gamma x T11 T12 t12,
      update Gamma x T11 |- t12 \in T12 ->
      Gamma |- tabs x T11 t12 \in TArrow T11 T12
  | T_App : forall T11 T12 Gamma t1 t2,
      Gamma |- t1 \in TArrow T11 T12 ->
      Gamma |- t2 \in T11 ->
      Gamma |- tapp t1 t2 \in T12
  | T_True : forall Gamma,
       Gamma |- ttrue \in TBool
  | T_False : forall Gamma,
       Gamma |- tfalse \in TBool
  | T_If : forall t1 t2 t3 T Gamma,
       Gamma |- t1 \in TBool ->
       Gamma |- t2 \in T ->
       Gamma |- t3 \in T ->
       Gamma |- tif t1 t2 t3 \in T

where "Gamma '|-' t '\in' T" := (has_type Gamma t T).

Hint Constructors has_type.

(* ################################### *)
(** *** Examples *)

Example typing_example_1 :
  empty |- tabs x TBool (tvar x) \in TArrow TBool TBool.
Proof.
  apply T_Abs. apply T_Var. reflexivity.  Qed.

(** Note that since we added the [has_type] constructors to the hints
    database, auto can actually solve this one immediately. *)

Example typing_example_1' :
  empty |- tabs x TBool (tvar x) \in TArrow TBool TBool.
Proof. auto.  Qed.

(** Another example:
     empty |- \x:A. \y:A->A. y (y x))
           \in A -> (A->A) -> A.
*)

Example typing_example_2 :
  empty |-
    (tabs x TBool
       (tabs y (TArrow TBool TBool)
          (tapp (tvar y) (tapp (tvar y) (tvar x))))) \in
    (TArrow TBool (TArrow (TArrow TBool TBool) TBool)).
Proof with auto using update_eq.
  apply T_Abs.
  apply T_Abs.
  eapply T_App. apply T_Var...
  eapply T_App. apply T_Var...
  apply T_Var...
Qed.

(** **** Exercise: 2 stars, optional (typing_example_2_full)  *)
(** Prove the same result without using [auto], [eauto], or
    [eapply]. *)

Example typing_example_2_full :
  empty |-
    (tabs x TBool
       (tabs y (TArrow TBool TBool)
          (tapp (tvar y) (tapp (tvar y) (tvar x))))) \in
    (TArrow TBool (TArrow (TArrow TBool TBool) TBool)).
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 2 stars (typing_example_3)  *)
(** Formally prove the following typing derivation holds: *)
(**
   empty |- \x:Bool->B. \y:Bool->Bool. \z:Bool.
               y (x z)
         \in T.
*)

Example typing_example_3 :
  exists T,
    empty |-
      (tabs x (TArrow TBool TBool)
         (tabs y (TArrow TBool TBool)
            (tabs z TBool
               (tapp (tvar y) (tapp (tvar x) (tvar z)))))) \in
      T.
Proof with auto.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** We can also show that terms are _not_ typable.  For example, let's
    formally check that there is no typing derivation assigning a type
    to the term [\x:Bool. \y:Bool, x y] -- i.e.,
    ~ exists T,
        empty |- \x:Bool. \y:Bool, x y : T.
*)

Example typing_nonexample_1 :
  ~ exists T,
      empty |-
        (tabs x TBool
            (tabs y TBool
               (tapp (tvar x) (tvar y)))) \in
        T.
Proof.
  intros Hc. inversion Hc.
  (* The [clear] tactic is useful here for tidying away bits of
     the context that we're not going to need again. *)
  inversion H. subst. clear H.
  inversion H5. subst. clear H5.
  inversion H4. subst. clear H4.
  inversion H2. subst. clear H2.
  inversion H5. subst. clear H5.
  inversion H1.  Qed.

(** **** Exercise: 3 stars, optional (typing_nonexample_3)  *)
(** Another nonexample:
    ~ (exists S, exists T,
          empty |- \x:S. x x : T).
*)

Example typing_nonexample_3 :
  ~ (exists S, exists T,
        empty |-
          (tabs x S
             (tapp (tvar x) (tvar x))) \in
          T).
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

End STLC.

(** $Date: 2016-02-04 21:50:25 +0000 (Thu, 04 Feb 2016) $ *)


Require Import List.
Import ListNotations.

Definition option_bind {A B} (m : option A) (f : A -> option B) : option B :=
  match m with
  | Some a => f a
  | None => None
  end.

Definition option_seq {A B} (f : option (A -> B)) (x : option A) : option B :=
  option_bind f (fun f => option_bind x (fun x => Some (f x))).

Fixpoint sequence {A} (l : list (option A)) : option (list A) :=
  match l with
  | [] => Some []
  | a :: l => match a with
             | Some a => match sequence l with
                        | Some l => Some (a :: l)
                        | None => None
                        end
             | None => None
             end
  end.

Lemma sequence_map_Some :
  forall A (l : list A),
    sequence (map (@Some _) l) = Some l.
Proof.
  induction l; simpl; auto.
  now rewrite IHl.
Qed.

Ltac unfold_option :=
  unfold sequence, option_seq, option_bind, option_map in *.

Module OptionNotations.
  Notation "f <$> o" := (@option_map _ _ f o) (at level 42, left associativity) : option.
  Notation "f <*> x" := (@option_seq _ _ f x) (at level 42, left associativity) : option.
  Notation "m >>= f" := (@option_bind _ _ m f) (at level 42, left associativity) : option.
  Open Scope option.
End OptionNotations.