(* Copyright © 1998-2006
 * Henk Barendregt
 * Luís Cruz-Filipe
 * Herman Geuvers
 * Mariusz Giero
 * Rik van Ginneken
 * Dimitri Hendriks
 * Sébastien Hinderer
 * Bart Kirkels
 * Pierre Letouzey
 * Iris Loeb
 * Lionel Mamane
 * Milad Niqui
 * Russell O’Connor
 * Randy Pollack
 * Nickolay V. Shmyrev
 * Bas Spitters
 * Dan Synek
 * Freek Wiedijk
 * Jan Zwanenburg
 *
 * This work is free software; you can redistribute it and/or modify
 * it under the terms of the GNU General Public License as published by
 * the Free Software Foundation; either version 2 of the License, or
 * (at your option) any later version.
 *
 * This work is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License along
 * with this work; if not, write to the Free Software Foundation, Inc.,
 * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
 *)

Require Export CoRN.ftc.Rolle.
Require Export CoRN.tactics.DiffTactics3.

Opaque Min Max.

Section Various_Theorems.

(**
* Calculus Theorems

This file is intended to present a collection of miscellaneous, mostly
technical results in differential calculus that are interesting or
useful in future work.

We begin with some properties of continuous functions.  Every
continuous function commutes with the limit of a numerical sequence
(sometimes called Heine continuity).
*)

Lemma Continuous_imp_comm_Lim : forall F x e, [0] [<] e ->
 Continuous (clcr (Lim x[-]e) (Lim x[+]e)) F -> forall Hx Hxn H,
 F (Lim x) Hx [=] Lim (Build_CauchySeq IR (fun n => F (x n) (Hxn n)) H).
Proof.
 intros F x e H H0 Hx Hxn H1.
 set (a := Lim x) in *.
 set (I := clcr (a[-]e) (a[+]e)) in *.
 cut (compact_ I). intro H2.
  2: simpl in |- *.
  2: apply less_leEq; apply less_transitive_unfolded with a.
   2: apply shift_minus_less; apply shift_less_plus'.
   2: astepl ZeroR; auto.
  2: apply shift_less_plus'.
  2: astepl ZeroR; auto.
 apply Limits_unique.
 simpl in |- *.
 intros eps H3.
 set (H2' := H2) in *.
 cut (Continuous_I (a:=Lend H2) (b:=Rend H2) H2' F). intro H4.
  2: apply Int_Continuous; auto.
 elim (contin_prop _ _ _ _ H4 _ H3); intros d H5 H6.
 elim (Cauchy_complete x (Min d e)).
  2: apply less_Min; auto.
 intros N HN.
 exists N; intros.
 fold a in HN.
 apply AbsIR_imp_AbsSmall.
 elim (HN m H7); intros.
 apply H6.
   split; simpl in |- *.
    unfold cg_minus in |- *; apply shift_plus_leEq'.
    eapply leEq_transitive.
     2: apply H8.
    apply inv_resp_leEq; apply Min_leEq_rht.
   apply shift_leEq_plus'.
   eapply leEq_transitive.
    apply H9.
   apply Min_leEq_rht.
  split; simpl in |- *.
   apply shift_minus_leEq; apply shift_leEq_plus'.
   astepl ZeroR; apply less_leEq; auto.
  apply shift_leEq_plus'; astepl ZeroR.
  apply less_leEq; auto.
 apply AbsSmall_imp_AbsIR.
 apply AbsSmall_leEq_trans with (Min d e).
  apply Min_leEq_lft.
 auto.
Qed.

(**
This is a tricky result: if [F] is continuous and positive in both [[a,b]]
and [(b,c]], then it is positive in [[a,c]].
*)

Lemma Continuous_imp_pos : forall a b c (Hac : a [<=] c), a [<=] b -> b [<] c ->
 forall F, Continuous_I Hac F -> (forall t, a [<=] t -> t [<=] b -> forall Ht, [0] [<] F t Ht) ->
 (forall t, b [<] t -> t [<=] c -> forall Ht, [0] [<] F t Ht) -> forall t, a [<=] t -> t [<=] c -> forall Ht, [0] [<] F t Ht.
Proof.
 intros a b c Hac H H0 F H1 H2 H3 t H4 H5 Ht.
 elim H1; intros H6 H7; clear H1.
 cut (Compact Hac b); [ intro H1 | split; auto ].
  2: apply less_leEq; auto.
 set (e := F b (H6 _ H1) [/]TwoNZ) in *.
 cut ([0] [<] e); intros.
  2: unfold e in |- *; apply pos_div_two; apply H2; auto.
  2: apply leEq_reflexive.
 elim H7 with e; auto.
 intros d H9 H10.
 cut (b[-]d [<] b).
  2: apply shift_minus_less; apply shift_less_plus'.
  2: astepl ZeroR; auto.
 intro H11.
 elim (less_cotransitive_unfolded _ _ _ H11 t); intro.
  clear H11.
  elim (less_cotransitive_unfolded _ _ _ H9 (t[-]b)); intro.
   apply H3.
    astepl ([0][+]b); apply shift_plus_less; auto.
   auto.
  apply cont_no_sign_change_pos with (Hab := Hac) (e := e) (Hx := H6 _ H1); auto.
     split; auto.
    apply H10; auto.
     split; auto.
    apply AbsSmall_imp_AbsIR.
    apply AbsIR_eq_AbsSmall.
     rstepr ( [--] (t[-]b)); apply inv_resp_leEq.
     apply less_leEq; auto.
    apply less_leEq; apply shift_minus_less; apply shift_less_plus'; auto.
   unfold e in |- *.
   eapply less_leEq_trans.
    apply pos_div_two'.
    apply H2; auto.
    apply leEq_reflexive.
   apply leEq_AbsIR.
  unfold e in |- *.
  apply pos_div_two'.
  apply H2; auto.
  apply leEq_reflexive.
 apply H2; auto.
 apply less_leEq; auto.
Qed.

(**
Similar results for increasing functions:
*)

Lemma strict_inc_glues : forall a b c F (Hab : a [<=] b) (Hbc : b [<=] c) (Hac : a [<=] c),
 included (Compact Hac) (Dom F) ->
 (forall x y, Compact Hab x -> Compact Hab y -> x [<] y -> forall Hx Hy, F x Hx [<] F y Hy) ->
 (forall x y, Compact Hbc x -> Compact Hbc y -> x [<] y -> forall Hx Hy, F x Hx [<] F y Hy) ->
 forall x y, Compact Hac x -> Compact Hac y -> x [<] y -> forall Hx Hy, F x Hx [<] F y Hy.
Proof.
 do 7 intro. intros H H0 H1 x y H2 H3 H4 Hx Hy.
 cut (Dom F a); [ intro Ha | apply H; apply compact_inc_lft ].
 cut (Dom F b); [ intro Hb | apply H; split; auto ].
 cut (Dom F c); [ intro Hc | apply H; apply compact_inc_rht ].
 elim (less_cotransitive_unfolded _ _ _ H4 b); intro.
  cut (Dom F (Min b y)); [ intro H5 | apply H; split ].
    2: apply leEq_Min; auto; elim H3; auto.
   2: eapply leEq_transitive; [ apply Min_leEq_lft | auto ].
  apply less_leEq_trans with (F _ H5).
   cut (Dom F (Min ((x[+]b) [/]TwoNZ) y)); [ intro Hxy | apply H; split ].
     3: elim H3; intros; eapply leEq_transitive; [ apply Min_leEq_rht | auto ].
    2: apply leEq_Min.
     3: elim H3; auto.
    2: apply shift_leEq_div; [ apply pos_two | rstepl (a[+]a) ].
    2: apply plus_resp_leEq_both; elim H2; auto.
   apply less_leEq_trans with (F _ Hxy).
    apply H0; try split.
        elim H2; auto.
       apply less_leEq; auto.
      apply leEq_Min.
       2: elim H3; auto.
      apply shift_leEq_div; [ apply pos_two | rstepl (a[+]a) ].
      apply plus_resp_leEq_both; elim H2; auto.
     eapply leEq_transitive.
      apply Min_leEq_lft.
     apply shift_div_leEq; [ apply pos_two | rstepr (b[+]b) ].
     apply plus_resp_leEq; apply less_leEq; auto.
    apply less_Min; auto.
    apply shift_less_div; [ apply pos_two | rstepl (x[+]x) ].
    apply plus_resp_leEq_less; [ apply leEq_reflexive | auto ].
   apply part_mon_imp_mon' with (Compact Hab); auto.
      intros x0 H6; apply H; inversion_clear H6; split; auto.
      apply leEq_transitive with b; auto.
     split.
      apply leEq_Min.
       apply shift_leEq_div; [ apply pos_two | rstepl (a[+]a) ].
       apply plus_resp_leEq_both; auto; elim H2; auto.
      elim H3; auto.
     eapply leEq_transitive.
      apply Min_leEq_lft.
     apply shift_div_leEq; [ apply pos_two | rstepr (b[+]b) ].
     apply plus_resp_leEq; apply less_leEq; auto.
    split.
     apply leEq_Min; auto; elim H3; auto.
    apply Min_leEq_lft.
   apply leEq_Min.
    eapply leEq_transitive.
     apply Min_leEq_lft.
    apply shift_div_leEq; [ apply pos_two | rstepr (b[+]b) ].
    apply plus_resp_leEq; apply less_leEq; auto.
   apply Min_leEq_rht.
  rewrite -> leEq_def; intro H6.
  cut (y [<=] b). intro H7.
   apply (less_irreflexive_unfolded _ (F y Hy)).
   eapply less_wdr.
    apply H6.
   apply pfwdef; eapply eq_transitive_unfolded.
    apply Min_comm.
   apply leEq_imp_Min_is_lft; auto.
  rewrite -> leEq_def; intro H7.
  apply (less_irreflexive_unfolded _ (F y Hy)).
  eapply less_transitive_unfolded.
   apply H6.
  apply less_wdl with (F b Hb).
   2: apply pfwdef; apply eq_symmetric_unfolded; apply leEq_imp_Min_is_lft; apply less_leEq; auto.
  apply H1; auto.
   apply compact_inc_lft.
  split; [ apply less_leEq | elim H3 ]; auto.
 cut (Dom F (Max b x)); [ intro H5 | apply H; split ].
   3: apply Max_leEq; auto; elim H2; auto.
  2: eapply leEq_transitive; [ apply Hab | apply lft_leEq_Max ].
 apply leEq_less_trans with (F _ H5).
  2: cut (Dom F (Max ((y[+]b) [/]TwoNZ) x)); [ intro Hxy | apply H; split ].
    3: elim H2; intros; eapply leEq_transitive; [ apply a0 | apply rht_leEq_Max ].
   3: apply Max_leEq.
    4: elim H2; auto.
   3: apply shift_div_leEq; [ apply pos_two | rstepr (c[+]c) ].
   3: apply plus_resp_leEq_both; elim H3; auto.
  2: apply leEq_less_trans with (F _ Hxy).
   3: apply H1; try split.
       6: elim H3; auto.
      5: apply less_leEq; auto.
     4: apply Max_leEq.
      5: elim H2; auto.
     4: apply shift_div_leEq; [ apply pos_two | rstepr (c[+]c) ].
     4: apply plus_resp_leEq_both; elim H3; auto.
    3: eapply leEq_transitive.
     4: apply lft_leEq_Max.
    3: apply shift_leEq_div; [ apply pos_two | rstepl (b[+]b) ].
    3: apply plus_resp_leEq; apply less_leEq; auto.
   3: apply Max_less; auto.
   3: apply shift_div_less; [ apply pos_two | rstepr (y[+]y) ].
   3: apply plus_resp_less_lft; auto.
  2: apply part_mon_imp_mon' with (Compact Hbc); auto.
     2: intros x0 H6; apply H; inversion_clear H6; split; auto.
     2: apply leEq_transitive with b; auto.
    3: split.
     4: apply Max_leEq.
      4: apply shift_div_leEq; [ apply pos_two | rstepr (c[+]c) ].
      4: apply plus_resp_leEq_both; auto; elim H3; auto.
     4: elim H2; auto.
    3: eapply leEq_transitive.
     4: apply lft_leEq_Max.
    3: apply shift_leEq_div; [ apply pos_two | rstepl (b[+]b) ].
    3: apply plus_resp_leEq; apply less_leEq; auto.
   2: split.
    3: apply Max_leEq; auto; elim H2; auto.
   2: apply lft_leEq_Max.
  2: apply Max_leEq.
   2: eapply leEq_transitive.
    3: apply lft_leEq_Max.
   2: apply shift_leEq_div; [ apply pos_two | rstepl (b[+]b) ].
   2: apply plus_resp_leEq; apply less_leEq; auto.
  2: apply rht_leEq_Max.
 rewrite -> leEq_def; intro H6.
 cut (b [<=] x); rewrite -> leEq_def; intro H7.
  apply (less_irreflexive_unfolded _ (F x Hx)).
  eapply less_wdl.
   apply H6.
  apply pfwdef; apply leEq_imp_Max_is_rht; rewrite -> leEq_def; auto.
 apply (less_irreflexive_unfolded _ (F x Hx)).
 eapply less_transitive_unfolded.
  2: apply H6.
 apply less_wdr with (F b Hb).
  2: apply pfwdef; apply eq_symmetric_unfolded; eapply eq_transitive_unfolded.
   2: apply Max_comm.
  2: apply leEq_imp_Max_is_rht; apply less_leEq; auto.
 apply H0; auto.
  2: apply compact_inc_rht.
 split; [ elim H2 | apply less_leEq ]; auto.
Qed.

Lemma strict_inc_glues' : forall a b c F, a [<] b -> b [<] c -> included (olor a c) (Dom F) ->
 (forall x y, olcr a b x -> olcr a b y -> x [<] y -> forall Hx Hy, F x Hx [<] F y Hy) ->
 (forall x y, clor b c x -> clor b c y -> x [<] y -> forall Hx Hy, F x Hx [<] F y Hy) ->
 forall x y, olor a c x -> olor a c y -> x [<] y -> forall Hx Hy, F x Hx [<] F y Hy.
Proof.
 intros a b c F Hab Hbc H H0 H1 x y H2 H3 H4 Hx Hy.
 cut (Dom F b); [ intro Hb | apply H; split; auto ].
 elim (less_cotransitive_unfolded _ _ _ H4 b); intro.
  cut (Dom F (Min b y)); [ intro H5 | apply H; split ].
    2: apply less_Min; auto; elim H3; auto.
   2: eapply leEq_less_trans; [ apply Min_leEq_lft | auto ].
  apply less_leEq_trans with (F _ H5).
   cut (Dom F (Min ((x[+]b) [/]TwoNZ) y)); [ intro Hxy | apply H; split ].
     3: elim H3; intros; eapply leEq_less_trans; [ apply Min_leEq_rht | auto ].
    2: apply less_Min.
     3: elim H3; auto.
    2: apply shift_less_div; [ apply pos_two | rstepl (a[+]a) ].
    2: apply plus_resp_less_both; elim H2; auto.
   apply less_leEq_trans with (F _ Hxy).
    apply H0; try split.
        elim H2; auto.
       apply less_leEq; auto.
      apply less_Min.
       2: elim H3; auto.
      apply shift_less_div; [ apply pos_two | rstepl (a[+]a) ].
      apply plus_resp_less_both; elim H2; auto.
     eapply leEq_transitive.
      apply Min_leEq_lft.
     apply shift_div_leEq; [ apply pos_two | rstepr (b[+]b) ].
     apply plus_resp_leEq; apply less_leEq; auto.
    apply less_Min; auto.
    apply shift_less_div; [ apply pos_two | rstepl (x[+]x) ].
    apply plus_resp_leEq_less; [ apply leEq_reflexive | auto ].
   apply part_mon_imp_mon' with (iprop (olcr a b)); auto.
      intros x0 H6; apply H; inversion_clear H6; split; auto.
      apply leEq_less_trans with b; auto.
     split.
      apply less_Min.
       apply shift_less_div; [ apply pos_two | rstepl (a[+]a) ].
       apply plus_resp_less_both; auto; elim H2; auto.
      elim H3; auto.
     eapply leEq_transitive.
      apply Min_leEq_lft.
     apply shift_div_leEq; [ apply pos_two | rstepr (b[+]b) ].
     apply plus_resp_leEq; apply less_leEq; auto.
    split.
     apply less_Min; auto; elim H3; auto.
    apply Min_leEq_lft.
   apply leEq_Min.
    eapply leEq_transitive.
     apply Min_leEq_lft.
    apply shift_div_leEq; [ apply pos_two | rstepr (b[+]b) ].
    apply plus_resp_leEq; apply less_leEq; auto.
   apply Min_leEq_rht.
  rewrite -> leEq_def; intro H6.
  cut (y [<=] b); rewrite -> leEq_def; intro H7.
   apply (less_irreflexive_unfolded _ (F y Hy)).
   eapply less_wdr.
    apply H6.
   apply pfwdef; eapply eq_transitive_unfolded.
    apply Min_comm.
   apply leEq_imp_Min_is_lft; rewrite -> leEq_def; auto.
  apply (less_irreflexive_unfolded _ (F y Hy)).
  eapply less_transitive_unfolded.
   apply H6.
  apply less_wdl with (F b Hb).
   2: apply pfwdef; apply eq_symmetric_unfolded; apply leEq_imp_Min_is_lft; apply less_leEq; auto.
  apply H1; auto.
   split; auto; apply leEq_reflexive.
  split; [ apply less_leEq | elim H3 ]; auto.
 cut (Dom F (Max b x)); [ intro H5 | apply H; split ].
   3: apply Max_less; auto; elim H2; auto.
  2: eapply less_leEq_trans; [ apply Hab | apply lft_leEq_Max ].
 apply leEq_less_trans with (F _ H5).
  2: cut (Dom F (Max ((y[+]b) [/]TwoNZ) x)); [ intro Hxy | apply H; split ].
    3: elim H2; intros; eapply less_leEq_trans; [ apply a0 | apply rht_leEq_Max ].
   3: apply Max_less.
    4: elim H2; auto.
   3: apply shift_div_less; [ apply pos_two | rstepr (c[+]c) ].
   3: apply plus_resp_less_both; elim H3; auto.
  2: apply leEq_less_trans with (F _ Hxy).
   3: apply H1; try split.
       6: elim H3; auto.
      5: apply less_leEq; auto.
     4: apply Max_less.
      5: elim H2; auto.
     4: apply shift_div_less; [ apply pos_two | rstepr (c[+]c) ].
     4: apply plus_resp_less_both; elim H3; auto.
    3: eapply leEq_transitive.
     4: apply lft_leEq_Max.
    3: apply shift_leEq_div; [ apply pos_two | rstepl (b[+]b) ].
    3: apply plus_resp_leEq; apply less_leEq; auto.
   3: apply Max_less; auto.
   3: apply shift_div_less; [ apply pos_two | rstepr (y[+]y) ].
   3: apply plus_resp_less_lft; auto.
  2: apply part_mon_imp_mon' with (iprop (clor b c)); auto.
     2: intros x0 H6; apply H; inversion_clear H6; split; auto.
     2: apply less_leEq_trans with b; auto.
    3: split.
     4: apply Max_less.
      4: apply shift_div_less; [ apply pos_two | rstepr (c[+]c) ].
      4: apply plus_resp_less_both; auto; elim H3; auto.
     4: elim H2; auto.
    3: eapply leEq_transitive.
     4: apply lft_leEq_Max.
    3: apply shift_leEq_div; [ apply pos_two | rstepl (b[+]b) ].
    3: apply plus_resp_leEq; apply less_leEq; auto.
   2: split.
    3: apply Max_less; auto; elim H2; auto.
   2: apply lft_leEq_Max.
  2: apply Max_leEq.
   2: eapply leEq_transitive.
    3: apply lft_leEq_Max.
   2: apply shift_leEq_div; [ apply pos_two | rstepl (b[+]b) ].
   2: apply plus_resp_leEq; apply less_leEq; auto.
  2: apply rht_leEq_Max.
 rewrite -> leEq_def; intro H6.
 cut (b [<=] x); rewrite -> leEq_def; intro H7.
  apply (less_irreflexive_unfolded _ (F x Hx)).
  eapply less_wdl.
   apply H6.
  apply pfwdef; apply leEq_imp_Max_is_rht; rewrite -> leEq_def; auto.
 apply (less_irreflexive_unfolded _ (F x Hx)).
 eapply less_transitive_unfolded.
  2: apply H6.
 apply less_wdr with (F b Hb).
  2: apply pfwdef; apply eq_symmetric_unfolded; eapply eq_transitive_unfolded.
   2: apply Max_comm.
  2: apply leEq_imp_Max_is_rht; apply less_leEq; auto.
 apply H0; auto.
  split; [ elim H2 | apply less_leEq ]; auto.
 split; auto; apply leEq_reflexive.
Qed.

Lemma strict_dec_glues : forall a b c F (Hab : a [<=] b) (Hbc : b [<=] c) (Hac : a [<=] c),
 included (Compact Hac) (Dom F) ->
 (forall x y, Compact Hab x -> Compact Hab y -> y[<]x -> forall Hx Hy, F x Hx [<] F y Hy) ->
 (forall x y, Compact Hbc x -> Compact Hbc y -> y[<]x -> forall Hx Hy, F x Hx [<] F y Hy) ->
 forall x y, Compact Hac x -> Compact Hac y -> y[<]x -> forall Hx Hy, F x Hx [<] F y Hy.
Proof.
 intros.
 apply inv_cancel_less.
 astepl ( {--}F y Hy); astepr ( {--}F x Hx).
 apply strict_inc_glues with a b c Hab Hbc Hac; auto.
  intros; simpl in |- *; apply inv_resp_less; auto.
 intros; simpl in |- *; apply inv_resp_less; auto.
Qed.

Lemma strict_dec_glues' : forall a b c F, a [<] b -> b [<] c -> included (olor a c) (Dom F) ->
 (forall x y, olcr a b x -> olcr a b y -> y[<]x -> forall Hx Hy, F x Hx [<] F y Hy) ->
 (forall x y, clor b c x -> clor b c y -> y[<]x -> forall Hx Hy, F x Hx [<] F y Hy) ->
 forall x y, olor a c x -> olor a c y -> y[<]x -> forall Hx Hy, F x Hx [<] F y Hy.
Proof.
 intros.
 apply inv_cancel_less.
 astepl ( {--}F y Hy); astepr ( {--}F x Hx).
 apply strict_inc_glues' with a b c; auto.
  intros; simpl in |- *; apply inv_resp_less; auto.
 intros; simpl in |- *; apply inv_resp_less; auto.
Qed.

(** More on glueing intervals. *)

Lemma olor_pos_clor_nonneg : forall a b (F : PartIR),
 (forall x, olor a b x -> forall Hx, [0] [<] F x Hx) -> forall Ha,
 [0] [<=] F a Ha -> forall x, clor a b x -> forall Hx, [0] [<=] F x Hx.
Proof.
 intros a b F H Ha H0 x H1 Hx.
 rewrite -> leEq_def; intros H2.
 cut (Not (olor a b x)); intro H3.
  cut (x [=] a). intro H4.
   rewrite -> leEq_def in H0; apply H0.
   eapply less_wdl; [ apply H2 | algebra ].
  red in H3.
  apply not_ap_imp_eq; intro H4.
  inversion_clear H1.
  elim (ap_imp_less _ _ _ H4); intros.
   apply (less_irreflexive_unfolded _ a); apply leEq_less_trans with x; auto.
  apply H3; split; auto.
 apply (less_irreflexive_unfolded IR [0]); apply less_transitive_unfolded with (F x Hx); auto.
Qed.

Lemma olor_pos_olcr_nonneg : forall a b (F : PartIR),
 (forall x, olor a b x -> forall Hx, [0] [<] F x Hx) -> forall Hb,
 [0] [<=] F b Hb -> forall x, olcr a b x -> forall Hx, [0] [<=] F x Hx.
Proof.
 intros a b F H Ha H0 x H1 Hx.
 rewrite -> leEq_def; intros H2.
 cut (Not (olor a b x)); intro H3.
  cut (x [=] b). intro H4.
   rewrite -> leEq_def in H0; apply H0.
   eapply less_wdl; [ apply H2 | algebra ].
  red in H3.
  apply not_ap_imp_eq; intro H4.
  inversion_clear H1.
  elim (ap_imp_less _ _ _ H4); intros.
   apply H3; split; auto.
  apply (less_irreflexive_unfolded _ b); apply less_leEq_trans with x; auto.
 apply (less_irreflexive_unfolded IR [0]); apply less_transitive_unfolded with (F x Hx); auto.
Qed.

Lemma olor_pos_clcr_nonneg : forall a b (F : PartIR), a [<] b ->
 (forall x, olor a b x -> forall Hx, [0] [<] F x Hx) -> forall Ha, [0] [<=] F a Ha -> forall Hb, [0] [<=] F b Hb ->
 forall x, clcr a b x -> forall Hx, [0] [<=] F x Hx.
Proof.
 intros a b F Hab H Ha H0 Hb H1 x H2 Hx.
 rewrite -> leEq_def; intros H3.
 cut (Not (olor a b x)); intro H4.
  elim (less_cotransitive_unfolded _ _ _ Hab x); intro H5.
   cut (x [=] b). intro H6.
    rewrite -> leEq_def in H1; apply H1.
    eapply less_wdl; [ apply H3 | algebra ].
   red in H4.
   apply not_ap_imp_eq; intro H6.
   inversion_clear H2.
   elim (ap_imp_less _ _ _ H6); intros.
    apply H4; split; auto.
   apply (less_irreflexive_unfolded _ b); apply less_leEq_trans with x; auto.
  cut (x [=] a); intros.
   rewrite -> leEq_def in H0; apply H0.
   eapply less_wdl; [ apply H3 | algebra ].
  red in H4.
  apply not_ap_imp_eq; intro.
  inversion_clear H2.
  elim (ap_imp_less _ _ _ X); intros.
   apply (less_irreflexive_unfolded _ a); apply leEq_less_trans with x; auto.
  apply H4; split; auto.
 apply (less_irreflexive_unfolded IR [0]); apply less_transitive_unfolded with (F x Hx); auto.
Qed.

(**
Any function that has the null function as its derivative must be constant.
*)

Lemma FConst_prop : forall J pJ F', Derivative J pJ F' [-C-][0] -> {c : IR | Feq J F' [-C-]c}.
Proof.
 intros J pJ F' H.
 elim (nonvoid_point _ (proper_nonvoid _ pJ)); intros x0 Hx0.
 exists (F' x0 (Derivative_imp_inc _ _ _ _ H x0 Hx0)).
 FEQ. rename X into H0.
 simpl in |- *.
 apply cg_inv_unique_2.
 apply AbsIR_approach_zero; intros e H1.
 simpl in Hx'.
 elim (Law_of_the_Mean _ _ _ _ H _ _ Hx0 H0 e H1).
 intros y H2 H3.
 eapply leEq_wdl.
  apply (H3 (Derivative_imp_inc _ _ _ _ H _ Hx0) Hx I).
 apply AbsIR_wd; simpl in |- *; rational.
Qed.

(** As a corollary, two functions with the same derivative must differ
by a constant.
*)

Lemma Feq_crit_with_const : forall J pJ F G H,
 Derivative J pJ F H -> Derivative J pJ G H -> {c : IR | Feq J (F{-}G) [-C-]c}.
Proof.
 intros.
 apply FConst_prop with pJ.
 Derivative_Help; FEQ.
Qed.

(** This yields the following known result: any differential equation
of the form [f'=g] with initial condition [f(a) [=] b] has a unique solution.
*)

Lemma Feq_criterium : forall J pJ F G H, Derivative J pJ F H -> Derivative J pJ G H ->
 forall x, J x -> (forall Hx Hx', F x Hx [=] G x Hx') -> Feq J F G.
Proof.
 do 5 intro. intros H0 H1 x H2 H3.
 elim (Feq_crit_with_const _ _ _ _ _ H0 H1); intros c Hc.
 apply Feq_transitive with (F{-}G{+}G).
  FEQ.
 apply Feq_transitive with ( [-C-][0]{+}G).
  2: FEQ.
 apply Feq_plus.
  2: apply Feq_reflexive; Included.
 apply Feq_transitive with ( [-C-]c).
  auto.
 FEQ. rename X into H4.
 simpl in |- *.
 elim Hc; intros H5 H6.
 elim H6; clear H6; intros H7 H6.
 clear Hc H5 H7 Hx' Hx.
 simpl in H6.
 cut (Conj (Dom F) (Dom G) x). intro H5.
  apply eq_symmetric_unfolded; eapply eq_transitive_unfolded.
   2: apply H6 with (Hx := H5); auto.
  apply eq_symmetric_unfolded; apply x_minus_x; auto.
 split.
  exact (Derivative_imp_inc _ _ _ _ H0 _ H2).
 exact (Derivative_imp_inc _ _ _ _ H1 _ H2).
Qed.

(**
Finally, a well known result: any function with a (strictly) positive
derivative is (strictly) increasing.  Although the two lemmas look
quite similar the proofs are completely different, both from the
formalization and from the mathematical point of view.
*)

Lemma Derivative_imp_resp_less : forall J pJ a b F F', Derivative J pJ F F' ->
 a [<] b -> J a -> J b -> (forall contF', [0] [<] glb_funct _ _ (Min_leEq_Max a b) F' contF') ->
 forall Ha Hb, F a Ha [<] F b Hb.
Proof.
 intros J pJ a b F F' derF Hab HaJ HbJ Hglb Ha Hb.
 apply shift_zero_less_minus'.
 cut (Continuous_I (Min_leEq_Max a b) F'). intro H.
  2: apply included_imp_Continuous with J;
    [ apply Derivative_imp_Continuous' with pJ F | apply included_interval ]; auto.
 elim (glb_is_glb _ _ _ _ H).
 simpl in |- *; intros Hglb1 Hglb2.
 cut ([0] [<] glb_funct _ _ _ _ H); [ intro H0 | auto ].
 elim (Law_of_the_Mean _ _ _ _ derF a b) with (e := (glb_funct _ _ _ _ H[*] (b[-]a)) [/]TwoNZ); auto.
  intros x H1 H2.
  apply less_leEq_trans with (F' x (contin_imp_inc _ _ _ _ H x H1) [*] (b[-]a) [-]
    (glb_funct _ _ _ _ H[*] (b[-]a)) [/]TwoNZ).
   rstepr ((F' x (contin_imp_inc _ _ _ _ H x H1) [-]glb_funct _ _ _ _ H [/]TwoNZ) [*] (b[-]a)).
   apply mult_resp_pos.
    apply shift_less_minus; astepl (glb_funct _ _ _ _ H [/]TwoNZ).
    eapply less_leEq_trans.
     apply pos_div_two'; auto.
    apply glb_prop.
    auto.
   apply shift_less_minus; astepl a; auto.
  apply shift_minus_leEq; apply shift_leEq_plus'.
  rstepl ( [--] (Part _ _ Hb[-]Part _ _ Ha[-] Part _ _ (contin_imp_inc _ _ _ _ H _ H1) [*] (b[-]a))).
  eapply leEq_transitive.
   apply inv_leEq_AbsIR.
  apply H2.
 apply pos_div_two; apply mult_resp_pos; auto.
 apply shift_less_minus; astepl a; auto.
Qed.

Lemma Derivative_imp_resp_leEq : forall J pJ a b F F', Derivative J pJ F F' ->
 a [<=] b -> J a -> J b -> (forall contF', [0] [<=] glb_funct _ _ (Min_leEq_Max b a) F' contF') ->
 forall Ha Hb, F a Ha [<=] F b Hb.
Proof.
 intros J pJ a b F F' derF Hab HaJ HbJ Hglb Ha Hb.
 astepr ([0][+]Part _ _ Hb); apply shift_leEq_plus.
 cut (Continuous_I (Min_leEq_Max b a) F'). intro H.
  2: apply included_imp_Continuous with J;
    [ apply Derivative_imp_Continuous' with pJ F | apply included_interval ]; auto.
 elim (glb_is_glb _ _ _ _ H).
 simpl in |- *; intros Hglb1 Hglb2.
 cut ([0] [<=] glb_funct _ _ _ _ H); [ intro H0 | auto ].
 apply approach_zero_weak.
 intros.
 elim (Law_of_the_Mean _ _ _ _ derF b a) with (e := e); auto.
 intros x H2 H3.
 eapply leEq_transitive.
  2: apply (H3 Hb Ha (contin_imp_inc _ _ _ _ H x H2)).
 eapply leEq_transitive.
  2: apply leEq_AbsIR.
 rstepl (Part _ _ Ha[-]Part _ _ Hb[-][--][0]).
 unfold cg_minus at 1 3 in |- *; apply plus_resp_leEq_lft.
 apply inv_resp_leEq.
 rstepl ( [--] (Part _ _ (contin_imp_inc _ _ _ _ H _ H2) [*] (b[-]a))).
 apply inv_resp_leEq.
 apply mult_resp_nonneg.
  eapply leEq_transitive; [ apply H0 | apply Hglb1 ].
  exists x.
  split. auto.
   split; algebra.
  apply (contin_imp_inc _ _ _ _ H); auto.
 apply shift_leEq_minus; astepl a; auto.
Qed.

Lemma Derivative_imp_resp_less' : forall J pJ a b F F', Derivative J pJ F F' ->
 a [<] b -> J a -> J b -> (forall contF', [0] [<=] glb_funct _ _ (Min_leEq_Max b a) F' contF') ->
 forall Ha Hb, F a Ha [#] F b Hb -> F a Ha [<] F b Hb.
Proof.
 intros J pJ a b F F' H H0 H1 H2 H3 Ha Hb H4.
 elim (ap_imp_less _ _ _ H4); intro; auto.
 exfalso.
 apply less_irreflexive_unfolded with (x := F a Ha).
 apply leEq_less_trans with (F b Hb); auto.
 apply Derivative_imp_resp_leEq with J pJ F'; auto.
 apply less_leEq; auto.
Qed.

(** From these results we can finally prove that exponentiation to a
real power preserves the less or equal than relation!
*)

Lemma nexp_resp_leEq_odd : forall n, odd n -> forall x y : IR, x [<=] y -> x[^]n [<=] y[^]n.
Proof.
 intro; case n.
  intros; exfalso; inversion H.
 clear n; intros.
 astepl (Part (FId{^}S n) x I).
 astepr (Part (FId{^}S n) y I).
 apply Derivative_imp_resp_leEq with realline I (nring (R:=IR) (S n) {**}FId{^}n).
     Opaque nring.
     Derivative_Help.
     FEQ.
    Transparent nring.
    auto.
   split.
  split.
 intros.
 apply leEq_glb; intros.
 simpl in |- *.
 apply mult_resp_nonneg.
  apply less_leEq; eapply leEq_less_trans.
   2: apply less_plusOne.
  apply nring_nonneg.
 astepr (y0[^]n); apply nexp_even_nonneg.
 inversion H; auto.
Qed.

End Various_Theorems.


(* -*- mode: coq; mode: visual-line -*- *)

(** * The Freudenthal Suspension Theorem, and related results. (INCOMPLETE) *)

Require Import HoTT.Basics HoTT.Types.
Require Import HProp EquivalenceVarieties.
Require Import HIT.Connectedness HIT.Suspension HIT.Truncations.
Import TrM.
Local Open Scope trunc_scope.
Local Open Scope path_scope.

Generalizable Variables X A B f g n.

(** [proof_admitted] is used to implement the admit tactic, as in Coq 8.5 beta 1. *)
Local Axiom proof_admitted : False.
Local Ltac admit := case proof_admitted.

(* ** Connectedness of the suspension *)

Global Instance isconn_susp {n : trunc_index} {X : Type} `{H : IsConnected n X}
  : IsConnected n.+1 (Susp X).
Proof.
  apply isconnected_from_elim.
  intros C H' f. exists (f North).
  assert ({ p0 : f North = f South & forall x:X, ap f (merid x) = p0 })
    as [p0 allpath_p0] by (apply (isconnected_elim n); apply H').
  apply (Susp_ind (fun a => f a = f North) 1 p0^).
  intros x.
  apply (concat (transport_paths_Fl _ _)).
  apply (concat (concat_p1 _)).
  apply ap, allpath_p0.
Defined.

(** ** The Freudenthal Suspension Theorem *)
Section Freudenthal.

(** We assume funext and univalence.  In fact, since we will use funext at two different levels and local assumptions are monomorphic, we need to assume funext twice; we give the second assumption of it a name (so we can use it explicitly when we want it), and a different type (so it doesn’t get used when we don’t want it). TODO: perhaps this could be handled in a more uniform way?? *)
Context `{Funext} (funext_large : Funext * Unit) `{Univalence}
        {n : trunc_index} {Hn : ~ n = -2}
        (X : Type) (x0:X) `{IsConnMap n _ _ (unit_name x0)}.

(* TODO: eventually, change these to the weaker assumptions:
Context {n : trunc_index} (X : Type) `{IsConnected n.+1 X}.
*)

(** For convenience, we add some local abbreviations. *)
Notation No := (@North X).
Notation So := (@South X).
Notation mer := (@merid X).
Definition mer' := (fun x => mer x @ (mer x0)^).

(** The eventual theorem we want is: *)
Global Instance Freudenthal
  : IsConnMap (n +2+ n) (mer').
Proof.
  intros p. unfold IsConnected.
(** We are not ready to prove this yet.  For the remainder of the section, we will generalize this goal a bit, and prove some auxiliary lemmas; then we will return to the theorem. *)
Abort.

(** The goal we require for the FST is: *)
Definition FST_Codes_No (p : No = No)
  := (Trunc (n +2+ n) (hfiber mer' p)).

(** To prove it, we generalise it over [Susp X], by [Susp_ind].  This requires three components, which we construct (the main parts of) as lemmas in advance. *)
Definition FST_Codes_So (q : No = So)
  := (Trunc (n +2+ n) (hfiber mer q)).

(* TODO: move! *)
Definition hfiber_pair {A B} {f: A -> B} {b} (a:A) (p:f a = b) : hfiber f b
  := (a;p).

Definition FST_Codes_cross (x1 : X) (q : No = So)
  : FST_Codes_No (q @ (mer x1) ^) -> FST_Codes_So q.
Proof.
  unfold FST_Codes_No, FST_Codes_So, mer'.
  apply Trunc_rec.
  intros [x2 p]. revert x1 x2 p.
  refine (@wedge_incl_elim_uncurried _ n n X x0 _ X x0 _
    (fun x1 x2 => (mer x2 @ (mer x0) ^ = q @ (mer x1) ^)
                    -> Trunc (n +2+ n) (hfiber mer q)) _ _).
  refine (pr1 (@isconnected_elim n.+1 X _ _ _ _)).
  { apply @trunc_sigma; try typeclasses eauto.
    { apply @trunc_forall; try typeclasses eauto; intro.
      apply @trunc_arrow; try typeclasses eauto; intro.
      intros.
      admit. }
    admit. }
  refine (pr1 (@isconnected_elim n.+1 X _ _ _ _)).
  { apply @trunc_arrow; try typeclasses eauto; intros.
    admit. }
  { exists (fun b s => tr (hfiber_pair b (cancelR _ _ _ s))).
    exists (fun a r => tr (hfiber_pair a
                                                    (cancelR _ _ _ ((concat_pV _) @ (concat_pV _)^ @ r)))).
    apply path_forall; intros s. apply ap, ap, ap.
    exact ((concat_1p _)^ @ whiskerR (concat_pV _)^ _). }
Defined.

(** We will need to show that [FST_Codes_cross] is an equivalence, for each [x1, q]. By connectedness of [X], it will be enough to show this for the case [x1 = x0]; to show this, we first write that case in a tidier form. *)
Definition FST_Codes_cross_x0 (q : No = So)
  : FST_Codes_No (q @ (mer x0)^) -> FST_Codes_So q.
Proof.
  unfold FST_Codes_No, FST_Codes_So.
  apply Trunc_functor, (functor_sigma idmap).
  unfold mer'; intros x1. apply cancelR.
Defined.

Definition isequiv_FST_Codes_cross (x : X) (q : No = So)
  : IsEquiv (FST_Codes_cross x q).
Proof.
  revert x.
  apply (@conn_map_elim _ _ _ (unit_name x0) _
    (fun x => IsEquiv (FST_Codes_cross x q))).
  - intros x; generalize dependent n. intros [ | n'] imposs.
    + destruct (imposs 1).
    + intros ?. apply (@trunc_leq -1);[exact tt | apply hprop_isequiv].
  - intros []. unfold FST_Codes_cross.
    refine (isequiv_homotopic (FST_Codes_cross_x0 q) _).
    { unfold FST_Codes_cross_x0.
      apply isequiv_Trunc_functor, @isequiv_functor_sigma.
      - exact _.
      - intros a. apply isequiv_cancelR. }
    { hnf. apply Trunc_ind.
      - intros ?; apply trunc_succ.
      - intros [x r]; simpl.
        unfold functor_sigma; simpl.
        symmetry.
        exact (ap10 (wedge_incl_comp1 x0 x0 _ _ _ _ x) r). }
Defined.

Definition FST_Codes
  : forall (y : Susp X), (No = y) -> Type.
Proof.
  apply (Susp_ind (fun y => (No = y -> Type)) FST_Codes_No FST_Codes_So).
  intros x. apply (@path_forall (fst funext_large)); intros p.
  refine (transport_arrow _ _ _ @ _).
  refine (transport_const _ _ @ _).
  transitivity (FST_Codes_No (p @ (mer x)^)).
  { apply ap, transport_paths_r. }
  apply path_universe_uncurried.
  exists (FST_Codes_cross x p).
  apply isequiv_FST_Codes_cross.
Defined.

(** It now remains to show that each [FST_Codes y p] is contractible. It is easy to provide a canonical inhabitant, by transport. (More directly, we could use path-induction, but we will later need to use transport lemmas to reason about this.) *)
Definition FST_Codes_center (y : Susp X) (p : No = y)
  : FST_Codes y p.
Proof.
  assert (goal' : FST_Codes y (transport _ p 1)).
  - apply transportD. simpl; unfold FST_Codes_No.
    apply tr. exists x0; unfold mer'. apply concat_pV.
  - refine (transport _ _ goal'). refine (transport_paths_r _ _ @ _).
    apply concat_1p.
Defined.

(** TODO: move the following few lemmas. *)
Lemma transport_as_ap {A} (P : A -> Type) {x y} (p : x = y)
  : transport P p == transport idmap (ap P p).
Proof.
  intros ?; destruct p; exact 1.
Defined.

Lemma transportD'
  {A : Type} (B : A -> Type) (C : forall a : A, B a -> Type)
  {x1 x2 : A} (p : x1 = x2) (y : B x1)
: C x1 y -> C x2 (transport B p y).
Proof.
  refine (transport idmap _).
  refine (_ @ ap10 (apD C p) _).
  apply inverse.
  refine (transport_arrow _ _ _ @ _).
  refine (transport_const _ _ @ _).
  apply ap, transport_Vp.
Defined.

Arguments transportD' / [_] _ _ [_ _] _ _ _.

Lemma transportD_as_apD
  {A : Type} (B : A -> Type) (C : forall a : A, B a -> Type)
  {x1 x2 : A} (p : x1 = x2) (y : B x1)
: transportD B C p y == transportD' B C p y.
Proof.
  intros ?; destruct p; simpl. exact 1.
Defined.

(** A transport lemma. *)
Definition FST_Codes_transportD_concrete (x1 : X) (p : No = No)
  : FST_Codes No p -> FST_Codes So (transport (paths No) (mer x1) p).
Proof.
  intro rr. assert (goal' : FST_Codes So (p @ mer x1)).
  - apply (FST_Codes_cross x1).
    refine (transport FST_Codes_No _ rr). symmetry; apply concat_pp_V.
  - refine (transport FST_Codes_So _ goal').
    apply inverse, transport_paths_r.
Defined.

Definition FST_Codes_transportD (x1 : X) (p : No = No) (rr : FST_Codes No p)
  : transportD (paths No) FST_Codes (mer x1) p rr
  = FST_Codes_transportD_concrete x1 p rr.
Proof.
  refine (transportD_as_apD _ _ _ _ _ @ _).
  unfold transportD'.
  unfold FST_Codes. rewrite (Susp_ind_beta_merid _ _ _ _ x1); simpl.
    rewrite (@ap10_path_forall (fst funext_large)).
  unfold FST_Codes_transportD_concrete.
  rewrite ! transport_pp.
  refine (transport_path_universe _ _ @ _).
(*rewrite transport_paths_r.
  rewrite transport_as_ap.*)
Admitted.

(** Showing it is contractible, we will again need the universal property of the suspension. We will prove the components as separate lemmas first; to see the required types of these, we temporarily set up the theorem. *)
Definition FST_Codes_contr (y : Susp X) (p : No = y) (rr : FST_Codes y p)
  : rr = FST_Codes_center y p.
Proof.
  revert y p rr.
  Check (Susp_ind (fun y => forall p rr, rr = FST_Codes_center y p)).
Abort.

Definition FST_Codes_contr_No (p : No = No) (rr : FST_Codes No p)
  : (rr = FST_Codes_center No p).
Proof.
  revert rr. apply Trunc_ind.
  - intros ?; apply trunc_succ.
  - intros [x1 r]. destruct r. unfold FST_Codes_center. simpl.
  (*transitivity (tr
    (transport (fun p => hfiber mer' p) (transport_paths_r p 1 @ concat_1p p)
    (transportD (paths No))))
simpl in *.*)
Admitted.

Global Instance Freudenthal
  : IsConnMap (n +2+ n) (@merid X).
Proof.
  intros p; apply isconnected_from_elim; intros C ? f.
Admitted.

End Freudenthal.


Goal forall P Q, P <-> Q -> P -> Q.
Proof.
  intros P Q H. Fail rewrite H.
Abort.

Require Import List.

Goal forall P Q, P <-> Q -> P -> Q.
Proof.
  intros P Q H. rewrite H. easy.
Qed.


Require Export Coq.MSets.MSetInterface.
Require Import Coq.MSets.MSetProperties
        Coq.MSets.MSetFacts
        Coq.MSets.MSetDecide.
Require Import Fiat.Common.Instances.
Require Import Fiat.Common.BoolFacts.
Require Import Fiat.Common.

Module MSetExtensionsOn (E: DecidableType) (Import M: WSetsOn E).
  Module Export BasicFacts := WFactsOn E M.
  Module Export BasicProperties := WPropertiesOn E M.
  Module Export BasicDec := WDecideOn E M.

  Definition of_list (ls : list E.t) : t
    := List.fold_right
         add
         empty
         ls.

  Global Instance Equal_Equivalence : Equivalence Equal := _.

  Global Instance equal_Equivalence : Equivalence equal.
  Proof.
    setoid_rewrite <- equal_iff; exact _.
  Qed.

  Tactic Notation "setoid_rewrite_in_all" open_constr(lem) :=
    idtac;
    match goal with
    | _ => rewrite !lem
    | [ H : _ |- _ ] => rewrite !lem in H
    | _ => setoid_rewrite lem
    | [ H : _ |- _ ] => setoid_rewrite lem in H
    end.

  Tactic Notation "setoid_rewrite_in_all" "<-" open_constr(lem) :=
    idtac;
    match goal with
    | _ => rewrite <- !lem
    | [ H : _ |- _ ] => rewrite <- !lem in H
    | _ => setoid_rewrite <- lem
    | [ H : _ |- _ ] => setoid_rewrite <- lem in H
    end.

  Ltac eq_bools_to_is_trues :=
    idtac;
    let x := match goal with |- ?x = ?y :> bool => x end in
    let y := match goal with |- x = ?y :> bool => y end in
    let Hx := fresh in
    let Hy := fresh in
    destruct x eqn:Hx;
    [ symmetry
    | destruct y eqn:Hy;
      [ rewrite <- Hx; clear Hx
      | reflexivity ] ];
    fold_is_true.

  Ltac eq_bools_to_is_trues_in H :=
    idtac;
    let x := match type of H with ?x = ?y :> bool => x end in
    let y := match type of H with x = ?y :> bool => y end in
    let Hx := fresh in
    let Hy := fresh in
    destruct x eqn:Hx;
    [ symmetry
    | destruct y eqn:Hy;
      [ rewrite <- Hx; clear Hx
      | reflexivity ] ];
    fold_is_true.
  Ltac eq_bools_to_is_trues_in_all :=
    idtac;
    match goal with
    | [ H : _ = _ :> bool |- _ ]
      => eq_bools_to_is_trues_in H
    end.

  Ltac to_caps_step :=
    first [ setoid_rewrite_in_all subset_spec
          | setoid_rewrite_in_all equal_spec
          | setoid_rewrite_in_all <- not_true_iff_false
          | setoid_rewrite_in_all negb_true_iff
          | setoid_rewrite_in_all mem_spec
          | progress fold_is_true
          | progress eq_bools_to_is_trues
          | progress eq_bools_to_is_trues_in_all ].
  Ltac to_caps := repeat to_caps_step.

  Create HintDb sets discriminated.
  Create HintDb setsb discriminated.
  Global Hint Immediate union_subset_1 union_subset_2 inter_subset_1 inter_subset_2 equal_refl : sets.
  Global Hint Resolve (BasicFacts.inter_s_m : forall x y _ x' y' _, _) : sets.

  Ltac simplify_sets_step :=
    idtac;
    match goal with
    | [ H : ?x [<=] ?y, H' : ?y [<=] ?x |- _ ]
      => pose proof (subset_antisym H H');
         clear H H'
    | [ H : context[subset ?x ?y] |- _ ]
      => match type of H with
         | context[subset y x] => fail 1
         | _ => idtac
         end;
         progress replace (equal y x) with (equal x y)
           in H by auto with sets
    | [ |- context[subset ?x ?y] ]
      => match goal with
         | [ |- context[subset y x] ] => fail 1
         | _ => idtac
         end;
         progress replace (equal y x) with (equal x y)
           by auto with sets
    | _ => setoid_subst_rel Equal
    end.

  Ltac simplify_sets := repeat simplify_sets_step.

  Ltac push_In_step :=
    first [ progress unfold Equal in *
          | setoid_rewrite_in_all union_spec
          | setoid_rewrite_in_all inter_spec
          | setoid_rewrite_in_all filter_spec; [ | let H := fresh in intros ?? H; hnf in H; substs; reflexivity.. ] ].

  Ltac push_In := repeat push_In_step.

  Lemma equal_refl_b x : equal x x.
  Proof. to_caps; auto with sets. Qed.

  Lemma equal_sym_b x y : equal x y = equal y x.
  Proof. to_caps; fsetdec. Qed.

  Hint Immediate equal_sym_b : sets.

  Lemma union_subset_1b
    : forall s s', subset s (union s s').
  Proof. to_caps; auto with sets. Qed.

  Lemma union_subset_2b
    : forall s s', subset s' (union s s').
  Proof. to_caps; auto with sets. Qed.

  Lemma inter_subset_1b
    : forall s s', subset (inter s s') s.
  Proof. to_caps; auto with sets. Qed.

  Lemma inter_subset_2b
    : forall s s', subset (inter s s') s'.
  Proof. to_caps; auto with sets. Qed.

  Hint Rewrite union_subset_1b union_subset_2b inter_subset_1b inter_subset_2b equal_refl_b : setsb.

  Lemma union_idempotent x : Equal (union x x) x.
  Proof. fsetdec. Qed.

  Lemma inter_idempotent x : Equal (inter x x) x.
  Proof. fsetdec. Qed.

  Hint Immediate union_idempotent inter_idempotent : sets.

  Lemma union_idempotent_b x : equal (union x x) x.
  Proof. to_caps; auto with sets. Qed.

  Lemma inter_idempotent_b x : equal (inter x x) x.
  Proof. to_caps; auto with sets. Qed.

  Hint Rewrite union_idempotent_b inter_idempotent_b : sets.

  Global Instance Subset_Proper_Equal_iff
    : Proper (Equal ==> Equal ==> iff) Subset.
  Proof. repeat intro; split; fsetdec. Qed.
  Global Instance Subset_Proper_Equal : Proper (Equal ==> Equal ==> impl) Subset | 1.
  Proof. repeat intro; fsetdec. Qed.
  Global Instance Subset_Proper_Equal_flip : Proper (Equal ==> Equal ==> flip impl) Subset | 1.
  Proof. repeat intro; fsetdec. Qed.

  Global Instance subset_Proper_equal
    : Proper (equal ==> equal ==> Logic.eq) subset.
  Proof. repeat intro; to_caps; fsetdec. Qed.

  Lemma equal_or_subset_and_not_equal_subset_b {x y}
    : (equal x y || (subset x y && negb (equal x y))) = subset x y.
  Proof. to_caps; bool_congr_setoid; to_caps; intuition; try fsetdec. Qed.

  Lemma equal_or_subset_and_not_equal_subset {x y}
    : (Equal x y \/ (Subset x y /\ ~Equal x y)) <-> Subset x y.
  Proof.
    destruct (equal x y) eqn:?; simpl; bool_congr; to_caps; simplify_sets;
      intuition.
  Qed.

  Hint Rewrite @equal_or_subset_and_not_equal_subset : sets.
  Hint Rewrite @equal_or_subset_and_not_equal_subset_b : setsb.

  Ltac handle_known_comparisons_step :=
    idtac;
    lazymatch goal with
    | [ |- context[subset (inter ?x ?y) ?x] ]
      => replace (subset (inter x y) x) with true by (symmetry; apply inter_subset_1b)
    | [ |- context[subset (inter ?x ?y) ?y] ]
      => replace (subset (inter x y) y) with true by (symmetry; apply inter_subset_2b)
    | [ |- context[subset ?x (union ?x ?y)] ]
      => replace (subset x (union x y)) with true by (symmetry; apply union_subset_1b)
    | [ |- context[subset ?y (union ?x ?y)] ]
      => replace (subset y (union x y)) with true by (symmetry; apply union_subset_2b)
    | [ |- context[equal (?f ?x ?y) ?x] ]
      => replace (equal (f x y) x) with (equal x (f x y)) by apply equal_sym_b
    | [ |- context[equal (?f ?x ?y) ?y] ]
      => replace (equal (f x y) y) with (equal y (f x y)) by apply equal_sym_b
    end.

  Ltac handle_known_comparisons := repeat handle_known_comparisons_step.

  Ltac cardinal_to_list_step :=
    idtac;
    match goal with
    | [ H : cardinal _ = _ |- _ ]
      => rewrite cardinal_spec in H
    | [ H : List.length ?ls = S _ |- _ ]
      => destruct ls eqn:?; simpl in H; inversion H; clear H
    | [ H : List.length ?ls = 0 |- _ ]
      => destruct ls eqn:?; simpl in H; inversion H; clear H
    | [ H : ?ls = nil |- _ ] => is_var ls; subst ls
    | [ H : ?ls = (_::_) |- _ ] => is_var ls; subst ls
    end.
  Ltac cardinal_to_list := repeat cardinal_to_list_step.
  Ltac in_to_elements :=
    repeat setoid_rewrite_in_all BasicFacts.elements_iff;
    repeat match goal with
           | [ H : elements ?v = _ |- _ ]
             => rewrite !H
           | [ H : elements ?v = _, H' : appcontext[elements ?v] |- _ ]
             => rewrite !H in H'
           end.
  Ltac InA_concretize_step :=
    idtac;
    match goal with
    | _ => progress substs
    | [ H : SetoidList.InA _ _ nil |- _ ] => solve [ inversion H ]
    | [ H : SetoidList.InA _ _ (_::_) |- _ ] => inversion H; clear H
    | [ |- ~SetoidList.InA _ _ _ ] => intro
    end.
  Ltac InA_concretitze := repeat InA_concretize_step.

  Lemma cardinal_one_In_same v
        (H : cardinal v = 1)
    : forall x y, In x v -> In y v -> E.eq x y.
  Proof.
    cardinal_to_list.
    intros; in_to_elements; InA_concretitze.
    fsetdec.
  Qed.
End MSetExtensionsOn.

Module MSetExtensions (M: Sets) := MSetExtensionsOn M.E M.


From discprob.basic Require Import base order.
From discprob.prob Require Import prob countable finite stochastic_order.
From discprob.monad Require Import monad monad_cost quicksort monad_cost_hoare.
From mathcomp Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq div choice fintype.
From mathcomp Require Import tuple finfun bigop prime binomial finset.
From mathcomp Require Import path.
Require Import Coq.omega.Omega Coq.Program.Wf.

(* Shocked this is not in the ssreflect library? *)
Lemma perm_eq_cat {A: eqType} (l1a l1b l2a l2b: seq A) :
  perm_eq l1a l2a →
  perm_eq l1b l2b →
  perm_eq (l1a ++ l1b) (l2a ++ l2b).
Proof.
  move /perm_eqP => Hpa.
  move /perm_eqP => Hpb.
  apply /perm_eqP.
  intros x. rewrite ?count_cat. rewrite (Hpa x) (Hpb x). done.
Qed.

Lemma sorted_cat {A: eqType} (l1 l2: seq A) (R: rel A):
  sorted R l1 → sorted R l2 →
  (∀ n1 n2, n1 \in l1 → n2 \in l2 → R n1 n2) →
  sorted R (l1 ++ l2).
Proof.
  revert l2. induction l1 => //=.
  intros l2 HP Hsorted Hle.
  rewrite cat_path. apply /andP; split; auto.
  induction l2 => //=. apply /andP; split; auto.
  apply Hle.
  - apply mem_last.
  - rewrite in_cons eq_refl //.
Qed.

Lemma quicksort_correct (l: list nat): mspec (qs l) (λ l', (sorted leq l' && perm_eq l l'):Prop).
Proof.
  remember (size l) as k eqn:Heq.
  revert l Heq.
  induction k as [k IH] using (well_founded_induction lt_wf) => l Heq.
  destruct l as [| a l].
  - rewrite //= => b. rewrite mem_seq1. move /eqP => -> //=.
  - destruct l as [| b0 l0].
    { rewrite //= => b. rewrite mem_seq1. move /eqP => -> //=. }
    rewrite qs_unfold.
    remember (b0 :: l0) as l eqn:Hl0. clear l0 Hl0.
    tbind (λ x, sval x \in a :: l).
    { intros (?&?) => //. }
    intros (pv&Hin) _.
    tbind (λ x, lower (sval x) = [ seq n <- (a :: l) | ltn n pv] ∧
                middle (sval x) = [ seq n <- (a :: l) | n == pv] ∧
                upper (sval x) = [ seq n <- (a :: l) | ltn pv n]).
    { remember (a :: l) as l0 eqn:Heql0.
      apply mspec_mret => //=. clear. induction l0 as [|a l]; first by rewrite //=.
      rewrite //=; case (ltngtP a pv) => //= ?;
      destruct (IHl) as (?&?&?); repeat split; auto; f_equal; done.
    }
    remember (a :: l) as l0 eqn:Heql0.
    intros (spl&Hin'). rewrite //=. intros (Hl&Hm&Hu).
    tbind (λ x, sorted leq x && perm_eq (lower spl) x).
    { rewrite //=.
      (* TODO: should probably just have an induction principle justifying this,
         we already had to prove that the list was smaller to justify that the defn
         was terminating *)
        eapply (IH (size (lower spl))); auto.
        rewrite Heq.
        move /andP in Hin'.
        destruct Hin' as (pf1&pf2); move /implyP in pf2.
        rewrite -(perm_eq_size pf1) //= ?size_cat -?plusE //;
          assert (Hlt: (lt O (size (middle spl)))) by
            ( apply /ltP; apply pf2 => //=; destruct p; eauto; subst; rewrite //=).
        rewrite //= in Hlt. omega.
    }
    intros ll. move /andP => [Hllsorted Hllperm].
    tbind (λ x, sorted leq x && perm_eq (upper spl) x).
    { rewrite //=.
        eapply (IH (size (upper spl))); auto.
        rewrite Heq.
        move /andP in Hin'.
        destruct Hin' as (pf1&pf2); move /implyP in pf2.
        rewrite -(perm_eq_size pf1) //= ?size_cat -?plusE //;
          assert (Hlt: (lt O (size (middle spl)))) by
            ( apply /ltP; apply pf2 => //=; destruct p; eauto; subst; rewrite //=).
        rewrite //= in Hlt. omega.
    }
    intros lu. move /andP => [Hlusorted Hluperm].
    apply mspec_mret => //=. apply /andP; split.
    * apply sorted_cat; [| apply sorted_cat |]; auto.
      ** rewrite Hm. clear. induction l0 => //=.
         case: ifP; auto.
         move /eqP => ->. rewrite //=.
         clear IHl0.
         induction l0 => //=.
         case: ifP; auto. move /eqP => -> //=. rewrite leqnn IHl0 //.
      ** rewrite Hm => a' b'; rewrite mem_filter.
         move /andP => [Heqpv Hin1 Hin2]. move /eqP in Heqpv.
         move: Hin2.
         rewrite -(perm_eq_mem Hluperm) Hu mem_filter.
         move /andP => [Hgtpv ?]. move /ltP in Hgtpv.
         rewrite Heqpv. apply /leP. omega.
      ** intros a' b'. rewrite -(perm_eq_mem Hllperm) Hl mem_filter.
         move /andP => [Hgtpv ?]. move /ltP in Hgtpv.
         rewrite mem_cat. move /orP => [].
         *** rewrite Hm; rewrite mem_filter.
             move /andP => [Heqpv ?]. move /eqP in Heqpv.
             rewrite Heqpv. apply /leP. omega.
         *** rewrite -(perm_eq_mem Hluperm) Hu mem_filter.
             move /andP => [Hltpv ?]. move /ltP in Hltpv.
             apply /leP. omega.
    * move /andP in Hin'. destruct Hin' as (Hperm&_).
      rewrite perm_eq_sym in Hperm.
      rewrite (perm_eq_trans Hperm) //.
      repeat apply perm_eq_cat; auto.
Qed.


Module Coq23.

  Inductive strange : Set :=
    cs : strange -> strange.

  Lemma silly : forall x : strange, cs x = x.
Proof.
  intros.
  induction x. rewrite IHx. auto.
Qed.
  Lemma strange_equ : forall x y : strange, x = y.
 Proof.
    intros. induction x.
    destruct y.
    rewrite <- IHx. apply silly.
Qed.

 Inductive A : Prop :=
   base : Set -> A
 | succ' : A -> A.

 Require Import Nat.
 Require Import Arith.

 Check (succ' (base nat)).


(*

-> Section 4 in paper
-> Union Types + Null + Intersection Types
-> Nominal types
-> Subtyping Distributivity

*)

Require Import Metalib.Metatheory.
Require Import LibTactics.
Require Import Lia.

Inductive typ : Set :=  (*r types *)
 | t_int : typ (*r int *)
 | t_top : typ (*r top type *)
 | t_bot : typ (*r bottom type *)
 | t_arrow : typ -> typ -> typ (*r function types *)
 | t_union : typ -> typ -> typ (*r intersection *)
 | t_and : typ -> typ -> typ (*r intersection *)
 | t_unit : typ (* null *)
 | t_prim (n:var).

Definition envp : Set := list ( atom * typ ).

(*well-formdness type for *)
Inductive wft (PG:envp) : typ -> Prop :=
  | wft_top :
      wft PG t_top
  | wft_bot :
      wft PG t_bot
  | wft_int :
      wft PG t_int
  | wft_arrow : forall A B,
      wft PG A ->
      wft PG B ->
      wft PG (t_arrow A B)
  | wft_or : forall A B,
      wft PG A ->
      wft PG B ->
      wft PG (t_union A B)
  | wft_and : forall A B,
      wft PG A ->
      wft PG B ->
      wft PG (t_and A B)
  | wft_unit :
      wft PG t_unit
  | wft_prim : forall i A,
      binds i A PG ->
      wft PG (t_prim i).

Inductive okenvp : envp -> Prop :=
  | okenvp_empty :
      okenvp nil
  | okenvp_cons : forall (PG:envp) (i:var),
      okenvp PG ->
      i `notin` (dom PG) ->
      okenvp ((i, t_top) :: PG)
  | okenvp_sub : forall (PG:envp) (i j:var),
      okenvp PG ->
      wft PG (t_prim j) ->
      i `notin` (dom PG) ->
      okenvp ((i, (t_prim j)) :: PG).

(* defns DSub *)
Inductive declarative_subtyping (PG: envp) : typ -> typ -> Prop :=    (* defn declarative_subtyping *)
 | DS_refl : forall (A:typ),
     okenvp PG ->
     wft PG A ->
     declarative_subtyping PG A A
 | DS_trans : forall (A C B:typ),
     declarative_subtyping PG A B ->
     declarative_subtyping PG B C ->
     declarative_subtyping PG A C
 | DS_top : forall (A:typ),
     okenvp PG ->
     wft PG A ->
     declarative_subtyping PG A t_top
 | DS_bot : forall (A:typ),
     okenvp PG ->
     wft PG A ->
     declarative_subtyping PG t_bot A
 | DS_arrow : forall (A C B D:typ),
     declarative_subtyping PG B A ->
     declarative_subtyping PG C D ->
     declarative_subtyping PG (t_arrow A C) (t_arrow B D)
 | DS_and : forall (A B C:typ),
     declarative_subtyping PG A B ->
     declarative_subtyping PG A C ->
     declarative_subtyping PG A (t_and B C)
 | DS_andl : forall (A B:typ),
     okenvp PG ->
     wft PG A -> wft PG B ->
     declarative_subtyping PG (t_and A B) A
 | DS_andr : forall (A B:typ),
     okenvp PG ->
     wft PG A -> wft PG B ->
     declarative_subtyping PG (t_and A B) B
 | DS_or : forall (A B C:typ),
     declarative_subtyping PG A C ->
     declarative_subtyping PG B C ->
     declarative_subtyping PG (t_union A B) C
 | DS_orl : forall (A B:typ),
     okenvp PG ->
     wft PG A -> wft PG B ->
     declarative_subtyping PG A (t_union A B)
 | DS_orr : forall (B A:typ),
     okenvp PG ->
     wft PG A -> wft PG B ->
     declarative_subtyping PG B (t_union A B)
 | DS_distArr : forall (A B1 B2:typ),
     okenvp PG ->
     wft PG A -> wft PG B1 -> wft PG B2 ->
     declarative_subtyping PG (t_and  (t_arrow A B1)   (t_arrow A B2) ) (t_arrow A (t_and B1 B2))
| DS_distArrU : forall (A1 B A2:typ),
     okenvp PG ->
     wft PG A1 -> wft PG A2 -> wft PG B ->
     declarative_subtyping PG (t_and  (t_arrow A1 B)   (t_arrow A2 B) ) (t_arrow (t_union A1 A2) B)
 | DS_distOr : forall (A1 B A2:typ),
     okenvp PG ->
     wft PG A1 -> wft PG A2 -> wft PG B ->
     declarative_subtyping PG (t_and  (t_union A1 B)   (t_union A2 B) ) (t_union  (t_and A1 A2)  B)
 | DS_prim : forall i A,
     okenvp PG ->
     binds i A PG ->
     declarative_subtyping PG (t_prim i) A.
(** definitions *)

(* defns Ordinary *)
Inductive ordu : typ -> Prop :=    (* defn ordu *)
 | OU_top :
     ordu t_top
 | OU_bot :
     ordu t_bot
 | OU_int :
     ordu t_int
 | OU_arrow : forall (A B:typ),
     ordu (t_arrow A B)
 | OU_and : forall (A B:typ),
     ordu A ->
     ordu B ->
     ordu (t_and A B)
 | OU_null :
     ordu t_unit
 | OU_prim : forall (i:var),
     ordu (t_prim i).

Inductive ordi : typ -> Prop :=    (* defn ordi *)
 | OI_top :
     ordi t_top
 | OI_bot :
     ordi t_bot
 | OI_int :
     ordi t_int
 | OI_arrow : forall (A B:typ),
     ordu A ->
     ordi B ->
     ordi (t_arrow A B)
 | OI_or : forall (A B:typ),
     ordi A ->
     ordi B ->
     ordi (t_union A B)
 | OI_null :
     ordi t_unit
 | OI_prim : forall (i:var),
     ordi (t_prim i).
(** definitions *)

(* defns Split *)
Inductive splu : typ -> typ -> typ -> Prop :=    (* defn splu *)
 | SpU_or : forall (A B:typ),
     splu (t_union A B) A B
 | SpU_andl : forall (A B A1 A2:typ),
     splu A A1 A2 ->
     splu (t_and A B) (t_and A1 B) (t_and A2 B)
 | SpU_andr : forall (A B B1 B2:typ),
     ordu A ->
     splu B B1 B2 ->
     splu (t_and A B) (t_and A B1) (t_and A B2).

Inductive spli : typ -> typ -> typ -> Prop :=    (* defn spli *)
 | SpI_and : forall (A B:typ),
     spli (t_and A B) A B
 | SpI_arrow : forall (A B C D:typ),
     spli B C D ->
     spli (t_arrow A B) (t_arrow A C) (t_arrow A D)
 | SpI_arrowUnion : forall (A D B C:typ),
     ordi D ->
     splu A B C ->
     spli (t_arrow A D) (t_arrow B D) (t_arrow C D)
 | SpI_orl : forall (A B A1 A2:typ),
     spli A A1 A2 ->
     spli (t_union A B) (t_union A1 B) (t_union A2 B)
 | SpI_orr : forall (A B B1 B2:typ),
     ordi A ->
     spli B B1 B2 ->
     spli (t_union A B) (t_union A B1) (t_union A B2).
(** definitions *)

(* defns SSub *)
Inductive algo_sub : envp -> typ -> typ -> Prop :=    (* defn algo_sub *)
 | AS_refl : forall PG A,
     okenvp PG ->
     wft PG A ->
     algo_sub PG A A
 | AS_prim_neq : forall PG i A n1 n2,
     okenvp ((i, A) :: PG) ->
     (* (issupertype PG n1 n2 = true) -> *)
     i <> n1 ->
     algo_sub PG (t_prim n1) (t_prim n2) ->
     algo_sub (((i, A))::PG) (t_prim n1) (t_prim n2)
 | AS_prim_eq : forall PG j n1 n2,
     okenvp (((n1,t_prim j))::PG) ->
     (* (issupertype PG n1 n2 = true) -> *)
     algo_sub PG (t_prim j) (t_prim n2) ->
     algo_sub (((n1,t_prim j))::PG) (t_prim n1) (t_prim n2)
 | AS_top : forall PG (A:typ),
     okenvp PG ->
     wft PG A ->
     algo_sub PG A t_top
 | AS_bot : forall PG (A:typ),
     okenvp PG ->
     wft PG A ->
     algo_sub PG t_bot A
 | AS_arrow : forall PG (A1 A2 B1 B2:typ),
     algo_sub PG B1 A1 ->
     algo_sub PG A2 B2 ->
     algo_sub PG (t_arrow A1 A2) (t_arrow B1 B2)
 | AS_and : forall PG (A B B1 B2:typ),
     spli B B1 B2 ->
     algo_sub PG A B1 ->
     algo_sub PG A B2 ->
     algo_sub PG A B
 | AS_andl : forall PG (A B A1 A2:typ),
     wft PG A2 ->
     spli A A1 A2 ->
     algo_sub PG A1 B ->
     algo_sub PG A B
 | AS_andr : forall PG (A B A1 A2:typ),
     wft PG A1 ->
     spli A A1 A2 ->
     algo_sub PG A2 B ->
     algo_sub PG A B
 | AS_or : forall PG (A B A1 A2:typ),
     splu A A1 A2 ->
     algo_sub PG A1 B ->
     algo_sub PG A2 B ->
     algo_sub PG A B
 | AS_orl : forall PG (A B B1 B2:typ),
     wft PG B2 ->
     splu B B1 B2 ->
     algo_sub PG A B1 ->
     algo_sub PG A B
 | AS_orr : forall PG (A B B1 B2:typ),
     wft PG B1 ->
     splu B B1 B2 ->
     algo_sub PG A B2 ->
     algo_sub PG A B.

#[export] Hint Resolve AS_refl : core.

(******************************************************************************)
(** * Size *)
Fixpoint size_typ (A1 : typ) {struct A1} : nat :=
  match A1 with
    | t_int => 1
    | t_top => 1
    | t_bot => 1
    | t_unit => 1
    | t_prim _ => 1
    | t_arrow A2 B1 => 1 + (size_typ A2) + (size_typ B1)
    | t_and A2 B1 => 1 + (size_typ A2) + (size_typ B1)
    | t_union A2 B1 => 1 + (size_typ A2) + (size_typ B1)
  end.

Fixpoint size_envp (G : envp) := match G with
                                 | nil => 0
                                 | (i, A) :: G => size_envp G + size_typ A + 1
                                     end.

(* Definition size_envp (G : envp) := fold_right plus 0 (map size_typ G). *)

Lemma size_typ_min :
  forall A1, 1 <= size_typ A1.
Proof.
  induction A1; simpl in *; eauto; try lia.
Qed.

Create HintDb SubHd.
Create HintDb FalseHd.

#[export] Hint Resolve OI_top OI_bot OI_int OU_top OU_bot OU_int OU_arrow SpI_and SpU_or : core.
#[export] Hint Constructors algo_sub ordi ordu spli splu : SubHd.

(* Types are Either Ordinary or Splittable *)
Lemma ordu_or_split: forall A,
    ordu A \/ exists B C, splu A B C.
Proof with (eauto with SubHd ; intros).
  intros. induction A...
  - (* and *)
    lets [?|(?&?&?)]: IHA1;
      lets [?|(?&?&?)]: IHA2...
Qed.

Lemma ordi_or_split: forall A,
    ordi A \/ exists B C, spli A B C.
Proof with (eauto with SubHd ; intros).
  intros. induction A...
  - (* arrow *)
    lets [?|(?&?&?)]: ordu_or_split A1;
      lets [?|(?&?&?)]: IHA2...
  - (* and *)
    lets [?|(?&?&?)]: IHA1;
      lets [?|(?&?&?)]: IHA2...
Qed.

(* destrcut conjunctions *)
Ltac destruct_conj :=
  repeat match goal with H: ?T |- _ =>
                         match T with
                         | exists _ , _ => destruct H
                         | _ /\ _ => destruct H
                         end
         end.

(********************************************)
(*                                          *)
(*            Ltac solve_false              *)
(*  try solve the goal by contradiction     *)
(*                                          *)
(********************************************)
Ltac solve_false := try intro; try solve [false; eauto 3 with FalseHd].

#[export] Hint Extern 1 => match goal with
                           | H: _ = _ |- _ => inverts H; fail
                           | H: ordi _ |- _ => inverts H; fail
                           | H: ordu _ |- _ => inverts H; fail
                           | H: spli _ _ _ |- _ => inverts H; fail
                           | H: splu _ _ _ |- _ => inverts H; fail
                         end : FalseHd.

(* splittable types and disjoint types are not overlapping *)
Lemma splu_ord_false : forall A B C,
    splu A B C -> ordu A -> False.
Proof.
  introv. gen B C.
  induction A; intros B C s o;
    try solve [inverts* s];
    try solve [inverts* o];
    inverts o;
    inverts* s.
Qed.

Lemma spli_ord_false : forall A B C,
    spli A B C -> ordi A -> False.
Proof.
  introv. gen B C.
  induction A; intros B C s o;
    try solve [inverts* s];
    try solve [inverts* o];
    inverts o;
    inverts* s.
  applys splu_ord_false; eassumption.
Qed.

#[export] Hint Resolve spli_ord_false splu_ord_false : FalseHd.

(* lemmas for ordinary *)
Lemma spli_keep_ordu_l : forall A B C,
   ordu A -> spli A B C -> ordu B.
Proof.
  introv Hord Hspl.
  inductions Hspl; try destruct m; inverts* Hord.
Qed.

Lemma spli_keep_ordu_r : forall A B C,
   ordu A -> spli A B C -> ordu C.
Proof.
  introv Hord Hspl.
  inductions Hspl; try destruct m; inverts* Hord.
Qed.

Lemma splu_keep_ord_l : forall A B C,
   ordi A -> splu A B C -> ordi B.
Proof.
  introv Hord Hspl.
  inductions Hspl; try destruct m; inverts* Hord.
Qed.

Lemma splu_keep_ord_r : forall A B C,
   ordi A -> splu A B C -> ordi C.
Proof.
  introv Hord Hspl.
  inductions Hspl; try destruct m; inverts* Hord.
Qed.

#[export] Hint Immediate spli_keep_ordu_l spli_keep_ordu_r
     splu_keep_ord_l splu_keep_ord_r : SubHd.

(* Subtyping *)
Lemma typ_size_lg_z : forall T, size_typ T > 0.
Proof.
  introv.
  pose proof (size_typ_min) T.
  inverts~ H.
Qed.

#[export] Hint Resolve typ_size_lg_z : core.

Lemma splu_decrease_size: forall A B C,
    splu A B C -> size_typ B < size_typ A /\ size_typ C < size_typ A.
Proof with (pose proof (typ_size_lg_z); simpl in *; try lia).
  introv H.
  induction H; simpl in *; eauto...
Qed.

Lemma spli_decrease_size: forall A B C,
    spli A B C -> size_typ B < size_typ A /\ size_typ C < size_typ A.
Proof with (pose proof (typ_size_lg_z); simpl in *; try lia).
  introv H.
  induction H; simpl in *; eauto...
  forwards (?&?): splu_decrease_size H0...
Qed.

Ltac s_spl_size :=
  try repeat match goal with
         | [ H: spli _ _ _ |- _ ] =>
           ( lets (?&?): spli_decrease_size H; clear H)
         | [ H: splu _ _ _ |- _ ] =>
           ( lets (?&?): splu_decrease_size H; clear H)
             end.

(********************************************)
(*                                          *)
(*               Ltac elia                 *)
(*  enhanced lia with split_decrease_size *)
(*                                          *)
(********************************************)
Ltac elia :=
  try solve [pose proof (typ_size_lg_z);
             s_spl_size; simpl in *; try lia].

Ltac indTypSize s :=
  assert (SizeInd: exists i, s < i) by eauto;
  destruct SizeInd as [i SizeInd];
  repeat match goal with | [ h : typ |- _ ] => (gen h) end;
  induction i as [|i IH]; [
    intros; match goal with | [ H : _ < 0 |- _ ] => inverts H end
  | intros ].

Ltac indTypEnvSize s :=
  assert (SizeInd: exists i, s < i) by eauto;
  destruct SizeInd as [i SizeInd];
  repeat match goal with | [ h : typ |- _ ] => (gen h) end;
  repeat match goal with | [ h : envp |- _ ] => (gen h) end;
  induction i as [|i IH]; [
    intros; match goal with | [ H : _ < 0 |- _ ] => inverts H end
  | intros ].
(* Splitting types is deterministic *)
(********************************************)
(*                                          *)
(*          Lemma split_unique              *)
(*                                          *)
(********************************************)
Lemma splu_unique : forall T A1 A2 B1 B2,
    splu T A1 B1 -> splu T A2 B2 -> A1 = A2 /\ B1 = B2.
Proof with (try eassumption; solve_false; subst~).
  intro T.
  induction T; intros;
    inverts H; inverts H0...
  - forwards (?&?): IHT1 H4 H5...
  - forwards (?&?): IHT2 H6 H7...
Qed.

Lemma spli_unique : forall T A1 A2 B1 B2,
    spli T A1 B1 -> spli T A2 B2 -> A1 = A2 /\ B1 = B2.
Proof with (try eassumption; solve_false; subst~).
  intro T.
  induction T; intros;
    inverts H; inverts H0...
  - forwards (?&?): IHT2 H4 H5...
  - forwards (?&?): splu_unique H6 H7...
  - forwards (?&?): IHT1 H4 H5...
  - forwards (?&?): IHT2 H6 H7...
Qed.

(********************************************)
(*                                          *)
(*             Ltac auto_unify              *)
(*                                          *)
(*  extends choose_unify                    *)
(*  no solve_false at the end                *)
(*                                          *)
(********************************************)
Ltac auto_unify :=
  simpl in *;
  try repeat match goal with
         | [ H1: spli ?A  _ _ , H2: spli ?A _ _ |- _ ] =>
           (forwards (?&?): spli_unique H1 H2;
            subst; clear H2)
         | [ H1: splu ?A  _ _ , H2: splu ?A _ _ |- _ ] =>
           (forwards (?&?): splu_unique H1 H2;
            subst; clear H2)
         end.

Ltac inverts_all_ord :=
  repeat match goal with
         | H: ordu (_ _ _) |- _ => inverts H
         | H: ordu (_ _) |- _ => inverts H
         | H: ordi (_ _ _) |- _ => inverts H
         | H: ordi (_ _) |- _ => inverts H
         end.

Ltac inverts_all_spl :=
  repeat match goal with
         | H: splu (_ _ _) _ _ |- _ => inverts H
         | H: splu (_ _) _ _ |- _ => inverts H
         | H: spli (_ _ _) _ _ |- _ => inverts H
         | H: spli (_ _) _ _ |- _ => inverts H
         end.

(******************************************************************************)
(* * wft *)

Ltac wft_inv := match goal with
                  H: wft ?G _ |- wft ?G ?A => match type of H with
                                           context[A] => inverts H; try assumption
                                         end
                end.
#[export] Hint Extern 1 (wft _ _) => wft_inv : core.

Lemma wft_splu_1 : forall G A1 A2 B,
    splu B A1 A2 -> wft G B -> wft G A1.
Proof.
  introv Spl Wf.
  induction* Spl. all: constructor~.
Qed.
Lemma wft_splu_2 : forall G A1 A2 B,
    splu B A1 A2 -> wft G B -> wft G A2.
Proof.
  introv Spl Wf.
  induction* Spl. all: constructor~.
Qed.
Lemma wft_splu : forall G A1 A2 B,
    splu B A1 A2 -> wft G A1 -> wft G A2 -> wft G B.
Proof.
  introv Spl Wf1 Wf2.
  induction* Spl. all: constructor~.
Qed.
#[export] Hint Immediate wft_splu_1 wft_splu_2 wft_splu : core.

Lemma wft_spli_1 : forall G A1 A2 B,
    spli B A1 A2 -> wft G B -> wft G A1.
Proof.
  introv Spl Wf.
  induction* Spl. all: constructor~.
  inverts* Wf.
Qed.
Lemma wft_spli_2 : forall G A1 A2 B,
    spli B A1 A2 -> wft G B -> wft G A2.
Proof.
  introv Spl Wf.
  induction* Spl. all: constructor~.
  inverts* Wf.
Qed.
Lemma wft_spli : forall G A1 A2 B,
    spli B A1 A2 -> wft G A1 -> wft G A2 -> wft G B.
Proof.
  introv Spl Wf1 Wf2.
  induction* Spl. all: constructor*. eauto using wft_splu.
Qed.
#[export] Hint Immediate wft_spli_1 wft_spli_2 wft_spli: core.

Ltac inverts_all_wft :=
  repeat match goal with
         | H: wft _ (_ _ _) |- _ => inverts H
         | H: wft _ (_ _) |- _ => inverts H
         | H: wft _ ?A, Hspl: spli ?A _ _ |- _ => forwards: wft_spli_1 Hspl H; forwards: wft_spli_2 Hspl H; clear H
         | H: wft _ ?A, Hspl: splu ?A _ _ |- _ => forwards: wft_splu_1 Hspl H; forwards: wft_splu_2 Hspl H; clear H
         end.

#[export] Hint Constructors wft okenvp : core.

Lemma wf_typ_weakening : forall p T G,
  wft G T ->
  okenvp (p::G) ->
  wft (p::G) T.
Proof with simpl_env; eauto.
  introv Hwf_typ Hk.
  induction Hwf_typ; intros; subst...
Qed.

Lemma okenvp_uniq : forall G,
  okenvp G -> uniq G.
Proof.
  introv H. induction* H.
Qed.

Lemma wft_in_domain : forall G n,
    wft G (t_prim n) -> n `in` dom G.
Proof.
  introv H.
  inductions H. eauto.
Qed.

Lemma wft_strenthen_prim : forall G m B n,
   wft ((m,B)::G) (t_prim n) -> m <> n -> wft G (t_prim n) .
Proof.
  introv Wf Neq. inductions Wf; eauto.
  inverts* H. injection H0; intros; subst*.
  contradiction.
Qed.

Lemma algo_sub_wft : forall G A B,
    algo_sub G A B -> okenvp G /\ wft G A /\ wft G B.
Proof with split; destruct_conj; eauto using wf_typ_weakening.
  introv H.
  induction* H...
Qed.

#[export] Hint Extern 1 (wft _ ?A) =>  match goal with
                             | H: algo_sub _ _ _ |- _ =>
                               match type of H with context[A] => forwards (?&?&?): algo_sub_wft H end
                             | Hspl: spli ?B A _, H: algo_sub _ _ _ |- _ =>
                               match type of H with context[B] => forwards (?&?&?): algo_sub_wft H end
                             | Hspl: spli ?B _ A, H: algo_sub _ _ _ |- _ =>
                               match type of H with context[B] => forwards (?&?&?): algo_sub_wft H end
                             | Hspl: splu ?B _ A, H: algo_sub _ _ _ |- _ =>
                               match type of H with context[B] => forwards (?&?&?): algo_sub_wft H end
                             end : core.

Lemma okenvp_inv : forall a PG,
    okenvp (a::PG) -> okenvp PG.
Proof.
  introv Ok. inverts~ Ok.
Qed.

#[export] Hint Immediate okenvp_inv : core.

(******************************************************************************)
(* algorithm correctness *)

(* Lemma 13 *)

Lemma algo_sub_arrow_inv : forall G A B C D,
      algo_sub G (t_arrow A B) (t_arrow C D) ->
      (algo_sub G C A) /\ (algo_sub G B D).
Proof with (try eassumption).
  introv s.
  indTypSize (size_typ (t_arrow A B) + size_typ (t_arrow C D)).
  inverts s; inverts_all_spl; inverts_all_ord; inverts_all_wft; try assumption;
    repeat match goal with
           | H: algo_sub _ (t_arrow _ _) (t_arrow _ _) |- _ => forwards (?&?): IH H; elia; clear H
           end.
  all: split; eauto 3 with *.
  (* refl *)
  all: constructor~; wft_inv.
Qed.

Lemma double_split : forall T A1 A2 B1 B2,
    splu T A1 A2 -> spli T B1 B2 ->
    ((exists C1 C2, spli A1 C1 C2 /\ splu B1 C1 A2 /\ splu B2 C2 A2) \/
    (exists C1 C2, spli A2 C1 C2 /\ splu B1 A1 C1 /\ splu B2 A1 C2)) \/
    ((exists C1 C2, splu B1 C1 C2 /\ spli A1 C1 B2 /\ spli A2 C2 B2) \/
    (exists C1 C2, splu B2 C1 C2 /\ spli A1 B1 C1 /\ spli A2 B1 C2)).
Proof with exists; repeat split*.
  introv Hu Hi.
  indTypSize (size_typ T).
  inverts keep Hu; inverts keep Hi.
  - (* spli or *) left. left...
  - (* spli or *) left. right...
  - (* splu and *) right. left...
  - (* splu and *) right. right...
Qed.

Ltac double_split_inv := match goal with
                           H1: spli ?A _ _, H2: splu ?A _ _ |- _ => forwards [ [?|?] | [?|?] ]: double_split H2 H1
                         end; destruct_conj.

Lemma algo_sub_or_inv : forall G A A1 A2 B,
    algo_sub G A B -> splu A A1 A2 ->
    algo_sub G A1 B /\ algo_sub G A2 B.
Proof with (auto_unify; try eassumption; elia; eauto 3 with SubHd).
  introv Hsub Hspl.
  indTypSize (size_typ A + size_typ B).
  inverts Hsub; inverts_all_spl; inverts_all_ord; solve_false; auto_unify; auto.
  1,2: split; eauto 3 with *.
  1,4,5: (* splu A *)
    repeat match goal with
              H1 : algo_sub _ ?A ?B, H2 : splu ?A _ _ |- _ => forwards(?&?): IH H2 H1; clear H1; elia
           end; split...
  1,2:  (* double split A *)
    double_split_inv; inverts_all_wft;
      try match goal with
            H1 : algo_sub _ ?A ?B, H2 : splu ?A _ _ |- _ => forwards(?&?): IH H2 H1; elia
          end; split...
Qed.

Ltac splu_l_inv := match goal with
                     H1 : algo_sub _ ?A ?B, H2 : splu ?A _ _ |- _ => forwards(?&?): algo_sub_or_inv H1 H2; clear H1; elia
                   end.

Lemma algo_sub_orlr_inv : forall G A B B1 B2,
    algo_sub G A B -> ordu A -> splu B B1 B2 ->
    algo_sub G A B1 \/ algo_sub G A B2.
Proof with (solve_false; auto_unify; try eassumption; elia; eauto 3 with SubHd).
  introv Hsub Hspl.
  indTypSize (size_typ A + size_typ B).
  inverts Hsub; inverts_all_spl; inverts_all_ord; solve_false; auto_unify; auto.
  1,2: eauto 3 with *.
  1: (* double split *)
    double_split_inv; inverts_all_wft;
      repeat match goal with
               H0: ordu ?A, H1 : algo_sub _ ?A ?B, H2 : splu ?B _ _ |- _ => forwards [?|?]: IH H0 H1 H2; clear H1; elia
             end...
  1,2 : match goal with
              H1 : algo_sub _ ?A ?B, H2 : splu ?B _ _ |- _ => forwards [?|?]: IH H1 H2; elia
        end...
Qed.

Ltac splu_r_inv := match goal with
                     H1 : algo_sub _ ?A ?B, H2 : splu ?B _ _, H3: ordu ?A |- _ => forwards[?|?]: algo_sub_orlr_inv H1 H3 H2; clear H1; elia
                     end.

Lemma algo_sub_and_inv : forall G A B B1 B2,
    algo_sub G A B -> spli B B1 B2 -> algo_sub G A B1 /\ algo_sub G A B2.
Proof with (auto_unify; try eassumption; elia; eauto 3 with SubHd).
  introv Hsub Hspl.
  indTypSize (size_typ A + size_typ B).
  inverts Hsub; inverts_all_spl; inverts_all_ord; inverts_all_wft; solve_false; auto_unify; auto.
  1,2: split; eauto 3 with *.
  1,3,4,5: (* spli B *)
    repeat match goal with
              H1 : algo_sub _ ?A ?B, H2 : spli ?B _ _ |- _ => forwards(?&?): IH H1 H2; clear H1; elia
           end; split...
  1: splu_l_inv; split...
  1,2:  (* double split A *)
    double_split_inv; inverts_all_wft;
      try match goal with
            H1 : algo_sub _ ?A ?B, H2 : spli ?B _ _ |- _ => forwards(?&?): IH H1 H2; elia
          end; split...
Qed.

Ltac spli_r_inv := match goal with
                     H1 : algo_sub _ ?A ?B, H2 : spli ?B _ _ |- _ => forwards(?&?): algo_sub_and_inv H1 H2; clear H1; elia
                   end.

Lemma algo_sub_andlr_inv : forall G A B A1 A2,
    algo_sub G A B -> spli A A1 A2 -> ordi B ->
    algo_sub G A1 B \/ algo_sub G A2 B.
Proof with (try eassumption; elia; eauto 3 with SubHd).
  introv Hsub Hspl.
  indTypSize (size_typ A + size_typ B).
  inverts Hsub; inverts_all_spl; inverts_all_ord; inverts_all_wft; solve_false; auto_unify; auto;
    repeat match goal with
              H0: ordi ?B, H1 : algo_sub ?A ?B, H2 : spli ?A _ _ |- _ => forwards [?|?]: IH H1 H2 H0; clear H1; elia
    end.
  1,2: eauto 3 with *.
  1,3,4,5:  (* spli A *)
    repeat match goal with
             H1 : algo_sub _ ?A ?B, H2 : spli ?A _ _ |- _ => forwards[?|?]: IH H1 H2; clear H1; elia
                end...
  1: (* double split *)
    double_split_inv; inverts_all_wft;
      repeat match goal with
               H0: ordi ?B, H1 : algo_sub _ ?A ?B, H2 : spli ?A _ _ |- _ => forwards [?|?]: IH H1 H2 H0; clear H1; elia
             end...
  splu_r_inv...
Qed.

Ltac spli_l_inv := match goal with
                     H1 : algo_sub _ ?A ?B, H2 : spli ?A _ _, H3: ordi ?B |- _ => forwards[?|?]: algo_sub_orlr_inv H1 H2 H3; clear H1; elia
                   end.

(********************************************)
(*                                          *)
(*             Ltac auto_inv                *)
(*                                          *)
(*  extends choose_unify                    *)
(*  no solve_false at the end               *)
(*                                          *)
(********************************************)
Ltac auto_inv :=
  repeat try match goal with
         | [ H1: algo_sub _ (t_arrow _ _) (t_arrow _ _) |- _ ] =>
           try (forwards~ (?&?): algo_sub_arrow_inv H1; clear H1)
         | [ H1: algo_sub _ ?A (t_and _ _) |- _ ] =>
           try (forwards~ (?&?): algo_sub_and_inv H1; clear H1)
      end;
  repeat try match goal with
         | [ H1: algo_sub _ ?A ?B, H2: spli ?B _ _ |- _ ] =>
           try (forwards~ (?&?): algo_sub_and_inv H1 H2; clear H1)
         | [ H1: algo_sub _ ?A (t_and _ _) |- _ ] =>
           try (forwards~ (?&?): algo_sub_and_inv H1; clear H1)
      end;
  repeat try match goal with
         | [ Hord: ordi ?B, H1: algo_sub _ ?A ?B, H2: spli ?A _ _ |- _ ] =>
           try (forwards~ [?|?]: algo_sub_andlr_inv H1 H2 Hord; clear H1)
         | [ Hord: ordi ?B, H1: algo_sub _ (t_and  _ _)  ?B |- _ ] =>
           try (forwards~ [?|?]: algo_sub_andlr_inv H1 Hord; clear H1)
      end;
  repeat try match goal with
         | [ H1: algo_sub _ ?A ?B, H2: splu ?A _ _ |- _ ] =>
           try (forwards~ (?&?): algo_sub_or_inv H1 H2; clear H1)
         | [ H1: algo_sub _ (t_union _ _) ?B |- _ ] =>
           try (forwards~ (?&?): algo_sub_or_inv H1; clear H1)
         end;
  repeat try match goal with
         | [ Hord: ordu ?A, H1: algo_sub _ ?A ?B, H2: splu ?B _ _ |- _ ] =>
           try (forwards~ [?|?]: algo_sub_orlr_inv H1 Hord H2; clear H1)
         | [ Hord: ordu ?A, H1: algo_sub _ ?A (t_union _ _) |- _ ] =>
           try (forwards~ [?|?]: algo_sub_orlr_inv H1 Hord; clear H1)
             end.

Lemma trans_via_top : forall G A B,
    algo_sub G t_top B -> wft G A -> algo_sub G A B.
Proof.
  introv s w.
  inductions s; inverts_all_wft; eauto 3 with SubHd; solve_false.
  forwards~ : IHs1. forwards~ : IHs2. applys~ AS_and H.
Qed.

(******************************************************************************)
(** * Nominal types *)
Lemma algo_sub_in_domain_1 : forall G n A,
  algo_sub G (t_prim n) A -> n `in` dom G.
Proof with solve_false.
  introv Sub. apply algo_sub_wft in Sub. destruct_conj.
  applys~ wft_in_domain.
Qed.

Lemma algo_sub_in_domain_2 : forall G n A,
  algo_sub G A (t_prim n) -> n `in` dom G.
Proof with solve_false.
  introv Sub. apply algo_sub_wft in Sub. destruct_conj.
  applys~ wft_in_domain.
Qed.

#[export] Hint Immediate algo_sub_in_domain_1 algo_sub_in_domain_2 : core.

Lemma algo_sub_weakening : forall p G S T,
  algo_sub G S T ->
  okenvp (p::G) ->
  algo_sub (p::G) S T.
Proof with eauto using wf_typ_weakening.
  introv Sub Ok.
  induction Sub; intros; subst...
  1: (* prim_neq *)
    { clear IHSub. destruct p. case_eq (eq_dec a n1); intros; subst.
       - false. apply algo_sub_in_domain_1 in Sub.
         apply okenvp_uniq in Ok. inverts Ok.
         rewrite dom_cons in H6. eauto.
       - applys~ AS_prim_neq.
         applys~ AS_prim_neq.
  }
  1: (* prim_eq *)
    { clear IHSub. destruct p. case_eq (eq_dec a n1); intros; subst.
      - false.
        apply okenvp_uniq in Ok. inverts Ok.
         rewrite dom_cons in H5. eauto.
       - applys~ AS_prim_neq.
         applys~ AS_prim_eq.
  }
  all: try constructor~...
  all: try forwards: IHSub...
  all: try forwards: IHSub1...
  all: try forwards: IHSub2...
  all: try eauto 2 with *.
  all: try solve [applys AS_andl; try eassumption; eauto using wf_typ_weakening].
  all: try solve [applys AS_andr; try eassumption; eauto using wf_typ_weakening].
  all: try solve [applys AS_orl; try eassumption; eauto using wf_typ_weakening].
  all: try solve [applys AS_orr; try eassumption; eauto using wf_typ_weakening].
Qed.

Lemma algo_sub_completeness: forall i A G,
    okenvp G -> binds i A G -> algo_sub G (t_prim i) A.
Proof.
  introv WF HB. gen i A.
  induction WF; intros; solve_false.
  - inverts HB.
    + injection H0; intros; subst.
      applys* AS_top.
    + applys~ algo_sub_weakening.
  - inverts HB.
    + injection H1; intros; subst.
      applys* AS_prim_eq.
    + applys algo_sub_weakening.
      applys* IHWF. constructor*.
Qed.

Lemma algo_sub_prim_eq:  forall PG j n1 A,
    okenvp ((n1,t_prim j) :: PG) ->
    algo_sub PG (t_prim j) A ->
    algo_sub (((n1,t_prim j))::PG) (t_prim n1) A.
Proof with try eassumption.
  introv Uni Sub.
  inductions Sub; solve_false;
    assert (wft ((n1, t_prim j) :: PG) (t_prim n1)) by eauto;
    eauto 3 with SubHd.
  - forwards~ : IHSub1... forwards~ : IHSub2...
    eauto 3 with SubHd.
  - forwards~ : IHSub...
    eauto 3 using wf_typ_weakening with SubHd.
  - forwards~ : IHSub...
    eauto 3 using wf_typ_weakening with SubHd.
Qed.

#[export] Hint Resolve algo_sub_prim_eq : SubHd.

Lemma algo_sub_prim_strenthen_head : forall i A G n B,
    algo_sub ((i, A) :: G) (t_prim n) B -> i <> n -> wft G B -> algo_sub G (t_prim n) B.
Proof with try eassumption; eauto 3 with SubHd.
  introv Sub Neq Wf.
  inductions Sub; solve_false...
  all: try assert (okenvp G) by inverts~ H.
  all: assert (HWF: wft ((i, A) :: G) (t_prim n)) by eauto.
  all: assert (wft G (t_prim n)).
  all: inverts HWF as Bind; inverts Bind as Heq;
    try injection Heq; intros; subst*; eauto; try solve [contradiction].
  all: eauto 3 with SubHd.
  - forwards~ : IHSub1. eauto. forwards~ : IHSub2...
Qed.

Lemma algo_sub_prim_ord : forall G n A,
   algo_sub G (t_prim n) A -> ordu A -> ordi A -> A = t_top \/ exists m, A = t_prim m.
Proof.
  introv Sub Ord1 Ord2.
  inductions Sub; solve_false.
  all: try solve [left~].
  all: try solve [right*].
Qed.
(******************************************************************************)
Ltac eassumption_spl :=
  match goal with
    | |- spli _ _ _ => try eassumption
    | |- splu _ _ _ => try eassumption
  end.
#[export] Hint Extern 0 => eassumption_spl : core.

Local Ltac algo_trans_autoIH :=
  match goal with
  | [ IH: forall G : envp, _ , H1: algo_sub _ ?A ?B , H2: algo_sub _ ?B ?C |- algo_sub _ ?A ?C ] =>
    (applys~ IH H1 H2; elia; auto)
  | [ IH: forall G : envp, _ , H1: algo_sub _ ?A ?B  |- algo_sub _ ?A ?C ] =>
    (applys~ IH H1; elia; try constructor~)
  | [ IH: forall G : envp, _ , H2: algo_sub _ ?B ?C |- algo_sub _ ?A ?C ] =>
    (applys~ IH H2; elia; try constructor~)
  end.

Lemma algo_sub_prim_neq : forall i A n m G,
    algo_sub ((i,A)::G) (t_prim n) (t_prim m) -> i <> n -> i <> m.
Proof.
  introv Sub Neq.
  inverts Sub; solve_false.
  - subst. apply okenvp_uniq in H4. inverts H4.
    forwards* : algo_sub_in_domain_2 G m.
Qed.

Lemma algo_sub_trans : forall G A B C, algo_sub G A B -> algo_sub G B C -> algo_sub G A C.
Proof with (solve_false; auto_unify; try eassumption_spl; auto_inv; inverts_all_wft; eauto 3 with SubHd; try solve algo_trans_autoIH).
  introv s1 s2.
  indTypEnvSize (size_envp G + size_typ A + size_typ B + size_typ C).
  forwards(?&?&?): algo_sub_wft s1. forwards(?&?&?): algo_sub_wft s2.
  lets [Hi|(?&?&Hi)]: ordi_or_split C...
  - lets [Hu|(?&?&Hu)]: ordu_or_split A...
    + lets [Hi'|(?&?&Hi')]: ordi_or_split B...
      lets [Hu'|(?&?&Hu')]: ordu_or_split B...
      lets [Hi''|(?&?&Hi'')]: ordi_or_split A...
      * (* double ord A B *)
        assert (okenvp G) by eauto.
        inverts keep s1; auto_unify...
        ** (* prim neq *)
          lets [Hu''|(?&?&Hu'')]: ordu_or_split C.
          *** forwards~ [?|(?&?)]: algo_sub_prim_ord s2 Hu''; subst; solve_false.
              1: { eauto 4 with SubHd. }
              applys algo_sub_weakening.
              applys~ IH...
              applys~ algo_sub_prim_strenthen_head s2.
              { assert (n2 `in` dom PG) by applys* wft_in_domain.
                apply okenvp_uniq in H. inverts H. intro HF. subst*. }
              { applys wft_strenthen_prim. now eauto.
                applys algo_sub_prim_neq s2.
                applys~ algo_sub_prim_neq s1. }
              now elia. now auto.
          *** auto_inv.
              { applys AS_orl... }
              { applys AS_orr... }
        ** (* prim eq *)
          lets [Hu''|(?&?&Hu'')]: ordu_or_split C.
          *** forwards~ [?|(?&?)]: algo_sub_prim_ord s2 Hu''; subst; solve_false.
              1: { eauto 4 with SubHd. }
              case_eq (eq_dec n1 n2); intros; subst~.
              applys~ algo_sub_prim_eq.
              apply algo_sub_prim_strenthen_head in s2; auto.
              applys IH... now elia.
              { applys wft_strenthen_prim. now eauto.
                applys~ algo_sub_prim_neq s2. }
          *** auto_inv.
              { applys AS_orl... }
              { applys AS_orr... }
        ** (* top *) applys~ trans_via_top.
        ** (* arrow *) inverts~ s2...
           (* *** applys AS_top... *)
           *** applys AS_arrow...
           *** applys AS_orl...
           *** applys AS_orr...
      * applys AS_andl...
      * applys AS_andr...
    + lets [Hi'|(?&?&Hi')]: ordi_or_split A...
      * applys AS_or Hu...
      * assert (algo_sub G x C)...
        assert (algo_sub G x0 C)...
  - applys AS_and Hi...
Qed.

#[export] Hint Resolve algo_sub_trans : SubHd.

Lemma algo_sub_symm_and: forall G A B,
    wft G A -> wft G B -> okenvp G -> algo_sub G (t_and A B) (t_and B A).
Proof with eauto 3 with SubHd.
  intros. applys~ AS_and...
Qed.

Lemma algo_sub_symm_or: forall G A B,
    wft G A -> wft G B -> okenvp G ->
    algo_sub G (t_union A B) (t_union B A).
Proof with eauto 3 with SubHd.
  intros. applys~ AS_or...
Qed.

Ltac split_inter_constructors :=
  applys* SpI_and + applys* SpI_orl +
  applys* SpI_arrow + applys* SpI_orl.
Ltac split_union_constructors :=
  applys* SpU_or + applys* SpU_andl.
Ltac swap_or_r := applys algo_sub_trans; [ | applys algo_sub_symm_or ].
Ltac swap_and_l := applys algo_sub_trans; [ (applys algo_sub_symm_and) | ].
Ltac split_r := applys AS_and; try split_inter_constructors.
Ltac split_l := applys AS_or; try split_union_constructors.
Ltac use_left_l := applys AS_andl; try split_inter_constructors.
Ltac use_right_l := applys AS_andr; try split_inter_constructors.
Ltac use_left_r := applys AS_orl; try split_union_constructors.
Ltac use_right_r := applys AS_orr; try split_union_constructors.

Ltac match_or := split_l; [ use_left_r | use_right_r].
Ltac match_and := split_r; [ use_left_l | use_right_l].
Ltac match_or_rev := split_l; [ use_right_r |  use_left_r ].
Ltac match_and_rev := split_r; [ use_right_l | use_left_l ].
Ltac swap_or_l := applys algo_sub_trans; [ applys algo_sub_symm_or | ].
Ltac swap_and_r := applys algo_sub_trans; [ | (applys algo_sub_symm_and) ].

Lemma algo_sub_distArrU: forall G A B C,
    wft G A -> wft G B -> wft G C -> okenvp G ->
    algo_sub G (t_and (t_arrow A C) (t_arrow B C)) (t_arrow (t_union A B) C).
Proof with eauto.
  introv.
  indTypSize (size_typ C).
  lets [Hi1|(?&?&Hi1)]: ordi_or_split C.
  - applys AS_and; eauto 3 with SubHd.
    use_left_l... use_right_l...
  - (* split C x x0 *)
    forwards~ Hs1: IH A B x... now elia.
    forwards~ Hs2: IH A B x0... now elia.
    applys AS_and. now eauto 3 with SubHd.
    + applys algo_sub_trans Hs1. match_and...
      applys AS_arrow... eauto 3 with SubHd.
      applys AS_arrow... eauto 3 with SubHd.
    + applys algo_sub_trans Hs2. match_and...
      applys AS_arrow... eauto 3 with SubHd.
      applys AS_arrow... eauto 3 with SubHd.
Qed.

#[export] Hint Resolve algo_sub_distArrU : SubHd.

Local Ltac auto_sub :=
  match goal with
        | |- algo_sub _ (t_arrow (t_union _ _) _) (t_and _ _) => split_r; auto_sub
        | H1: algo_sub _ ?A ?B, H2: algo_sub _ ?B ?C |- algo_sub _ ?A ?C => applys algo_sub_trans H1 H2
        | |- algo_sub _ ?A (t_union ?A _) => use_left_r; auto
        | |- algo_sub _ ?A (t_union _ ?A) => use_right_r; auto
        | |- algo_sub _ (t_and ?A _) ?A => use_left_l; auto
        | |- algo_sub _ (t_and _ ?A) ?A => use_right_l; auto
        | |- algo_sub _ ?A ?A => applys AS_refl; auto_sub
        | |- algo_sub _ (t_arrow _ _) (t_arrow _ _) => applys AS_arrow; auto_sub
        | |- algo_sub _ (t_and _ _) (t_and _ _) => match_and; auto with *
        | |- algo_sub _ (t_and (t_union _ _) (t_union _ _)) (t_union (t_and _ _) _) =>
          match_and; auto with *
        | |- algo_sub _ (t_and (t_union _ _) (t_union _ _)) (t_union _ (t_and _ _)) =>
          swap_or_r; auto with *; match_and; match_or_rev; auto with *

        | |- algo_sub _ _ (t_union _ _) => match_or; try applys AS_refl; auto with *
        | |- algo_sub _ (t_union _ _) (_ (t_union _ _)) => match_or; auto with *
        | |- algo_sub _ (t_and (t_union _ _) _) (t_union (t_and _ _) (t_and _ _)) =>
          match_or; auto with *
        | |- algo_sub _ (t_and _ (t_union _ _)) (t_union (t_and _ _) (t_and _ _)) =>
          swap_and_l; auto with *; match_or; match_and_rev; auto with *

        | |- algo_sub _ (t_and _ _) (_ (t_and _ _)) => match_and; auto with *
        | |- algo_sub _ (t_union _ _) (_ _ (t_union _ _)) => match_or; auto with *
        | |- algo_sub _ (_ _ (t_and _ _)) (t_and _ _) => match_and; auto with *
        | |- _ => auto
  end.

Lemma algo_sub_soundness: forall i j G,
    algo_sub G (t_prim i) (t_prim j) ->
    i=j \/ binds i (t_prim j) G \/ exists A, binds i A G /\ algo_sub G A (t_prim j).
Proof.
  introv Sub.
  inductions Sub; solve_false.
  - now tauto.
  - forwards~ [?|[?|(?&?&?)]]: IHSub.
    right. right. exists. splits*.
    applys~ algo_sub_weakening.
  - right. right. exists (t_prim j0). splits*.
    applys~ algo_sub_weakening.
Qed.

(******************************************************************************)
#[export] Hint Constructors declarative_subtyping : SubHd.

Lemma DS_distArrRev : forall PG (A B1 B2:typ),
     okenvp PG ->
     wft PG A -> wft PG B1 -> wft PG B2 ->
     declarative_subtyping PG (t_arrow A (t_and B1 B2)) (t_and  (t_arrow A B1)   (t_arrow A B2) ).
Proof.
  introv Ok Wf1 Wf2 Wf3.
  applys* DS_and; applys DS_arrow; eauto with SubHd.
Qed.

Lemma DS_distArrURev : forall PG (A1 A2 B:typ),
     okenvp PG ->
     wft PG A1 -> wft PG A2 -> wft PG B ->
     declarative_subtyping PG (t_arrow (t_union A1 A2) B) (t_and  (t_arrow A1 B)   (t_arrow A2 B) ).
Proof.
  introv Ok Wf1 Wf2 Wf3.
  applys* DS_and; applys DS_arrow; eauto with SubHd.
Qed.

Lemma dsub_symm_and: forall G A B,
    okenvp G -> wft G A -> wft G B -> declarative_subtyping G (t_and A B) (t_and B A).
Proof.
  intros.
  applys DS_and; eauto with SubHd.
Qed.

Lemma dsub_symm_or: forall G A B,
    okenvp G -> wft G A -> wft G B -> declarative_subtyping G (t_union A B) (t_union B A).
Proof.
  intros.
  applys DS_or; eauto with SubHd.
Qed.

#[export] Hint Resolve dsub_symm_and dsub_symm_or : SubHd.

Lemma DS_distAnd : forall PG (A1 A2 B:typ),
     okenvp PG ->
     wft PG A1 -> wft PG A2 -> wft PG B ->
     declarative_subtyping PG (t_and  (t_union A1 A2)  B) (t_union  (t_and A1 B)   (t_and A2 B) ).
Proof.
  introv Ok Wf1 Wf2 Wf3.
  applys DS_trans; [ | applys~ DS_distOr].
  applys DS_and; applys DS_trans.
  2,4: applys~ dsub_symm_or.
  all: applys DS_trans; [ | applys~ DS_distOr]; applys DS_and.
  all: applys DS_trans; [ | applys~ dsub_symm_or].
  1: applys* DS_andl.
  all: applys DS_trans.
  1,3,5: applys~ DS_andr.
  all: try solve [applys~ DS_orl]; try solve[applys~ DS_orr].
Qed.

#[export] Hint Resolve DS_distArrRev DS_distArrURev DS_distAnd : SubHd.

Lemma decl_sub_weakening : forall p G S T,
  declarative_subtyping G S T ->
  okenvp (p::G) ->
  declarative_subtyping (p::G) S T.
Proof with eauto 4 using wf_typ_weakening with SubHd.
  introv Sub Ok.
  induction Sub; intros; subst...
  all: constructor...
  destruct p. applys~ binds_cons_3.
Qed.

Lemma dsub_splu: forall G A B C,
    splu A B C -> okenvp G -> wft G A -> declarative_subtyping G B A /\ declarative_subtyping G C A.
Proof with intuition.
  introv Spl Ok Wf.
  induction Spl; inverts_all_wft; intuition eauto.
  all: try forwards (?&?): IHSpl.
  all: eauto 3 with SubHd.
  - applys DS_and. applys~ DS_trans. applys~ DS_andl. now auto.
    applys~ DS_andr.
  - eauto with SubHd.
  - eauto with SubHd.
  - eauto with SubHd.
Qed.

Lemma dsub_spli: forall G A B C,
    spli A B C -> okenvp G -> wft G A -> declarative_subtyping G A B /\ declarative_subtyping G A C.
Proof with intuition.
  introv Spl Ok Wf.
  induction Spl; inverts_all_wft; forwards~ : dsub_splu; intuition eauto.
  all: try forwards (?&?): IHSpl.
  all: eauto 3 with SubHd.
  all: eauto with SubHd.
Qed.

#[export] Hint Resolve dsub_splu dsub_spli : SubHd.

Lemma dsub_or: forall G A B C,
    okenvp G -> wft G A -> splu A B C -> declarative_subtyping G A (t_union B C).
Proof with (inverts_all_wft; eauto 3 with SubHd).
  introv Ok Wf Spl.
  induction Spl; try intuition; eauto 3 with SubHd.
  - applys DS_trans.
    2: { applys* DS_distAnd... }
    applys* DS_and... applys DS_trans. applys* DS_andl.
    applys* IHSpl.
  - applys~ DS_trans. applys~ dsub_symm_and.
    applys DS_trans (t_union (t_and B1 A) (t_and B2 A)).
    1: { applys~ DS_trans.
        2: { applys~ DS_distAnd... }
        applys* DS_and... applys DS_trans. applys* DS_andl.
    applys* IHSpl. }
    applys DS_or.
    applys DS_trans (t_and A B1)...
    applys DS_trans (t_and A B2)...
Qed.

Lemma dsub_and: forall G A B C,
    okenvp G -> wft G A -> spli A B C -> declarative_subtyping G (t_and B C) A.
Proof with (inverts_all_wft; eauto 3 with SubHd).
  introv Ok Wf Spl.
  induction Spl; try intuition; eauto 3 with SubHd.
  - forwards: IHSpl... applys DS_trans...
  - forwards: dsub_or H0... applys DS_trans...
  - applys DS_trans.
    1: { applys DS_distOr... }
    applys DS_or... applys DS_trans...
  - applys DS_trans. 2: { applys dsub_symm_or... }
    applys DS_trans (t_and (t_union B1 A) (t_union B2 A))...
    2: { applys DS_trans. applys DS_distOr...
         applys DS_or... applys DS_trans... }
    applys DS_and.
    applys DS_trans (t_union A B1)...
    applys DS_trans (t_union A B2)...
Qed.

#[export] Hint Resolve dsub_and dsub_or : SubHd.

#[export] Hint Extern 1 (okenvp ?G) =>  match goal with
                             | H: algo_sub _ _ _ |- _ =>
                               match type of H with context[G] => forwards (?&?&?): algo_sub_wft H end
                             end : core.

Ltac inverts_all_wft_2 :=
  repeat match goal with
         | H: wft _ (_ _ _) |- _ => inverts H
         | H: wft _ (_ _) |- _ => inverts H
         | H: wft _ ?A, Hspl: spli ?A _ _ |- _ => forwards: wft_spli_1 Hspl H; forwards: wft_spli_2 Hspl H; clear H
         | H: wft _ ?A, Hspl: splu ?A _ _ |- _ => forwards: wft_splu_1 Hspl H; forwards: wft_splu_2 Hspl H; clear H
         | H: algo_sub _ _ _ |- wft _ _ => forwards (?&?&?): algo_sub_wft H; clear H
         end.

(* Equivalence of subtyping *)
(* Lemma 14 *)

Theorem dsub2asub: forall G A B,
    declarative_subtyping G A B <-> algo_sub G A B.
Proof with (simpl in *; try applys SpI_and; try applys SpU_or; inverts_all_wft_2; try eassumption; eauto 3 with SubHd).
  split; introv H.
  - induction H...
    all: try solve [ auto_sub ].
    + applys~ algo_sub_completeness.
  - induction H; auto with SubHd.
    + (* prim *) applys~ decl_sub_weakening.
    + (* prim eq *) applys DS_trans.
      2: { applys* decl_sub_weakening. }
      applys~ DS_prim.
    + (* and *)
      applys DS_trans (t_and B1 B2)... applys dsub_and...
    + (* andl *)
      forwards (?&?): dsub_spli PG H0...
    + (* andr *)
      forwards (?&?): dsub_spli PG H0...
    +  (* or *)
      applys DS_trans (t_union A1 A2)... applys dsub_or...
    + (* orl *)
      forwards (?&?): dsub_splu PG H0...
    + (* orr *)
      forwards (?&?): dsub_splu PG H0...
Qed.

Lemma wft_dec : forall G A, wft G A \/ ~ wft G A.
Proof.
  intros. induction* A.
  all: try solve [destruct IHA1; destruct IHA2; auto].
  induction G.
  - right. intro HF. inverts* HF.
  - destruct a.
    case_eq (eq_dec a n); intros; subst*.
    destruct IHG.
    + left*. apply wft_in_domain in H0.
      lets (?&?): binds_In_inv H0.
      econstructor. applys* binds_cons.
    + right. intro HF. apply H0.
      inverts HF. rewrite_env (nil ++ [(a,t)] ++ G) in H2.
      apply binds_remove_mid in H2. all: now eauto.
Qed.

#[export] Hint Immediate okenvp_uniq : core.

(* Lemma uniq_dec : forall (G: envp), uniq G \/ ~ uniq G. *)
(* Proof. *)
(*   introv. induction* G. *)
(*   destruct IHG. *)
(*   - destruct a. *)
(*     assert (HIn: a `in` dom G \/ a `notin` dom G) by *)
(*         forwards~ [?|?]: AtomSetNotin.D.FSetDecideAuxiliary.dec_In a (dom G). *)
(*     destruct* HIn. *)
(*     right. intro Uni. inverts~ Uni. *)
(*   - right. intro Uni. inverts~ Uni. *)
(* Qed. *)

Lemma okenvp_dec : forall G, okenvp G \/ ~ okenvp G.
Proof.
  introv. induction* G.
  destruct IHG.
  - destruct a. destruct t.
    all: try solve [right; intro HF; inverts HF].
    + forwards* [?|?]: AtomSetNotin.D.FSetDecideAuxiliary.dec_In a (dom G).
      right*. intro Ok. inverts~ Ok.
    + forwards* [?|?]: wft_dec G (t_prim n).
      * forwards* [?|?]: AtomSetNotin.D.FSetDecideAuxiliary.dec_In a (dom G).
        right*. intro Ok. inverts~ Ok.
      * right; intro HF; inverts~ HF.
  - right*.
Qed.

Lemma algo_sub_prim_dec : forall G n m,
    okenvp G ->
    algo_sub G (t_prim n) (t_prim m) \/ ~ algo_sub G (t_prim n) (t_prim m).
Proof.
  introv Ok. gen n m.
  induction G; intros.
  - right. intro HF. forwards : algo_sub_wft HF. destruct_conj.
    inverts H0. inverts H3.
  - forwards* [?|?]: IHG n m.
    + left. applys~ algo_sub_weakening.
    + destruct a. case_eq (a==n); intros; subst.
      * case_eq (n==m); intros; subst*.
        destruct t; try solve [inverts Ok].
        ** right; intro HF.
           inverts HF; solve_false.
        ** forwards* [?|?]: IHG n1 m.
           *** left. applys algo_sub_trans.
               2: applys~ algo_sub_weakening H2.
               applys* AS_prim_eq.
           *** right; intro HF.
               inverts HF; solve_false.
      * right; intro HF. apply H.
        forwards~ : algo_sub_prim_neq HF.
        applys~ algo_sub_prim_strenthen_head HF.
        applys* wft_strenthen_prim H1.
Qed.

(* Decidability of subtyping *)

(* Lemma 15 *)

Theorem decidability : forall G A B,
    algo_sub G A B \/ not (algo_sub G A B).
Proof with (simpl in *; solve_false; jauto; elia; try solve [right; intros HF; auto_inv; inverts HF; simpl in *; solve_false]; eauto 3 with SubHd).
  introv.
  indTypSize (size_typ A + size_typ B).
  lets [?|?]: okenvp_dec G. 2: { right. intro HF. applys* H. }
  lets [?|?]: wft_dec G A. 2: { right. intro HF. applys* H0. }
  lets [?|?]: wft_dec G B. 2: { right. intro HF. applys* H1. }
  lets [Hi|(?&?&Hi)]: ordi_or_split B.
  - lets [Hi'|(?&?&Hi')]: ordi_or_split A.
    + lets [Hu|(?&?&Hu)]: ordu_or_split A.
      * lets [Hu'|(?&?&Hu')]: ordu_or_split B.
        ** (* all ordinary *)
          destruct A; destruct B...
          *** forwards [IHA1|IHA1] : IH B1 A1...
              forwards [IHA2|IHA2] : IH A2 B2...
          *** applys~ algo_sub_prim_dec.
        ** (* spl > B, S-orl/r *)
          forwards [IHA1|IHA1] : IH A x...
          forwards [IHA2|IHA2] : IH A x0...
      * forwards [IHA1|IHA1] : IH x B...
        forwards [IHA2|IHA2] : IH x0 B...
    + (* spl < A, S-andl/r *)
      forwards [IHA1|IHA1] : IH x B...
      forwards [IHA2|IHA2] : IH x0 B...
  - (* spl < B, S-and *)
    forwards [IHA1|IHA1] : IH A x...
    forwards [IHA2|IHA2] : IH A x0...
Qed.


Require Import ZArith.
Require Import String.
Require Export maps.

Set Implicit Arguments.
Inductive float : Set :=.

Inductive Defn : Set :=
   FunDef : string -> list string -> Stmt -> Defn
with Exp : Set :=
   BCon : bool -> Exp
 | EVar : string -> Exp
 | ECon : Z -> Exp
 | ExpUndef : Undef -> Exp
 | ENeg : Exp -> Exp
 | EMult : Exp -> Exp -> Exp
 | EPlus : Exp -> Exp -> Exp
 | EMinus : Exp -> Exp -> Exp
 | EDiv : Exp -> Exp -> Exp
 | BLe : Exp -> Exp -> Exp
 | BLt : Exp -> Exp -> Exp
 | BEq : Exp -> Exp -> Exp
 | BAnd : Exp -> Exp -> Exp
 | BOr : Exp -> Exp -> Exp
 | EBuild : Map k k -> Exp
 | ECall : string -> list Exp -> Exp
 | ELoad : Exp -> Exp
 | BNot : Exp -> Exp
 | HOLE_Exp : Exp
with Frame : Set :=
   frame : k -> Map k k -> Frame
with kitem : Set :=
   KBool : bool -> kitem
 | KDefn : Defn -> kitem
 | KExp : Exp -> kitem
 | KExps : list Exp -> kitem
 | KFrame : Frame -> kitem
 | KFrames : list Frame -> kitem
 | KId : string -> kitem
 | KIds : list string -> kitem
 | KInt : Z -> kitem
 | KMap : Map k k -> kitem
 | KPgm : list Defn -> kitem
 | KStmt : Stmt -> kitem
 | KUndef : Undef -> kitem
 | KFreeze : kitem -> kitem
with KResult : Set :=
   Bool : bool -> KResult
 | Int : Z -> KResult
 | VUndef : Undef -> KResult
with Stmt : Set :=
   HAssign : Exp -> Exp -> Stmt
 | SAssign : string -> Exp -> Stmt
 | Seq : Stmt -> Stmt -> Stmt
 | Decl : string -> Stmt
 | SIf : Exp -> Stmt -> Stmt -> Stmt
 | Jump : Exp -> Stmt
 | SReturnVoid : Stmt
 | SReturn : Exp -> Stmt
 | SCall : string -> list Exp -> Stmt
 | Skip : Stmt
 | SWhile : Exp -> Stmt -> Stmt
with Undef : Set :=
   undef : Undef
with k : Set :=
   kdot : k
 | kra : kitem -> k -> k.

Definition KResultToExp (x : KResult) : Exp :=
  match x with
  | Bool i => BCon i
  | Int i => ECon i
  | VUndef i => ExpUndef i
  end.
Definition KResultFromExp (x : Exp) : option KResult :=
  match x with
  | BCon i => Some (Bool i)
  | ECon i => Some (Int i)
  | ExpUndef i => Some (VUndef i)
  | _ => None
  end.
Definition KResultToK (x : KResult) : kitem :=
  match x with
  | Bool i => KBool i
  | Int i => KInt i
  | VUndef i => KUndef i
  end.
Definition KResultFromK (x : kitem) : option KResult :=
  match x with
  | KBool i => Some (Bool i)
  | KInt i => Some (Int i)
  | KUndef i => Some (VUndef i)
  | _ => None
  end.
Definition ExpToK (x : Exp) : kitem :=
  match x with
  | BCon i => KBool i
  | EVar i => KId i
  | ECon i => KInt i
  | ExpUndef i => KUndef i
  | _ => KExp x
  end.
Definition ExpFromK (x : kitem) : option Exp :=
  match x with
  | KExp i => Some i
  | KBool i => Some (BCon i)
  | KId i => Some (EVar i)
  | KInt i => Some (ECon i)
  | KUndef i => Some (ExpUndef i)
  | _ => None
  end.