Add LoadPath "..".
Add LoadPath "../LabelFree".
Add LoadPath "../Hybrid".

Require Import Shared.
Require Import LabelFree.
Require Import Hybrid.
Require Import Arith.
Require Import ListLib.
Require Import Setoid.

Open Scope is5_scope.
Open Scope permut_scope.
Open Scope hybrid_is5_scope.

(* Relation for contexts *)

Definition LF_to_Hyb_ctx (G: bg_LF) (G': bg_Hyb) :=
  PPermut_LF (map snd_ G') G /\ ok_Hyb G' nil.

Lemma ok_LF_ok_Hyb:
forall (G: list (var*ty)) U,
  ok_LF G U -> ok_Hyb G U.
induction G; intros; try constructor; destruct a; inversion H; subst;
constructor; auto.
Qed.

Lemma LF_to_Hyb_ctx_Ok:
forall G' G,
  ok_Bg_LF G -> LF_to_Hyb_ctx G G' -> ok_Bg_Hyb G'.
induction G'; intros; unfold ok_Bg_Hyb in *; unfold ok_Bg_LF in *;
unfold LF_to_Hyb_ctx in *; split; destruct H0; auto; try constructor;
rewrite <- flat_map_concat.
apply ok_LF_PPermut with (G':=map snd_ (a::G')) in H.
destruct a; rew_map in *; simpl in *; rew_concat in *; auto.
apply ok_LF_ok_Hyb; auto.
symmetry; auto.
Qed.

Lemma LF_to_Hyb_ctx_extend_t:
forall G G' w Gamma v A,
LF_to_Hyb_ctx (((v,A)::Gamma)::G) ((w, (v,A)::Gamma)::G') ->
LF_to_Hyb_ctx (Gamma::G) ((w, Gamma)::G').
unfold LF_to_Hyb_ctx in *; intros; destruct H; split; rew_map in *;
simpl in *.
PPermut_LF_simpl.
apply PPermut_LF_last_rev_simpl with (a:=((v,A)::Gamma));
transitivity (((v,A)::Gamma) :: G).
rewrite <- H; PPermut_LF_simpl. PPermut_LF_simpl.
inversion H0; subst; constructor; auto.
Qed.

Lemma LF_to_Hyb_ctx_extend_w:
forall G G' w,
  LF_to_Hyb_ctx (nil::G) ((w, nil)::G') ->
  LF_to_Hyb_ctx G G'.
unfold LF_to_Hyb_ctx in *; intros; destruct H; split; rew_map in *;
simpl in *.
apply PPermut_LF_last_rev_simpl with (a:=nil);
transitivity (nil :: G).
rewrite <- H; PPermut_LF_simpl. PPermut_LF_simpl.
inversion H0; subst. apply ok_Hyb_used_weakening in H6; auto.
Qed.

Lemma LF_to_Hyb_ctx_extend2_t:
forall G G' w Gamma A,
LF_to_Hyb_ctx (Gamma::G) ((w, Gamma)::G') ->
forall v, v \notin \{} ->
LF_to_Hyb_ctx (((v,A)::Gamma)::G) ((w, (v,A)::Gamma)::G').
unfold LF_to_Hyb_ctx in *; intros; destruct H; split;
rew_map in *; simpl in *.
PPermut_LF_simpl.
apply PPermut_LF_last_rev_simpl with (a:=Gamma);
transitivity (Gamma :: G).
rewrite <- H; symmetry; apply PPermut_LF_first_last.
PPermut_LF_simpl.
inversion H1; subst; constructor; auto.
Qed.

Lemma LF_to_Hyb_ctx_extend2_w:
forall G G',
  LF_to_Hyb_ctx G G' ->
  forall w, w \notin used_w_vars_Hyb G' ->
  LF_to_Hyb_ctx (nil::G) ((w, nil)::G').
unfold LF_to_Hyb_ctx in *; intros; destruct H; split;
rew_map in *; simpl in *.
PPermut_LF_simpl; auto.
apply ok_Hyb_fresh_wo_list; auto.
rewrite notin_union; rewrite from_list_nil; split; auto.
Qed.

Lemma LF_to_Hyb_PPermut_LF_bg:
forall G G' G'',
  LF_to_Hyb_ctx G G'' ->
  PPermut_LF G G' ->
  LF_to_Hyb_ctx G' G''.
unfold LF_to_Hyb_ctx in *; intros; destruct H; split; auto.
rewrite H; auto.
Qed.

Lemma LF_to_Hyb_PPermut_Hyb_bg:
forall G' G'' G,
  LF_to_Hyb_ctx G G' ->
  PPermut_Hyb G' G'' ->
  LF_to_Hyb_ctx G G''.
unfold LF_to_Hyb_ctx in *; intros; destruct H; split.
rewrite <- H.
clear G H H1; symmetry; induction H0;
auto;rew_map; simpl; PPermut_LF_simpl.
rewrite H; rewrite H0; auto.
rewrite IHPPermut_Hyb1; rewrite IHPPermut_Hyb2; auto.
rewrite <- H0; auto.
Qed.

Add Morphism LF_to_Hyb_ctx: LF_to_Hyb_ctx_LF.
intros; split; intros.
apply LF_to_Hyb_PPermut_LF_bg with (G:=x); auto;
apply LF_to_Hyb_PPermut_Hyb_bg with (G':=x0); auto.
apply LF_to_Hyb_PPermut_LF_bg with (G:=y); auto;
apply LF_to_Hyb_PPermut_Hyb_bg with (G':=y0); auto.
Qed.

(* Relation for typing terms *)

Inductive LF_to_Hyb_term_R: ctx_LF  -> te_LF  -> ty ->
                         bg_Hyb -> var -> te_Hyb -> Prop :=

| hyp_LF_Hyb:
    forall G Gamma G' w v A,
      types_LF G Gamma (hyp_LF v) A ->
      LF_to_Hyb_ctx (Gamma::G) ((w, Gamma)::G') ->
      LF_to_Hyb_term_R Gamma (hyp_LF v) A
                    G' w (hyp_Hyb v)

| lam_LF_Hyb:
    forall L G Gamma G' w M M' A B,
      types_LF G Gamma (lam_LF A M) (A ---> B) ->
      LF_to_Hyb_ctx (Gamma::G) ((w, Gamma)::G') ->
      (forall v0,
         v0 \notin L ->
         LF_to_Hyb_term_R ((v0, A)::Gamma) (open_LF M (hyp_LF (fte v0))) B
                       G' w
                       (M' ^t^ (hyp_Hyb (fte v0)))) ->
      LF_to_Hyb_term_R Gamma (lam_LF A M) (A ---> B) G' w (lam_Hyb A M')

| appl_LF_Hyb:
    forall G Gamma G' w M1 M2 N1 N2 A B,
      types_LF G Gamma (appl_LF M1 N1) B ->
      LF_to_Hyb_term_R Gamma M1 (A ---> B) G' w M2 ->
      LF_to_Hyb_term_R Gamma N1 A G' w N2 ->
      LF_to_Hyb_ctx (Gamma::G) ((w, Gamma)::G') ->
      LF_to_Hyb_term_R Gamma (appl_LF M1 N1) B G' w (appl_Hyb M2 N2)

| box_LF_Hyb:
    forall L G Gamma G' w M N A,
      types_LF G Gamma (box_LF M) ([*]A) ->
      LF_to_Hyb_ctx (Gamma::G) ((w, Gamma)::G') ->
      (forall w0, w0 \notin L ->
        LF_to_Hyb_term_R (@nil (var*ty)) M A
                      ((w,Gamma)::G') w0 (N ^w^ (fwo w0))) ->
      LF_to_Hyb_term_R Gamma (box_LF M) ([*]A) G' w (box_Hyb N)

| unbox_LF_Hyb:
    forall G Gamma G' w M N A,
      types_LF G Gamma (unbox_LF M) A ->
      LF_to_Hyb_ctx (Gamma::G) ((w, Gamma)::G') ->
      LF_to_Hyb_term_R Gamma M ([*]A) G' w N ->
      LF_to_Hyb_term_R Gamma (unbox_LF M) A
                    G' w (unbox_fetch_Hyb (fwo w) N)

| unbox_fetch_LF_Hyb:
    forall G Gamma Gamma' G' w w' M N A G'',
      w <> w' ->
      types_LF (Gamma'::G) Gamma (unbox_LF M) A ->
      LF_to_Hyb_ctx (Gamma::Gamma'::G) ((w, Gamma)::(w', Gamma')::G') ->
      LF_to_Hyb_term_R Gamma' M ([*]A)
                    ((w, Gamma)::G') w' N ->
      ((w', Gamma')::G') ~=~ G'' ->
      LF_to_Hyb_term_R Gamma (unbox_LF M) A
                    G'' w (unbox_fetch_Hyb (fwo w') N)

| here_LF_Hyb:
    forall G Gamma G' w A M N,
      types_LF G Gamma (here_LF M) (<*>A) ->
      LF_to_Hyb_ctx (Gamma::G) ((w, Gamma)::G') ->
      LF_to_Hyb_term_R Gamma M A G' w N ->
      LF_to_Hyb_term_R Gamma (here_LF M) (<*>A)
                    G' w (get_here_Hyb (fwo w) N)

| get_here_LF_Hyb:
    forall G Gamma Gamma' G' w w' A M N G'',
      w <> w' ->
      types_LF (Gamma'::G) Gamma (here_LF M) (<*>A) ->
      LF_to_Hyb_ctx (Gamma::Gamma'::G) ((w, Gamma)::(w', Gamma')::G') ->
      LF_to_Hyb_term_R Gamma' M A
                    ((w, Gamma)::G') w' N ->
      ((w', Gamma')::G') ~=~ G'' ->
      LF_to_Hyb_term_R Gamma (here_LF M) (<*>A)
                    G'' w (get_here_Hyb (fwo w') N)

| letdia_LF_Hyb:
    forall Lt Lw G Gamma G' w A B M1 M2 N1 N2,
      types_LF G Gamma (letdia_LF M1 N1) B ->
      LF_to_Hyb_term_R Gamma M1 (<*>A) G' w M2 ->
      (forall w'0 v', w'0 \notin Lw -> v' \notin Lt ->
                     LF_to_Hyb_term_R Gamma (open_LF N1 (hyp_LF (fte v'))) B
                                   ((w'0, (v', A) :: nil ) :: G') w
                                   ((N2 ^w^ fwo w'0 ) ^t^ hyp_Hyb (fte v'))) ->
      LF_to_Hyb_ctx (Gamma::G) ((w, Gamma)::G') ->
      LF_to_Hyb_term_R Gamma (letdia_LF M1 N1) B G' w
                    (letdia_get_Hyb (fwo w) M2 N2)

| letdia_get_LF_Hyb:
    forall Lt Lw G Gamma Gamma' G' w w' A B M1 M2 N1 N2 G'',
      types_LF (Gamma'::G) Gamma (letdia_LF M1 N1) B ->
      LF_to_Hyb_term_R Gamma' M1 (<*>A)
                    ((w, Gamma)::G') w' M2 ->
      (forall w'0 v', w'0 \notin Lw -> v' \notin Lt ->
         LF_to_Hyb_term_R Gamma (open_LF N1 (hyp_LF (fte v'))) B
                       (((w'0, (v', A) :: nil ) :: (w', Gamma')::G'))
                       w ((N2 ^w^ fwo w'0 ) ^t^ hyp_Hyb (fte v'))) ->
      LF_to_Hyb_ctx (Gamma::Gamma'::G) ((w, Gamma)::(w', Gamma')::G') ->
      (w', Gamma')::G' ~=~ G'' ->
      LF_to_Hyb_term_R Gamma (letdia_LF M1 N1) B
                    G'' w
                    (letdia_get_Hyb (fwo w') M2 N2)
.

Lemma LF_to_Hyb_term_R_permut_G_Gamma:
forall Gamma Gamma' M A G w M' G',
  Gamma *=* Gamma' ->
  G ~=~ G' ->
  LF_to_Hyb_term_R Gamma M A G w M' ->
  LF_to_Hyb_term_R Gamma' M A G' w M'.
intros; generalize dependent G'; generalize dependent Gamma';
induction H1; intros; try econstructor; eauto.
rewrite <- H1; eauto.
assert (PPermut_LF (Gamma::G) (Gamma'::G)) as HP1 by (rewrite H1; auto);
assert (((w, Gamma) :: G') ~=~ ((w, Gamma') :: G'0)) as HP2 by
    (rewrite H2; PPermut_Hyb_simpl);
rewrite <- HP1; rewrite <- HP2; eauto.
rewrite <- H3; eauto.
assert (PPermut_LF (Gamma::G) (Gamma'::G)) as HP1 by (rewrite H3; auto);
assert (((w, Gamma) :: G') ~=~ ((w, Gamma') :: G'0)) as HP2 by
    (rewrite H4; PPermut_Hyb_simpl);
rewrite <- HP1; rewrite <- HP2; eauto.
rewrite <- H1; eauto.
assert (PPermut_LF (Gamma::G) (Gamma'::G)) as HP1 by (rewrite H1; auto);
assert (((w, Gamma) :: G') ~=~ ((w, Gamma') :: G'0)) as HP2 by
    (rewrite H2; PPermut_Hyb_simpl);
rewrite <- HP1; rewrite <- HP2; eauto.
rewrite <- H3; eauto.
assert (PPermut_LF (Gamma::G) (Gamma'::G)) as HP1 by (rewrite H3; auto);
assert (((w, Gamma) :: G') ~=~ ((w, Gamma') :: G'0)) as HP2 by
    (rewrite H4; PPermut_Hyb_simpl);
rewrite <- HP1; rewrite <- HP2; eauto.
rewrite <- H2; eauto.
assert (PPermut_LF (Gamma::G) (Gamma'::G)) as HP1 by (rewrite H2; auto);
assert (((w, Gamma) :: G') ~=~ ((w, Gamma') :: G'0)) as HP2 by
    (rewrite H3; PPermut_Hyb_simpl);
rewrite <- HP1; rewrite <- HP2; eauto.
rewrite <- H4; eauto.
assert (PPermut_LF (Gamma::Gamma'::G) (Gamma'0::Gamma'::G)) as HP1 by
  (rewrite H4; auto);
assert (((w, Gamma) :: (w', Gamma') :: G') ~=~
  ((w, Gamma'0):: (w', Gamma') :: G')) as HP2 by
    (rewrite H3; PPermut_Hyb_simpl);
rewrite <- HP1; rewrite <- HP2; eauto.
rewrite <- H5; rewrite H3; auto.
rewrite <- H2; eauto.
assert (PPermut_LF (Gamma::G) (Gamma'::G)) as HP1 by (rewrite H2; auto);
assert (((w, Gamma) :: G') ~=~ ((w, Gamma') :: G'0)) as HP2 by
    (rewrite H3; PPermut_Hyb_simpl);
rewrite <- HP1; rewrite <- HP2; eauto.
rewrite <- H4; eauto.
assert (PPermut_LF (Gamma::Gamma'::G) (Gamma'0::Gamma'::G)) as HP1 by
  (rewrite H4; auto);
assert (((w, Gamma) :: (w', Gamma') :: G') ~=~
  ((w, Gamma'0):: (w', Gamma') :: G')) as HP2 by
    (rewrite H3; PPermut_Hyb_simpl);
rewrite <- HP1; rewrite <- HP2; eauto.
rewrite <- H5; rewrite H3; auto.
rewrite <- H4; eauto.
assert (PPermut_LF (Gamma::G) (Gamma'::G)) as HP1 by
  (rewrite H4; auto);
assert (((w, Gamma) :: G') ~=~ ((w, Gamma') :: G'0)) as HP2 by
    (rewrite H5; PPermut_Hyb_simpl);
rewrite <- HP1; rewrite <- HP2; eauto.
rewrite <- H5; eauto.
assert (PPermut_LF (Gamma::Gamma'::G) (Gamma'0::Gamma'::G)) as HP1 by
  (rewrite H5; auto);
assert (((w, Gamma) :: (w', Gamma') :: G') ~=~
  ((w, Gamma'0):: (w', Gamma') :: G')) as HP2 by
    (rewrite H4; PPermut_Hyb_simpl);
rewrite <- HP1; rewrite <- HP2; eauto.
rewrite <- H6; rewrite H4; auto.
Qed.

Add Morphism LF_to_Hyb_term_R: LF_to_Hyb_term_R_G.
split; intros.
eapply LF_to_Hyb_term_R_permut_G_Gamma with (G:=x0) (Gamma:=x); auto.
eapply LF_to_Hyb_term_R_permut_G_Gamma with (G:=y2) (Gamma:=y); auto; symmetry;
auto.
Qed.

(* .. it types! *)

Lemma LF_to_Hyb_types:
forall G' Gamma M A w M',
  LF_to_Hyb_term_R Gamma M A G' w M' ->
  types_Hyb G' (w, Gamma) M' A.
intros; induction H; intros.
(* hyp *)
inversion H; subst; constructor; [eapply LF_to_Hyb_ctx_Ok | ]; eauto.
(* lam *)
inversion H; subst;
apply t_lam_Hyb with (L:=L \u L0); [eapply LF_to_Hyb_ctx_Ok | ]; eauto; intros;
unfold open_t_Hyb in *; unfold open_LF in *;
apply H1; eauto.
(* appl *)
inversion H; subst; econstructor; [eapply LF_to_Hyb_ctx_Ok| | ]; eauto.
(* box *)
inversion H; subst; apply t_box_Hyb with (L:=L);
assert (PPermut_LF (G & Gamma) (Gamma :: G)) as H4 by PPermut_LF_simpl;
assert (G' & (w, Gamma) ~=~ (w, Gamma) :: G') as H3 by PPermut_Hyb_simpl.
rewrite H3; eapply LF_to_Hyb_ctx_Ok; eauto; rewrite H4; auto.
intros; rewrite H3; eapply H2; eauto; rewrite <- H4; auto.
(* unbox *)
inversion H; subst.
constructor; [eapply LF_to_Hyb_ctx_Ok|] ; eauto.
constructor; auto;
eapply LF_to_Hyb_ctx_Ok; eauto;
assert (PPermut_LF (Gamma0 :: G0 & Gamma) (Gamma::G))
       by (rewrite <- H6; PPermut_LF_simpl);
rewrite H2; auto.
(* unbox-fetch *)
rewrite <- H3;
inversion H0; subst.
apply t_unbox_fetch_Hyb with (G:=G') (Gamma:=Gamma').
assert ((w, Gamma) :: (w', Gamma') :: G' ~=~ (w', Gamma') :: G' & (w, Gamma))
  by PPermut_Hyb_simpl;
rewrite <- H4; eapply LF_to_Hyb_ctx_Ok ; eauto.
assert (G' & (w, Gamma) ~=~ (w, Gamma) :: G') by PPermut_Hyb_simpl;
rewrite H4; auto.
PPermut_Hyb_simpl.
apply t_unbox_fetch_Hyb with (G:=G') (Gamma:=Gamma').
assert ((w, Gamma) :: (w', Gamma') :: G' ~=~ (w', Gamma') :: G' & (w, Gamma))
  by PPermut_Hyb_simpl.
assert (PPermut_LF (Gamma0 :: G0 & Gamma) (Gamma :: Gamma' :: G)) by
(transitivity (G0 & Gamma0 & Gamma); [ | rewrite H8 ];
 rew_app; PPermut_LF_simpl).
rewrite H6 in Ok.
rewrite <- H4; eapply LF_to_Hyb_ctx_Ok ; eauto.
assert (G' & (w, Gamma) ~=~ (w, Gamma) :: G') by PPermut_Hyb_simpl;
rewrite H4; auto.
PPermut_Hyb_simpl.
(* here *)
inversion H; subst.
constructor; [eapply LF_to_Hyb_ctx_Ok|] ; eauto.
constructor; auto;
eapply LF_to_Hyb_ctx_Ok; eauto;
assert (PPermut_LF (Gamma0 :: G0 & Gamma) (Gamma::G))
       by (rewrite <- H7; PPermut_LF_simpl);
rewrite H2; auto.
(* get-here *)
rewrite <- H3; inversion H0; subst.
apply t_get_here_Hyb with (G:=G') (Gamma:=Gamma').
assert ((w, Gamma) :: (w', Gamma') :: G' ~=~ (w', Gamma') :: G' & (w, Gamma))
  by PPermut_Hyb_simpl;
rewrite <- H4; eapply LF_to_Hyb_ctx_Ok ; eauto.
assert (G' & (w, Gamma) ~=~ (w, Gamma) :: G') by PPermut_Hyb_simpl;
rewrite H4; auto.
PPermut_Hyb_simpl.
apply t_get_here_Hyb with (G:=G') (Gamma:=Gamma').
assert ((w, Gamma) :: (w', Gamma') :: G' ~=~ (w', Gamma') :: G' & (w, Gamma))
  by PPermut_Hyb_simpl.
assert (PPermut_LF (Gamma0 :: G0 & Gamma) (Gamma :: Gamma' :: G)) by
(transitivity (G0 & Gamma0 & Gamma); [ | rewrite H9 ];
 rew_app; PPermut_LF_simpl).
rewrite H5 in Ok.
rewrite <- H4; eapply LF_to_Hyb_ctx_Ok ; eauto.
assert (G' & (w, Gamma) ~=~ (w, Gamma) :: G') by PPermut_Hyb_simpl;
rewrite H4; auto.
PPermut_Hyb_simpl.
(* letdia *)
inversion H; subst.
econstructor; [eapply LF_to_Hyb_ctx_Ok | | intros] ; eauto.
econstructor; intros; eauto;
eapply LF_to_Hyb_ctx_Ok; eauto;
assert (PPermut_LF (Gamma0 :: G0 & Gamma) (Gamma::G))
       by (rewrite <- H9; PPermut_LF_simpl);
rewrite H4; auto.
(* letdia-get *)
rewrite <- H4; inversion H; subst.
eapply t_letdia_get_Hyb with (G:=G') (Gamma:=Gamma').
assert ((w, Gamma) :: (w', Gamma') :: G' ~=~ (w', Gamma') :: G' & (w, Gamma))
  by PPermut_Hyb_simpl;
rewrite <- H5; eapply LF_to_Hyb_ctx_Ok ; eauto.
assert (G' & (w, Gamma) ~=~ (w, Gamma) :: G') by PPermut_Hyb_simpl;
rewrite H5; eauto.
intros;
assert ((w'0, (v', A) :: nil) :: (w', Gamma') :: G' ~=~
        (w'0, (v', A) :: nil) :: G' & (w', Gamma')) by PPermut_Hyb_simpl;
rewrite <- H7; eauto.
PPermut_Hyb_simpl.
eapply t_letdia_get_Hyb with (G:=G') (Gamma:=Gamma').
assert ((w, Gamma) :: (w', Gamma') :: G' ~=~ (w', Gamma') :: G' & (w, Gamma))
  by PPermut_Hyb_simpl.
assert (PPermut_LF (Gamma0 :: G0 & Gamma) (Gamma :: Gamma' :: G)) by
(transitivity (G0 & Gamma0 & Gamma); [ | rewrite H10 ];
 rew_app; PPermut_LF_simpl).
rewrite H6 in Ok.
rewrite <- H5; eapply LF_to_Hyb_ctx_Ok ; eauto.
assert (G' & (w, Gamma) ~=~ (w, Gamma) :: G') by PPermut_Hyb_simpl;
rewrite H5; eauto.
intros;
assert ((w'0, (v', A) :: nil) :: (w', Gamma') :: G' ~=~
        (w'0, (v', A) :: nil) :: G' & (w', Gamma')) by PPermut_Hyb_simpl;
rewrite <- H7; eauto.
PPermut_Hyb_simpl.
Qed.

(* ...it preserves values! *)

Lemma LF_to_Hyb_value:
forall G' Gamma M A w M',
  LF_to_Hyb_term_R Gamma M A G' w M' ->
  value_LF M -> value_Hyb M'.
intros; induction H; simpl;
inversion H0; subst; constructor; eauto.
Qed.

Close Scope hybrid_is5_scope.
Close Scope permut_scope.
Close Scope is5_scope.


Require Import Bool Arith List Cpdt.CpdtTactics.
Require Export TrmVerif.

Lemma pf_known_eq : forall (sgn : gsign) (thy : list stp) (h : hashval) (p : trm) (v : Z) (ctx : list stp) (phi : list trm) ,
get_prop_pf v ctx phi sgn (Known h) thy = Some p -> exists s, beta_eta_delta_norm s sgn = Some p /\ findsnd2 (snd sgn) h = Some s.
Proof.
  intros.
  unfold get_prop_pf in H.
  destruct (findsnd2 (snd sgn) h).
  exists t.
  split.
  apply H.
  reflexivity.
  discriminate.
Qed.

Lemma pf_prap_eq : forall (sgn : gsign) (thy : list stp) (d : pf) (e : pf) (t : trm) (v : Z) (ctx : list stp) (phi : list trm) ,
get_prop_pf v ctx phi sgn (PrAp d e) thy = Some t -> exists s, get_prop_pf v ctx phi sgn d thy = Some (Imp s t) /\ get_prop_pf v ctx phi sgn e thy = Some s.
Proof.
  intros.
  unfold get_prop_pf in H.
  fold get_prop_pf in H.
  destruct (get_prop_pf v ctx phi sgn d thy).
  destruct t0.
  discriminate.
  discriminate.
  discriminate.
  discriminate.
  discriminate.
  destruct (get_prop_pf v ctx phi sgn e thy).
  destruct (trm_eq_dec t0_1 t0).
  exists t0.
  crush.
  discriminate.
  discriminate.
  discriminate.
  discriminate.
  discriminate.
  discriminate.
  discriminate.
Qed.

Lemma pf_tmap_eq : forall (sgn : gsign) (thy : list stp) (d : pf) (t : trm) (v : Z) (ctx : list stp) (phi : list trm) (q :trm),
get_prop_pf v ctx phi sgn (TmAp d t) thy = Some q -> exists (s : trm) (a : stp),
get_prop_pf v ctx phi sgn d thy = Some (All a s) /\ correct_trm v ctx sgn t a thy = true /\ beta_eta_delta_norm (subst_trmtrm s 0 (delta_norm t sgn (length (fst sgn)))) sgn = Some q.
Proof.
  intros.
  unfold get_prop_pf in H.
  fold get_prop_pf in H.
  destruct (get_prop_pf v ctx phi sgn d thy).
  destruct t0.
  discriminate.
  discriminate.
  discriminate.
  discriminate.
  discriminate.
  discriminate.
  unfold correct_trm.
  destruct (get_stp_trm v ctx sgn t thy).
  destruct (stp_eq_dec s s0).
  exists t0.
  exists s0.
  rewrite e.
  split.
  reflexivity.
  split.
  destruct (stp_eq_dec s0 s0).
  reflexivity.
  contradict n.
  reflexivity.
  apply H.
  discriminate.
  discriminate.
  discriminate.
  discriminate.
  discriminate.
  discriminate.
Qed.

Lemma pf_stpap_eq : forall (sgn : gsign) (thy : list stp) (d : pf) (v : Z) (ctx : list stp) (phi : list trm) (q :trm) (a : stp),
  get_prop_pf v ctx phi sgn (TpAp d a) thy = Some q ->
  exists (s : trm), get_prop_pf v ctx phi sgn d thy = Some (TTpAll s) /\ crt_stp v true (Z.of_nat (length thy)) a /\ subst_trmstp s 0 a = q.
Proof.
  intros.
  unfold get_prop_pf in H.
  fold get_prop_pf in H.
  destruct (get_prop_pf v ctx phi sgn d thy).
  destruct t.
  discriminate.
  discriminate.
  discriminate.
  discriminate.
  discriminate.
  discriminate.
  discriminate.
  discriminate.
  discriminate.
  exists t.
  split.
  reflexivity.
  split.
  apply stp_eq1.
  destruct (correct_stp v a (Z.of_nat (length thy))).
  reflexivity.
  discriminate.
  destruct (correct_stp v a (Z.of_nat (length thy))).
  crush.
  discriminate.
  discriminate.
Qed.

Lemma pf_pflam_eq : forall (sgn : gsign) (thy : list stp) (d : pf) (v : Z) (ctx : list stp) (phi : list trm) (q2 :trm) (s :trm),
  get_prop_pf v ctx phi sgn (PrLa s d) thy = Some q2 ->
  exists (q t : trm), beta_eta_delta_norm s sgn = Some q /\ correct_trm v ctx sgn s prop thy = true /\ q2 = Imp q t /\ get_prop_pf v ctx (q::phi) sgn d thy = Some t.
Proof.
  intros.
  unfold get_prop_pf in H.
  fold get_prop_pf in H.
  destruct (correct_trm v ctx sgn s prop thy).
  simpl in H.
  destruct (beta_eta_delta_norm s sgn).
  exists t.
  destruct (get_prop_pf v ctx (t :: phi) sgn d thy).
  exists t0.
  crush.
  discriminate.
  discriminate.
  simpl in H.
  discriminate.
Qed.

Lemma pf_tmlam_eq : forall (sgn : gsign) (thy : list stp) (d : pf) (v : Z) (ctx : list stp) (phi : list trm) (a : stp) (q :trm),
  get_prop_pf v ctx phi sgn (TmLa a d) thy = Some q ->
  exists (s : trm), get_prop_pf v (a::ctx) (map (fun x:trm => uptrm x 0 1) phi) sgn d thy = Some s /\ q = All a s /\ crt_stp v true (Z.of_nat (length thy)) a.
Proof.
  intros.
  unfold get_prop_pf in H.
  fold get_prop_pf in H.
  destruct (get_prop_pf v (a::ctx) (map (fun x:trm => uptrm x 0 1) phi) sgn d thy).
  exists t.
  split.
  reflexivity.
  split.
  destruct (correct_stp v a (Z.of_nat (length thy))).
  simpl in H.
  crush.
  simpl in H.
  discriminate.
  apply stp_eq1.
  destruct (correct_stp v a (Z.of_nat (length thy))).
  reflexivity.
  simpl in H.
  discriminate.
  destruct (correct_stp v a (Z.of_nat (length thy))).
  simpl in H.
  discriminate.
  simpl in H.
  discriminate.
Qed.

Lemma pf_lam_eq : forall (sgn : gsign) (thy : list stp) (d : pf) (v : Z) (q :trm),
  get_prop_pf v nil nil sgn (TpLa d) thy = Some q ->
  exists (s : trm), q = TTpAll s /\ get_prop_pf (v + 1) nil nil sgn d thy = Some s.
Proof.
  intros.
  unfold get_prop_pf in H.
  fold get_prop_pf in H.
  destruct (get_prop_pf (v + 1) nil nil sgn d thy).
  exists t.
  crush.
  discriminate.
Qed.

Theorem pf_eq1: forall (sgn : gsign) (thy : list stp) (d : pf) (p : trm) (v : Z) (ctx : list stp) (phi : list trm),
  get_prop_pf v ctx phi sgn d thy = Some p -> crt_pf v ctx phi sgn thy d p.
Proof.
  induction d.
  - intros.
    apply pf_known_eq in H.
    destruct H as [s H].
    apply pf_known with (s := s).
    destruct H as [H1 H2].
    intros.
    apply H2.
    destruct H as [H1 H2].
    apply H1.
  - intros.
    unfold get_prop_pf in H.
    apply pf_hyp.
    apply H.
  - intros.
    apply pf_prap_eq in H.
    destruct H as [s H].
    apply pf_prap with (s := s).
    destruct H as [H1 H2].
    apply IHd1 in H1.
    apply H1.
    destruct H as [H1 H2].
    apply IHd2 in H2.
    apply H2.
  - intros.
    apply pf_tmap_eq in H.
    destruct H as [s H].
    destruct H as [a H].
    apply pf_tmap with (s := s) (a := a).
    destruct H as [H1 H].
    apply IHd in H1.
    apply H1.
    destruct H as [H1 H].
    destruct H as [H2 H3].
    apply crt_trm_eq1 in H2.
    apply H2.
    destruct H as [H1 H].
    destruct H as [H2 H3].
    destruct (beta_eta_delta_norm (subst_trmtrm s 0 (delta_norm t sgn (length (fst sgn)))) sgn).
    crush.
    discriminate.
  - intros.
    apply pf_stpap_eq in H.
    destruct H as [t H].
    apply pf_stpap with (s := t).
    destruct H as [H1 H].
    apply IHd in H1.
    apply H1.
    destruct H as [H1 H].
    destruct H as [H2 H].
    apply H2.
    destruct H as [H1 H].
    destruct H as [H2 H3].
    apply H3.
  - intros.
    apply pf_pflam_eq in H.
    destruct H as [q H].
    destruct H as [t0 H].
    destruct H as [H1 H].
    destruct H as [H2 H].
    destruct H as [H3 H4].
    apply pf_tmlam with (q := q) (t := t0).
    apply crt_trm_eq1 in H2.
    apply H2.
    crush.
    apply IHd in H4.
    apply H4.
    apply H3.
  - intros.
    apply pf_tmlam_eq in H.
    destruct H as [s0 H].
    destruct H as [H1 H].
    destruct H as [H2 H3].
    apply pf_tplam with (s := s0).
    crush.
    apply IHd in H1.
    apply H1.
    apply H2.
  - intros.
    destruct ctx; destruct phi.
    apply pf_lam_eq in H.
    destruct H as [s H].
    destruct H as [H1 H2].
    apply pf_all with (s := s).
    apply IHd in H2.
    apply H2.
    apply H1.
    unfold get_prop_pf in H.
    discriminate.
    unfold get_prop_pf in H.
    discriminate.
    unfold get_prop_pf in H.
    discriminate.
Qed.

Theorem crt_pf_eq1: forall (sgn : gsign) (thy : list stp) (d : pf) (p : trm) (v : Z) (ctx : list stp) (phi : list trm),
  correct_pf v ctx phi sgn d p thy = true -> crt_pf v ctx phi sgn thy d p.
Proof.
  intros.
  unfold correct_pf in H.
  fold correct_pf in H.
  apply pf_eq1.
  destruct (get_prop_pf v ctx phi sgn d thy).
  destruct (trm_eq_dec t p).
  crush.
  discriminate.
  discriminate.
Qed.

Theorem pf_eq2: forall (sgn : gsign) (thy : list stp) (d : pf) (p : trm) (v : Z) (ctx : list stp) (phi : list trm),
  crt_pf v ctx phi sgn thy d p -> get_prop_pf v ctx phi sgn d thy = Some p.
Proof.
  induction d.
  - intros.
    apply pf_known_rev in H.
    destruct H as [s H].
    destruct H as [H1 H2].
    unfold get_prop_pf.
    rewrite H1.
    rewrite H2.
    reflexivity.
  - intros.
    apply pf_hyp_rev in H.
    unfold get_prop_pf.
    rewrite H.
    reflexivity.
  - intros.
    apply pf_prap_rev in H.
    destruct H as [s H].
    destruct H as [H1 H2].
    unfold get_prop_pf.
    fold get_prop_pf.
    apply IHd1 in H1.
    apply IHd2 in H2.
    rewrite H1.
    rewrite H2.
    destruct (trm_eq_dec s s).
    reflexivity.
    contradict n.
    reflexivity.
  - intros.
    apply pf_tmap_rev in H.
    destruct H as [s H].
    destruct H as [a H].
    destruct H as [H1 H].
    destruct H as [H2 H3].
    unfold get_prop_pf.
    fold get_prop_pf.
    apply IHd in H1.
    rewrite H1.
    apply trm_eq2 in H2.
    rewrite H2.
    destruct (stp_eq_dec a a).
    rewrite H3.
    reflexivity.
    contradict n.
    reflexivity.
  - intros.
    apply pf_stpap_rev in H.
    destruct H as [t H].
    destruct H as [H1 H].
    destruct H as [H2 H3].
    unfold get_prop_pf.
    fold get_prop_pf.
    apply IHd in H1.
    rewrite H1.
    apply stp_eq2 in H2.
    rewrite H2.
    rewrite H3.
    reflexivity.
  - intros.
    apply pf_tmlam_rev in H.
    destruct H as [t0 H].
    destruct H as [q H].
    destruct H as [H1 H].
    destruct H as [H2 H].
    destruct H as [H3 H4].
    unfold get_prop_pf.
    fold get_prop_pf.
    apply IHd in H3.
    apply crt_trm_eq2 in H1.
    rewrite H1.
    simpl.
    rewrite <- H2.
    rewrite H3.
    rewrite H4.
    reflexivity.
  - intros.
    apply pf_tplam_rev in H.
    destruct H as [t H].
    destruct H as [H1 H].
    destruct H as [H2 H3].
    unfold get_prop_pf.
    fold get_prop_pf.
    apply IHd in H2.
    apply stp_eq2 in H1.
    rewrite H1.
    simpl.
    rewrite H2.
    rewrite H3.
    reflexivity.
  - intros.
    apply pf_all_rev in H.
    destruct H as [t H].
    destruct H as [H1 H].
    destruct H as [H2 H].
    destruct H as [H3 H4].
    unfold get_prop_pf.
    fold get_prop_pf.
    apply IHd in H1.
    rewrite H1.
    rewrite H2.
    rewrite H3.
    rewrite H4.
    reflexivity.
Qed.

Theorem crt_pf_eq2: forall (sgn : gsign) (thy : list stp) (d : pf) (p : trm) (v : Z) (ctx : list stp) (phi : list trm),
  crt_pf v ctx phi sgn thy d p -> correct_pf v ctx phi sgn d p thy = true.
Proof.
  intros.
  unfold correct_pf.
  apply pf_eq2 in H.
  destruct (get_prop_pf v ctx phi sgn d thy).
  destruct (trm_eq_dec t p).
  crush.
  contradict n.
  crush.
  discriminate.
Qed.


Require Import ExtLib.Core.RelDec.
Require Import ExtLib.Tactics.

Set Implicit Arguments.
Set Strict Implicit.

Theorem pull_ex_and_left
: forall T P Q, Basics.flip Basics.impl ((@ex T P) /\ Q) (exists n, P n /\ Q).
Proof.
  do 2 red. intros.
  firstorder.
Qed.

Theorem pull_ex_and_right
: forall T P Q, Basics.flip Basics.impl (Q /\ (@ex T P)) (exists n, Q /\ P n).
Proof.
  do 2 red; firstorder.
Qed.

Hint Rewrite pull_ex_and_left : pulling.
Hint Rewrite pull_ex_and_right : pulling.

(* test cases pulled from
   DemoPolyQuantPullRtac. *)
Require Import ExtLib.Core.RelDec.
Require Import ExtLib.Data.Nat.

Existing Instance RelDec_lt.
Fixpoint goal2_D mx n (acc : nat) : Prop :=
  match n with
  | 0 =>
    if acc ?[ lt ] mx then
      exists x : nat, 0 = 0
    else
      0 = 0
  | S n =>
    goal2_D mx n (acc * 2) /\ goal2_D mx n (acc * 2 + 1)
  end.

Fixpoint goal2_D' mx mx2 n (acc : nat) : Prop :=
  match n with
  | 0 =>
    if acc ?[ lt ] mx then
      exists x : nat, 0 = 0
    else if acc ?[lt] mx2 then
           exists b : bool, 0 = 0 else
           0 = 0
  | S n =>
    goal2_D' mx mx2 n (acc * 2) /\ goal2_D' mx mx2 n (acc * 2 + 1)
  end.

(* idea: maybe we want a standard way of setting mx and mx2
 *)

(* standardized way of calling goal2_D' *)

Definition goal2_D'' n : Prop :=
  let thirdn := Nat.div n 3 in
  goal2_D' thirdn (2 * thirdn) n 0.

Set Printing Depth 5. (* To avoid printing large terms *)

Ltac the_tac := rewrite_strat (bottomup (hints pulling ; eval cbv beta)).

(*
Goal goal2_D'' 12.
  vm_compute. Time the_tac.
*)

(* Data: keeping track of values for runs for different n
   we report time-out if any runs time out
   TODO we should also report QED times. these are tactic run times.

   3: .113, .109, .109, .109, .109
   4: .178, .18, .178, .177, .181
   5: .274, .278, .274, .278, .274
   6: .686, .691, .686, .687, .686
   7: 1.175, 1.172, 1.167, 1.167, 1.165
   8: 2.067, 2.074, 2.086, 2.071, 2.092
   9: 5.79, 5.81, 5.876, 5.786, 5.84
   10: 11.108, 11.793, 11.043, 11.038, 11.202
   11: 21.77, 21.601, 21.539, 21.581, 21.527
   12: 61.032, 59.672, 59.612, 59.505, 59.68
   13: time out (but not all runs)
   14: all runs time out
*)

(* original settings 4 2 5 0 provide a baseline *)
(*
Goal goal2_D' 2 4 5 0.
  vm_compute.   Time rewrite_strat (bottomup (hints pulling ; eval cbv beta)).
Abort.
*)

(* code for the new test bench *)
Module Demo.
  Ltac prep := vm_compute.
  Ltac run := rewrite_strat (bottomup (hints pulling ; eval cbv beta)).
  Ltac cleanup := repeat (first [exists 0 |exists true]); tauto.
  Definition goal := goal2_D''.
End Demo.


Require Coq.Classes.EquivDec.
Require Coq.Lists.List.
Import List.ListNotations.
Require Import Coq.Program.Program.
Require Import Leapfrog.Syntax.
Require Import Leapfrog.FinType.
Require Import Leapfrog.Sum.
Require Import Leapfrog.Syntax.

Require Import Leapfrog.BisimChecker.

Require Import Leapfrog.Notations.

Open Scope p4a.

Ltac prep_equiv :=
  unfold Equivalence.equiv, RelationClasses.complement in *;
  program_simpl; try congruence.

Obligation Tactic := prep_equiv.

Module UDPInterleaved.
  Inductive state :=
  | ParseIP
  | ParseUDP
  | ParseTCP.

  Scheme Equality for state.
  Global Instance state_eqdec: EquivDec.EqDec state eq := state_eq_dec.
  Global Instance state_finite: @Finite state _ state_eq_dec.
  Proof.
    solve_finiteness.
  Defined.

  Inductive header :=
  | HdrIP
  | HdrUDP
  | HdrTCP.

  Definition sz (h: header) : nat :=
    match h with
    | HdrIP => 64
    | HdrUDP => 32
    | HdrTCP => 64
    end.

  Scheme Equality for header.
  Global Instance header_eqdec: EquivDec.EqDec header eq := header_eq_dec.
  Global Instance header_finite: @Finite header _ header_eq_dec.
  Proof.
    solve_finiteness.
  Defined.

  Definition states (s: state) :=
    match s with
    | ParseIP =>
      {| st_op := extract(HdrIP);
         st_trans := transition select (| (EHdr (Hdr_sz := sz) HdrIP)[43 -- 40] |) {{
           [| exact #b|0|0|0|1 |] ==> inl ParseUDP ;;;
           [| exact #b|0|0|0|0 |] ==> inl ParseTCP ;;;
            reject
         }};
      |}
    | ParseUDP =>
      {| st_op := extract(HdrUDP);
         st_trans := transition accept |}
    | ParseTCP =>
      {| st_op := extract(HdrTCP);
        st_trans := transition accept |}
    end.

  Program Definition aut: Syntax.t state sz :=
    {| t_states := states |}.
  Solve Obligations with (destruct s || destruct h; cbv; Lia.lia).

End UDPInterleaved.

Module UDPCombined.
  Inductive state :=
  | ParsePref
  | ParseSuf.

  Scheme Equality for state.
  Global Instance state_eqdec: EquivDec.EqDec state eq := state_eq_dec.
  Global Instance state_finite: @Finite state _ state_eq_dec.
  Proof.
    solve_finiteness.
  Defined.

  Inductive header :=
  | HdrIP
  | HdrPref.

  Definition sz (h: header) : nat :=
    match h with
    | HdrIP => 64
    | HdrPre => 32
    end.

  Scheme Equality for header.
  Global Instance header_eqdec: EquivDec.EqDec header eq := header_eq_dec.
  Global Instance header_finite: @Finite header _ header_eq_dec.
  Proof.
    solve_finiteness.
  Defined.

  Definition states (s: state) :=
    match s with
    | ParsePref =>
      {| st_op :=
          extract(HdrIP) ;;
          extract(HdrPref) ;
          st_trans := transition select (| (EHdr (Hdr_sz := sz) HdrIP)[43 -- 40] |) {{
            [| exact #b|0|0|0|1 |] ==> accept ;;;
            [| exact #b|0|0|0|0 |] ==> inl ParseSuf ;;;
             reject
          }};
      |}
    | ParseSuf => {|
      st_op := extract(HdrPref);
      st_trans := transition accept;
    |}
    end.

  Program Definition aut: Syntax.t state sz :=
    {| t_states := states |}.
  Solve Obligations with (destruct s || destruct h; cbv; Lia.lia).

End UDPCombined.

Module IPFilter.
  Definition aut := Sum.sum UDPCombined.aut UDPInterleaved.aut.
End IPFilter.


Require Import MirrorCore.syms.SymEnv.
Require Import MirrorCore.Lambda.ExprCore.
Require Import ExtLib.Core.RelDec.
Require Import MirrorCore.TypesI.
Require Import ExtLib.Tactics.
Require Import ExtLib.Data.Fun.
(*Require Import VST.progs.list_dt.*)
Require Import VST.floyd_funcs.
Require Import mc_reify.types.
Require Import mc_reify.bool_funcs.
Require Import MirrorCharge.ModularFunc.ILogicFunc.
Require Import MirrorCharge.ModularFunc.BILogicFunc.
Require Import VST.floyd.local2ptree.
Require Import mc_reify.local2list.

Inductive const :=
| fN : nat -> const
| fZ : Z -> const
| fint : int -> const
| fint64 : int64 -> const
| fPos : positive -> const
| fident : ident -> const
| fCtype : type -> const
| fCexpr : expr -> const
| fComparison : comparison -> const
| fbool : bool -> const
| ffloat : float -> const
| ffloat32 : float32 -> const
| fenv : type_id_env -> const
| fllrr : LLRR -> const
.

Definition typeof_const (c : const) : typ :=
 match c with
| fN _ => tynat
| fZ _ => tyZ
| fPos _ => typositive
| fident _ => tyident
| fCtype _ => tyc_type
| fCexpr _ => tyc_expr
| fComparison _ => tycomparison
| fbool _ => tybool
| fint _ => tyint
| fint64 _ => tyint64
| ffloat _ => tyfloat
| ffloat32 _ => tyfloat32
| fenv _ => tytype_id_env
| fllrr _ => tyllrr
end.

Definition constD (c : const)
: typD (typeof_const c) :=
match c with
| fN c | fZ c | fPos c | fident c | fCtype c | fCexpr c | fComparison c | fbool c | fint c
| fint64 c | ffloat c | ffloat32 c | fenv c | fllrr c
                                          => c
end.

(*
Instance RelDec_type_eq : RelDec (@eq type) :=
{ rel_dec := eqb_type }.

Instance RelDec_const_eq : RelDec (@eq const) :=
{ rel_dec := fun (a b : const) =>
               match a , b with
| N c1,  N c2 | Z c1,  Z c2 | Pos c1,  Pos c2 | Ctype c1,  Ctype c2
| Cexpr c1,  Cexpr c2 | Comparison c1,  Comparison c2 => c1 ?[ eq ] c2
| _, _ => false
end}.*)

Inductive z_op :=
| fZ_lt
| fZ_le
| fZ_gt
| fZ_ge
| fZ_add
| fZ_sub
| fZ_mul
| fZ_div
| fZ_mod
| fZ_land
| fZ_max
| fZ_opp.

Definition typeof_z_op z : typ :=
match z with
| fZ_lt
| fZ_le
| fZ_gt
| fZ_ge => (tyArr tyZ (tyArr tyZ typrop))
| fZ_add
| fZ_sub
| fZ_mul
| fZ_div
| fZ_mod
| fZ_land
| fZ_max => (tyArr tyZ (tyArr tyZ tyZ))
| fZ_opp => (tyArr tyZ tyZ)
end.

Definition z_opD (z : z_op) : typD  (typeof_z_op z) :=
match z with
| fZ_lt => Z.lt
| fZ_le => Z.le
| fZ_gt => Z.gt
| fZ_ge => Z.ge
| fZ_add => Z.add
| fZ_sub => Z.sub
| fZ_mul => Z.mul
| fZ_div => Z.div
| fZ_mod => Zmod
| fZ_land => Z.land
| fZ_max => Z.max
| fZ_opp => Z.opp
end.

(*Instance RelDec_func_eq : RelDec (@eq func) :=
{ rel_dec := fun (a b : func) =>
               match a , b with
                 | Plus , Plus => true*)

Inductive int_op :=
| fint_add
| fint_and
| fint_lt
| fint_ltu
| fint_mul
| fint_neg
| fint_sub
| fint_cmp
| fint_cmpu
| fint_repr
| fint_signed
| fint_unsigned
| fint_max_unsigned
| fint64_repr.

Definition typeof_int_op i : typ :=
match i with
| fint_lt
| fint_ltu => tyArr tyint (tyArr tyint tybool)
| fint_mul
| fint_sub
| fint_add => tyArr tyint (tyArr tyint tyint)
| fint_and => tyArr tyint (tyArr tyint tyint)
| fint_neg => tyArr tyint tyint
| fint_cmp
| fint_cmpu => tyArr tycomparison (tyArr tyint (tyArr tyint tybool))
| fint_repr => tyArr tyZ tyint
| fint_signed
| fint_unsigned  => tyArr tyint tyZ
| fint_max_unsigned => tyZ
| fint64_repr => tyArr tyZ tyint64
end.

Definition int_opD (i : int_op): typD  (typeof_int_op i) :=
match i with
| fint_add => Int.add
| fint_and => Int.and
| fint_lt => Int.lt
| fint_ltu => Int.ltu
| fint_mul => Int.mul
| fint_neg => Int.neg
| fint_sub => Int.sub
| fint_cmp => Int.cmp
| fint_cmpu => Int.cmpu
| fint_repr => Int.repr
| fint_signed => Int.signed
| fint_unsigned => Int.unsigned
| fint_max_unsigned => Int.max_unsigned
| fint64_repr => Int64.repr
end.

Inductive values :=
| fVint
| fVfloat
| fVlong
| fVptr
| fVundef
| fVsingle.

Definition typeof_value (v : values) :=
match v with
| fVint => tyArr tyint tyval
| fVfloat => tyArr tyfloat tyval
| fVlong => tyArr tyint64 tyval
| fVptr => tyArr typositive (tyArr tyint tyval)
| fVsingle => tyArr tyfloat32 tyval
| fVundef => tyval
end.

Definition valueD  (v : values): typD  (typeof_value v) :=
match v with
| fVint => Vint
| fVfloat => Vfloat
| fVlong => Vlong
| fVptr => Vptr
| fVsingle => Vsingle
| fVundef => Vundef
end.

Inductive eval :=
| feval_cast : type -> type -> eval
| fderef_noload : type -> eval
| feval_field : type -> ident -> eval
| feval_binop : binary_operation -> type -> type -> eval
| feval_unop : unary_operation -> type -> eval
| feval_id : ident -> eval.

Definition typeof_eval (e : eval) :=
 match e with
| feval_cast _ _ => (tyArr tyval tyval)
| fderef_noload _ => (tyArr tyval tyval)
| feval_field _ _ => (tyArr tyval tyval)
| feval_binop _ _ _=> (tyArr tyval (tyArr tyval tyval))
| feval_unop _ _ => (tyArr tyval tyval)
| feval_id _  => (tyArr tyenviron tyval)
end.

Definition evalD  (e : eval) : typD  (typeof_eval e) :=
match e with
| feval_id id => eval_id id
| feval_cast t1 t2 => eval_cast t1 t2
| fderef_noload t => deref_noload t
| feval_field t id => eval_field t id
| feval_binop op t1 t2 => eval_binop op t1 t2
| feval_unop op t => eval_unop op t
end.

(*TODO: classify these better*)
Inductive other :=
| ftwo_power_nat
| fforce_ptr
| fand
| falign
| ftyped_true
| feq : typ -> other
| fnone : typ -> other
| fsome : typ -> other
| ftypeof
| fTrue
| fFalse
.

Definition typeof_other (o : other) :=
match o with
| ftwo_power_nat => tyArr tynat tyZ
| fforce_ptr  => tyArr tyval tyval
| fand => tyArr typrop (tyArr typrop typrop)
| falign => tyArr tyZ (tyArr tyZ tyZ)
| ftyped_true => tyArr tyc_type (tyArr tyval typrop)
| feq t => tyArr t (tyArr t typrop)
| fnone t => tyoption t
| fsome t => tyArr t (tyoption t)
| ftypeof => tyArr tyc_expr tyc_type
| fTrue | fFalse => typrop
end.

Definition otherD  (o : other) : typD  (typeof_other o) :=
match o with
| ftwo_power_nat => (two_power_nat : typD (typeof_other ftwo_power_nat))
| fforce_ptr => force_ptr
| fand => and
| falign => align
| ftyped_true => typed_true
| feq t => @eq (typD t)
| fsome t => @Some (typD t)
| fnone t => @None (typD t)
| ftypeof => typeof
| fTrue => True
| fFalse => False
end.

Inductive data :=
| fnil : typ -> data
| fmap : typ -> typ -> data
| ffold_right : typ -> typ -> data
| ffold_left : typ -> typ -> data
| fcons : typ -> data
| fappend : typ -> data
| fnth_error : typ -> nat -> data
| freplace_nth : typ -> nat -> data
| fpair : typ -> typ -> data
| fget : typ -> positive -> data
| fset : typ -> positive -> data
| fleaf : typ -> data
| fnode : typ -> data
| fempty : typ -> data
.

Definition typeof_data (l : data) :=
match l with
| fmap a b => tyArr (tyArr a b) (tyArr (tylist a) (tylist b))
| fnil a => (tylist a)
| ffold_right a b => tyArr (tyArr b (tyArr a a)) (tyArr a (tyArr (tylist b) a))
| ffold_left a b => tyArr (tyArr a (tyArr b a)) (tyArr (tylist b) (tyArr a a))
| fcons a => tyArr a (tyArr (tylist a) (tylist a))
| fappend a => tyArr (tylist a) (tyArr (tylist a) (tylist a))
| fnth_error a _ => tyArr (tylist a) (tyoption a)
| freplace_nth a _ => tyArr (tylist a) (tyArr a (tylist a))
| fpair t1 t2 => tyArr t1 (tyArr t2 (typrod t1 t2))
| fleaf t => typtree t
| fnode t => tyArr (typtree t) (tyArr (tyoption t) (tyArr (typtree t) (typtree t)))
| fset t _ => tyArr t (tyArr (typtree t) (typtree t))
| fget t _ => (tyArr (typtree t) (tyoption t))
| fempty t => typtree t
end.

Definition dataD (l : data) : typD (typeof_data l) :=
match l with
| fmap t1 t2 => @map (typD  t1) (typD  t2)
| fnil t => (@nil (typD t) : typD (typeof_data (fnil t)))
| ffold_right a b => @fold_right (typD a) (typD b)
| ffold_left a b => @fold_left (typD a) (typD b)
| fcons a => @cons (typD a)
| fappend a => @app (typD a)
| fnth_error a n => fun l => @nth_error (typD a) l n
| freplace_nth a n => @canon.replace_nth (typD a) n
| fpair a b => ((@pair (typD a) (typD b)) : typD (typeof_data (fpair a b)))
| fleaf t => @PTree.Leaf (typD t)
| fnode t => @PTree.Node (typD t)
| fset t p => @PTree.set (typD t) p
| fget t p => @PTree.get (typD t) p
| fempty t => @PTree.empty (typD t)
end.

Inductive sep :=
| flocal
| fprop
| fdata_at : type -> sep
| ffield_at : type -> list gfield -> sep
| fproj_val : type -> sep
| fupd_val : type -> sep
(*| flseg : forall (t: type) (i : ident), listspec t i -> sep*)
.

Fixpoint reptyp (ty: type) : typ :=
  match ty with
  | Tvoid => tyunit
  | Tint _ _ _ => tyval
  | Tlong _ _ => tyval
  | Tfloat _ _ => tyval
  | Tpointer t1 a => tyval
  | Tarray t1 sz a => tylist (reptyp t1)
  | Tfunction t1 t2 _ => tyunit
  | Tstruct id fld a => reptyp_structlist fld
  | Tunion id fld a => reptyp_unionlist fld
  | Tcomp_ptr id a => tyval
  end
with reptyp_structlist (fld: fieldlist) : typ :=
  match fld with
  | Fnil => tyunit
  | Fcons id ty fld' =>
    if is_Fnil fld'
      then reptyp ty
      else typrod (reptyp ty) (reptyp_structlist fld')
  end
with reptyp_unionlist (fld: fieldlist) : typ :=
  match fld with
  | Fnil => tyunit
  | Fcons id ty fld' =>
    if is_Fnil fld'
      then reptyp ty
      else tysum (reptyp ty) (reptyp_unionlist fld')
  end.

Definition typeof_sep (s : sep) : typ :=
match s with
| fdata_at t => tyArr tyshare (tyArr (reptyp t) (tyArr tyval tympred))
| ffield_at t gfs => tyArr tyshare (tyArr (reptyp (nested_field_type2 t gfs)) (tyArr tyval tympred))
(*| flseg t i l => tyArr tyshare (tyArr (tylist (reptyp_structlist (@all_but_link i (list_fields))))
                                      (tyArr tyval (tyArr tyval tympred)))*)
| flocal => tyArr (tyArr tyenviron typrop) (tyArr tyenviron tympred)
| fprop => tyArr typrop tympred
| fproj_val t => tyArr (tylist tygfield)
                 (tyArr (reptyp t) tyval)
| fupd_val t => tyArr (tylist tygfield)
                 (tyArr (reptyp t)
                  (tyArr tyval (reptyp t)))
end.

Definition proj1T {A} {B} (x: A /\ B) :=
  match x with
  | conj y z => y
  end.

Definition proj2T {A} {B} (x: A /\ B) :=
  match x with
  | conj y z => z
  end.

Definition typD_reptyp_reptype: forall t, typD  (reptyp t) = reptype t.
Proof.
  intros.
  apply (type_mut (fun t => typD (reptyp t) = reptype t)
                  (fun tl => True)
                  (fun fld => typD (reptyp_structlist fld) = reptype_structlist fld /\
                              typD (reptyp_unionlist fld) = reptype_unionlist fld));
  try reflexivity; intros.
  + simpl.
    rewrite H.
    reflexivity.
  + simpl.
    apply (proj1T H).
  + simpl.
    apply (proj2T H).
  + split; reflexivity.
  + split; simpl.
    - destruct (is_Fnil f); simpl; rewrite H; try rewrite (proj1T H0); reflexivity.
    - destruct (is_Fnil f); simpl; rewrite H; try rewrite (proj2T H0); reflexivity.
Defined.

Definition reptyp_reptype ty (v: typD  (reptyp ty)): reptype ty :=
  eq_rect_r (fun x => x) v (eq_sym (typD_reptyp_reptype ty)).

Definition reptype_reptyp ty (v: reptype ty): typD  (reptyp ty) :=
  eq_rect_r (fun x => x) v (typD_reptyp_reptype ty).

Lemma reptyp_reptype_reptype_reptyp: forall t v, reptyp_reptype t (reptype_reptyp t v) = v.
Proof.
  intros.
  unfold reptyp_reptype, reptype_reptyp.
  unfold eq_rect_r.
  generalize (typD_reptyp_reptype t).
  revert v.
  rewrite (typD_reptyp_reptype t).
  intros.
  rewrite <- !eq_rect_eq.
  reflexivity.
Qed.

(*
Fixpoint reptyp_reptype  ty {struct ty} : typD  (reptyp ty) -> reptype ty :=
  match ty as ty0 return (typD  (reptyp ty0) -> reptype ty0) with
    | Tvoid => fun x : unit => x
    | Tint i s a => fun x : val => x
    | Tlong s a => fun x : val => x
    | Tfloat f a => fun x : val => x
    | Tpointer t a => fun x : val => x
    | Tarray t z a => map (reptyp_reptype  t)
    | Tfunction t t0 c => fun x : unit => x
    | Tstruct i f a => reptyp_structlist_reptype  f
    | Tunion i f a => reptyp_unionlist_reptype  f
    | Tcomp_ptr i a => fun x : val => x
  end
with reptyp_structlist_reptype  fl {struct fl} : typD  (reptyp_structlist fl) -> reptype_structlist fl :=
  match
    fl as fl0
    return (typD  (reptyp_structlist fl0) -> reptype_structlist fl0)
  with
    | Fnil => fun x : typD  (reptyp_structlist Fnil) => x
    | Fcons i t fl0 =>
      let b := is_Fnil fl0 in
      if b as b0
         return
         (typD
               (if b0
                then reptyp t
                else typrod (reptyp t) (reptyp_structlist fl0)) ->
          if b0
          then reptype t
          else (reptype t * reptype_structlist fl0)%type)
      then reptyp_reptype  t
      else
        fun x : typD  (reptyp t) * typD  (reptyp_structlist fl0) =>
          (reptyp_reptype  t (fst x),
           reptyp_structlist_reptype  fl0 (snd x))
  end
with reptyp_unionlist_reptype  fl {struct fl} : typD  (reptyp_unionlist fl) -> reptype_unionlist fl :=
match
     fl as fl0
     return (typD  (reptyp_unionlist fl0) -> reptype_unionlist fl0)
   with
   | Fnil => fun x : typD  (reptyp_unionlist Fnil) => x
   | Fcons i t fl0 =>
       let b := is_Fnil fl0 in
       if b as b0
        return
          (typD
             (if b0
              then reptyp t
              else tysum (reptyp t) (reptyp_unionlist fl0)) ->
           if b0 then reptype t else (reptype t + reptype_unionlist fl0)%type)
       then reptyp_reptype  t
       else
        fun x : typD  (reptyp t) + typD  (reptyp_unionlist fl0) =>
        match x with
        | inl y => inl (reptyp_reptype  t y)
        | inr y => inr (reptyp_unionlist_reptype  fl0 y)
        end
   end.

Fixpoint reptype_reptyp ty {struct ty} : reptype ty -> typD (reptyp ty) :=
  match ty as ty0 return (reptype ty0 -> typD  (reptyp ty0)) with
    | Tvoid => fun x : unit => x
    | Tint i s a => fun x : val => x
    | Tlong s a => fun x : val => x
    | Tfloat f a => fun x : val => x
    | Tpointer t a => fun x : val => x
    | Tarray t z a => map (reptype_reptyp  t)
    | Tfunction t t0 c => fun x : unit => x
    | Tstruct i f a => reptype_structlist_reptyp  f
    | Tunion i f a => reptype_unionlist_reptyp  f
    | Tcomp_ptr i a => fun x : val => x
  end
with reptype_structlist_reptyp fl {struct fl} : reptype_structlist fl -> typD (reptyp_structlist fl) :=
  match
    fl as fl0
    return (reptype_structlist fl0 -> typD  (reptyp_structlist fl0))
  with
    | Fnil => fun x : reptype_structlist Fnil => x
    | Fcons i t fl0 =>
      let b := is_Fnil fl0 in
      if b as b0
         return
         ((if b0
          then reptype t
          else (reptype t * reptype_structlist fl0)%type) ->
          typD
               (if b0
                then reptyp t
                else typrod (reptyp t) (reptyp_structlist fl0)))
      then reptype_reptyp t
      else
        fun x : (reptype t * reptype_structlist fl0)%type =>
          (reptype_reptyp t (fst x),
           reptype_structlist_reptyp fl0 (snd x))
  end
with reptype_unionlist_reptyp  fl {struct fl} : reptype_unionlist fl -> typD  (reptyp_unionlist fl) :=
match
     fl as fl0
     return (reptype_unionlist fl0 -> typD  (reptyp_unionlist fl0))
   with
   | Fnil => fun x : reptype_unionlist Fnil => x
   | Fcons i t fl0 =>
       let b := is_Fnil fl0 in
       if b as b0
        return
          ((if b0 then reptype t else (reptype t + reptype_unionlist fl0)%type) ->
           typD
             (if b0
              then reptyp t
              else tysum (reptyp t) (reptyp_unionlist fl0)))
       then reptype_reptyp t
       else
        fun x : (reptype t + reptype_unionlist fl0)%type =>
        match x with
        | inl y => inl (reptype_reptyp t y)
        | inr y => inr (reptype_unionlist_reptyp fl0 y)
        end
   end.

Lemma reptyp_reptype_reptype_reptyp: forall t v, reptyp_reptype t (reptype_reptyp t v) = v.
Proof.
  intros.
  eapply (type_mut
    (fun t => forall v, reptyp_reptype t (reptype_reptyp t v) = v)
    (fun tl => True)
    (fun fld => (forall v, reptyp_structlist_reptype fld (reptype_structlist_reptyp fld v) = v) /\
                (forall v, reptyp_unionlist_reptype fld (reptype_unionlist_reptyp fld v) = v)));
  intros; simpl; auto.
  + rewrite map_map.
    induction v0; simpl; auto.
    rewrite H, IHv0.
    reflexivity.
  + apply (proj1 H).
  + apply (proj2 H).
  + split.
    - if_tac; [apply H |].
      intros.
      unfold fst, snd.
      rewrite H, (proj1 H0).
      destruct v0; reflexivity.
    - if_tac; [apply H |].
      intros.
      destruct v0; [rewrite H; auto |].
      rewrite (proj2 H0).
      reflexivity.
Qed.
*)
Definition sepD  (s : sep) : typD  (typeof_sep s).
refine
match s with
| flocal => (local : typD (typeof_sep flocal))
| fprop => prop
| fdata_at ty =>  _ (*fun sh (t : reptype ty) v => data_at sh ty t v *)
| ffield_at t ids => _
| fproj_val ty => _
| fupd_val ty => _
(*| flseg t id ls => _*)
end.
{ simpl. intros sh rt v.
  exact (data_at sh ty (reptyp_reptype  _ rt) v). }
{ simpl. intros sh ty v.
  exact (field_at sh t ids (reptyp_reptype  _ ty) v). }
{ simpl. intros gfs v.
  exact (proj_val ty gfs (reptyp_reptype  _ v)). }
{ simpl. intros gfs v v0.
  exact (reptype_reptyp _ (upd_val ty gfs (reptyp_reptype _ v) v0)). }
(*{ simpl.
  intros sh lf v1 v2.
  exact (@lseg t id ls sh (List.map (reptyp_structlist_reptype  _) lf) v1 v2). }*)
Defined.

Inductive smx :=
| fenviron : environ -> smx
| fsemax
| fstatement : statement -> smx
| fretassert : ret_assert -> smx
| ftycontext : PTree.t (type * bool) -> PTree.t type -> type -> PTree.t type ->  smx
| fupdate_tycon
(*| fPROPx
| fLOCALx
| fSEPx *)
| fnormal_ret_assert
(*| flocalD : PTree.t val -> PTree.t (type * val) -> list (environ -> Prop) -> smx *)
| fassertD
| flocalD
| fvaltree : PTree.t val -> smx
| fdenote_tc_assert_b_norho
| ftc_expr_b_norho
| ftc_temp_id_b_norho : positive -> type ->  smx
(*| fmsubst_eval_expr_norho*)
(*| fmsubst_eval_lvalue_norho*)
| flater
| flater_lift
| fnested_field_type2
| fis_neutral_cast
| fmsubst_efield_denote : list efield -> smx
| flegal_nested_efield : list type -> smx
| fmsubst_eval_LR
| ftc_LR_b_norho
| ftc_environ
| ftc_efield_b_norho : list efield -> smx
| fnested_efield
| ftypeof_temp
| ftc_val
| flegal_nested_field
| fstruct_field
| funion_field
| farray_subsc
| fwritable_share
| fTsh
| fEws
| ftype_is_by_value
.

Definition typeof_smx (t : smx) :=
match t with
| fsemax => tyArr tyOracleKind (tyArr tytycontext (tyArr (tyArr tyenviron tympred) (tyArr tystatement (tyArr tyret_assert typrop))))
| fstatement s => tystatement
| fretassert r => tyret_assert
| ftycontext _ _ _ _ => tyArr (typtree tyfunspec) tytycontext
(*| fPROPx => tyArr (tylist typrop) (tyArr (tyArr tyenviron tympred) (tyArr tyenviron tympred))
| fLOCALx => tyArr (tylist (tyArr tyenviron typrop)) (tyArr (tyArr tyenviron tympred) (tyArr tyenviron tympred))
| fSEPx => tyArr (tylist (tyArr tyenviron tympred)) (tyArr tyenviron tympred)*)
| fnormal_ret_assert => tyArr (tyArr tyenviron tympred) (tyret_assert)
| fenviron e => tyenviron
| flocalD  => tyArr (typtree tyval)
                    (tyArr (typtree (typrod tyc_type tyval)) (tylist (tyArr tyenviron typrop)))
| fupdate_tycon => tyArr tytycontext (tyArr tystatement tytycontext)
| fvaltree t => typtree tyval
| fassertD => tyArr  (tylist typrop) (tyArr (tylist (tyArr tyenviron typrop)) (tyArr (tylist tympred) (tyArr tyenviron tympred)))
| fdenote_tc_assert_b_norho => tyArr tytc_assert tybool
| ftc_expr_b_norho => tyArr tytycontext (tyArr tyc_expr tybool)
| ftc_temp_id_b_norho _ _  => tyArr tytycontext (tyArr tyc_expr tybool)
(*| fmsubst_eval_expr_norho => tyArr (typtree tyval) (tyArr (typtree (typrod tyc_type tyval)) (tyArr tyc_expr (tyoption tyval)))*)
(*| fmsubst_eval_lvalue_norho =>  tyArr (typtree tyval) (tyArr (typtree (typrod tyc_type tyval)) (tyArr tyc_expr (tyoption tyval)))*)
| flater => tyArr tympred tympred
| flater_lift => tyArr (tyArr tyenviron tympred) (tyArr tyenviron tympred)
| fnested_field_type2 => tyArr tyc_type (tyArr (tylist tygfield) tyc_type)
| fis_neutral_cast => tyArr tyc_type (tyArr tyc_type tybool)
| fmsubst_efield_denote _ => tyArr (typtree tyval)
                           (tyArr (typtree (typrod tyc_type tyval))
                                 (tyoption (tylist tygfield)))
| flegal_nested_efield _ => tyArr tytype_id_env
                          (tyArr tyc_type
                           (tyArr tyc_expr
                            (tyArr (tylist tygfield)
                              (tyArr tyllrr tybool))))
| fmsubst_eval_LR => tyArr (typtree tyval)
                     (tyArr (typtree (typrod tyc_type tyval))
                      (tyArr tyc_expr
                       (tyArr tyllrr (tyoption tyval))))
| ftc_LR_b_norho => tyArr tytycontext (tyArr tyc_expr (tyArr tyllrr tybool))
| ftc_environ => tyArr tytycontext (tyArr tyenviron typrop)
| ftc_efield_b_norho efs => tyArr tytycontext tybool
| fnested_efield => tyArr tyc_expr
                    (tyArr (tylist tyefield)
                     (tyArr (tylist tyc_type) tyc_expr))
| ftypeof_temp => tyArr tytycontext (tyArr tyident (tyoption tyc_type))
| ftc_val => tyArr tyc_type (tyArr tyval typrop)
| flegal_nested_field => tyArr tyc_type (tyArr (tylist tygfield) typrop)
| fstruct_field => tyArr tyident tygfield
| funion_field => tyArr tyident tygfield
| farray_subsc => tyArr tyZ tygfield
| fwritable_share => tyArr tyshare typrop
| fTsh => tyshare
| fEws => tyshare
| ftype_is_by_value => tyArr tyc_type tybool
end.

Definition smxD (t : smx) : typD (typeof_smx t) :=
match t with
| fsemax => (@semax : typD (typeof_smx fsemax))
| fstatement s | fretassert s  => s
| ftycontext t v r gt => fun gf => mk_tycontext t v r gt gf
(*| fPROPx => PROPx
| fLOCALx => LOCALx
| fSEPx => SEPx*)
| fnormal_ret_assert => normal_ret_assert
| fenviron e => (e : typD (typeof_smx (fenviron e)))
| flocalD => localD
| fupdate_tycon => update_tycon
| fvaltree t => t
| fassertD => assertD
| fdenote_tc_assert_b_norho => (denote_tc_assert_b_norho : typD (typeof_smx fdenote_tc_assert_b_norho))
| ftc_expr_b_norho => tc_expr_b_norho
| ftc_temp_id_b_norho id ty  => tc_temp_id_b_norho id ty
(*| fmsubst_eval_expr_norho => msubst_eval_expr*)
(*| fmsubst_eval_lvalue_norho => msubst_eval_lvalue*)
| flater => later
| flater_lift => later
| fnested_field_type2 => nested_field_type2
| fis_neutral_cast => is_neutral_cast
| fmsubst_efield_denote efs => (fun T1 T2 => msubst_efield_denote T1 T2 efs)
| flegal_nested_efield tts => (fun e t_root e1 gfs => legal_nested_efield e t_root e1 gfs tts)
| fmsubst_eval_LR => msubst_eval_LR
| ftc_LR_b_norho => tc_LR_b_norho
| ftc_environ => tc_environ
| ftc_efield_b_norho efs => (fun tycon => tc_efield_b_norho tycon efs)
| fnested_efield => nested_efield
| ftypeof_temp => typeof_temp
| ftc_val => tc_val
| flegal_nested_field => legal_nested_field
| fstruct_field => StructField
| funion_field => UnionField
| farray_subsc => ArraySubsc
| fwritable_share => writable_share
| fTsh => SeparationLogic.Tsh
| fEws => assert_lemmas.Ews
| ftype_is_by_value => client_lemmas.type_is_by_value
end.

Inductive func' :=
| Const : const -> func'
| Zop : z_op -> func'
| Intop : int_op -> func'
| Value : values -> func'
| Eval_f : eval -> func'
| Other : other -> func'
| Sep : sep -> func'
| Data : data -> func'
| Smx : smx -> func'.

Definition func := (SymEnv.func + @ilfunc typ + @bilfunc typ + func')%type.

Definition typeof_func (f: func') : typ :=
match f with
| Const c => typeof_const c
| Zop z => typeof_z_op z
| Intop i => typeof_int_op i
| Value v => typeof_value v
| Eval_f e => typeof_eval e
| Other o => typeof_other o
| Sep s => typeof_sep s
| Data l => typeof_data l
| Smx t => typeof_smx t
end.

Definition funcD  (f : func') : typD  (typeof_func f) :=
match f with
| Const c => constD  c
| Zop z => z_opD  z
| Intop i => int_opD  i
| Value v => valueD  v
| Eval_f e => evalD  e
| Other o => otherD  o
| Sep s => sepD  s
| Data l => dataD l
| Smx t => smxD t
end.


(** * Usual constructive Dedekind cuts *)
(** Catherine LELAY. July 2017 *)
(** This file formalizes the usual definitions of constructive Dedekind cuts.
- The two-sided definition come from the HoTT-book
- The one-sided definition come from Robert S Lubarsky and Michael Rathjen. On the constructive
Dedekind reals. Logic and Analysis.

I first prove the equivalence between these two definitions, then I prove the equivalence between
the non-negative numbers of the one-sided definition and the set Dcuts *)

Require Export UniMath.NumberSystems.RationalNumbers.
Require Import UniMath.RealNumbers.Prelim.
Require Import UniMath.RealNumbers.NonnegativeRationals.
Require Import UniMath.RealNumbers.NonnegativeReals.

Unset Kernel Term Sharing.

(** ** Usual definitions *)

Local Open Scope hq_scope.

Definition isTwoSided (L U : hq → hProp) : UU :=
  ((∏ q : hq, L q <-> ∃ r : hq, L r ∧ hqlth q r)
     × (∏ q : hq, U q <-> ∃ r : hq, U r ∧ hqlth r q))
    × ((∃ q : hq, L q) × (∃ q : hq, U q))
    × (∏ q : hq, ¬ (U q ∧ L q))
    × (∏ q r : hq, hqlth q r → L q ∨ U r).

Definition isOneSided (S : hq → hProp) : UU :=
  ((∃ r : hq, S r) ∧ (∃ r : hq, ¬ S r))
    × (∏ r : hq, S r → ∃ q : hq, S q ∧ hqlth r q)
    × (∏ r s : hq, hqlth r s → S r ∨ ¬ S s).

(** ** Equivalence between these two definitions *)

Lemma isTwoSided_OneSided :
  ∏ (L U : hq → hProp), isTwoSided L U → isOneSided L.
Proof.
  intros L U H.
  split ; split.
  - exact (pr1 (pr1 (pr2 H))).
  - generalize (pr1 (pr2 (pr2 H))) (pr2 (pr1 (pr2 H))) ; intros H0.
    apply hinhfun.
    intros q.
    exists (pr1 q).
    intros Lq.
    apply (H0 (pr1 q)).
    split.
    + exact (pr2 q).
    + exact Lq.
  - intros r Lr.
    generalize (pr1 (pr1 H)) ; intros H0.
    exact (pr1 (H0 r) Lr).
  - intros r s Hrs.
    generalize (pr1 (pr2 (pr2 H))) (pr2 (pr2 (pr2 H))) ; intros H0 H1.
    generalize (H1 _ _ Hrs).
    apply hinhfun, sumofmaps.
    + exact ii1.
    + intros Us.
      apply ii2.
      intros Ls.
      apply (H0 s).
      split.
      * exact Us.
      * exact Ls.
Qed.

Lemma isOneSided_TwoSided :
  ∏ (S : hq → hProp),
  isOneSided S → isTwoSided S (λ s : hq, ∃ r : hq, hqlth r s × ¬ S r).
Proof.
  intros S H.
  split ; split ; [ | | split | split].
  - intros q ; split.
    + exact (pr1 (pr2 H) q).
    + apply hinhuniv ; intros r.
      generalize (pr2 (pr2 H) _ _ (pr2 (pr2 r))).
      apply hinhuniv, sumofmaps.
      * intros Sq ; apply Sq.
      * intros Sr.
        apply fromempty.
        apply Sr, (pr1 (pr2 r)).
  - intros q ; split.
    + apply hinhfun.
      intros r.
      set (s := Prelim.hqlth_between _ _ (pr1 (pr2 r))).
      exists (pr1 s).
      split.
      * apply hinhpr.
        exists (pr1 r).
        { split.
          - exact (pr1 (pr2 s)).
          - exact (pr2 (pr2 r)).
        }
      * exact (pr2 (pr2 s)).
    + apply hinhuniv.
      intros r.
      generalize (pr1 (pr2 r)).
      apply hinhfun.
      intros s.
      exists (pr1 s).
      split.
      * apply istranshqlth with (pr1 r).
        ** exact (pr1 (pr2 s)).
        ** exact (pr2 (pr2 r)).
      * exact (pr2 (pr2 s)).
  - exact (pr1 (pr1 H)).
  - generalize (pr2 (pr1 H)).
    apply hinhfun.
    intros r.
    exists (pr1 r+1).
    apply hinhpr.
    exists (pr1 r).
    split.
    + exact (hqlthnsn _).
    + exact (pr2 r).
  - intros q Hq.
    generalize (pr1 Hq).
    apply (hinhuniv (P := make_hProp _ isapropempty)).
    intros r.
    generalize (pr2 (pr2 H) _ _ (pr1 (pr2 r))).
    apply hinhuniv, sumofmaps.
    + exact (pr2 (pr2 r)).
    + intros Sq ; apply Sq.
      exact (pr2 Hq).
  - intros q r Hqr.
    set (s := Prelim.hqlth_between _ _ Hqr).
    generalize (pr2 (pr2 H) _ _ (pr1 (pr2 s))).
    apply hinhfun, sumofmaps.
    + exact ii1.
    + intros Sr.
      apply ii2, hinhpr.
      exists (pr1 s).
      split.
      * exact (pr2 (pr2 s)).
      * exact Sr.
Qed.

Lemma weqTwoSidedOneSided :
  (∑ L U : hq → hProp, isTwoSided L U) ≃ (∑ S : hq → hProp, isOneSided S).
Proof.
  set (f := (λ (LU : ∑ L U : hq → hProp, isTwoSided L U),
            pr1 LU,, isTwoSided_OneSided (pr1 LU) (pr1 (pr2 LU)) (pr2 (pr2 LU)))
            : (∑ L U : hq → hProp, isTwoSided L U) → ∑ S, isOneSided S).
  set (g := (λ S : (∑ S : hq → hProp, isOneSided S),
                   pr1 S ,, (λ s : hq, ∃ r : hq, r < s × ¬ pr1 S r)
                       ,, isOneSided_TwoSided (pr1 S) (pr2 S))
            : (∑ S, isOneSided S) → ∑ L U : hq → hProp, isTwoSided L U).
  apply (weq_iso f g).
  - intros LU.
    change (pr1 (g (f LU)),, pr2 (g (f LU)) = pr1 LU,, pr2 LU).
    apply pair_path_in2.
    simple refine (subtypePath_prop (B := λ _, make_hProp _ _) _).
    + apply isapropdirprod.
      * apply isapropdirprod ;
          apply impred_isaprop ; intro q ;
         apply isapropdirprod ; apply isapropimpl, propproperty.
      * apply isapropdirprod.
        ** apply isapropdirprod ; apply propproperty.
        ** apply isapropdirprod.
           *** apply impred_isaprop ; intro q.
               apply isapropneg.
           *** apply impred_isaprop ; intro q.
               apply impred_isaprop ; intro r.
               apply isapropimpl, propproperty.
    + apply funextfun ; intros q.
      apply hPropUnivalence.
      * apply hinhuniv.
        intros r.
        generalize (pr2 (pr2 (pr2 (pr2 (pr2 LU)))) _ _ (pr1 (pr2 r))).
        apply hinhuniv, sumofmaps.
        { intro Lr ; apply fromempty, (pr2 (pr2 r)), Lr. }
        intros Uq ; apply Uq.
      * intros Uq.
        generalize (pr1 (pr2 (pr1 (pr2 (pr2 LU))) _) Uq).
        apply hinhfun.
        intros r.
        exists (pr1 r).
        split.
        ** apply (pr2 (pr2 r)).
        ** intros Lr.
           apply (pr1 (pr2 (pr2 (pr2 (pr2 LU)))) (pr1 r)).
           split.
           *** apply (pr1 (pr2 r)).
           *** apply Lr.
  - intros S.
    simple refine (subtypePath_prop (B := λ _, make_hProp _ _) _).
    + apply isapropdirprod.
      * apply propproperty.
      * apply isapropdirprod.
        ** apply impred_isaprop ; intro r.
           apply isapropimpl, propproperty.
        ** apply impred_isaprop ; intro r.
           apply impred_isaprop ; intro s.
           apply isapropimpl, propproperty.
    + reflexivity.
Qed.

(** ** Equivalence of Dcuts with usual definitions *)

Lemma isOneSided_Dcuts_bot :
  ∏ D, isOneSided D → Dcuts_def_bot (λ r, D (pr1 r)).
Proof.
  intros D H r Dr q Hq.
  generalize (le_eqorltNonnegativeRationals _ _ Hq) ; clear Hq.
  apply sumofmaps ; intros H0.
  - rewrite H0.
    exact Dr.
  - rewrite ltNonnegativeRationals_correct in H0.
    generalize (pr2 (pr2 H) _ _ H0).
    apply hinhuniv, sumofmaps ; intros Dq.
    + exact Dq.
    + apply fromempty, Dq, Dr.
Qed.
Lemma isOneSided_Dcuts_open :
  ∏ D, isOneSided D → Dcuts_def_open (λ r, D (pr1 r)).
Proof.
  intros D H r Dr.
  generalize ((pr1 (pr2 H)) (pr1 r) Dr).
  apply hinhfun.
  intros q.
  assert (Hq : 0 <= pr1 q).
  { apply istranshqleh with (pr1 r).
    { exact (pr2 r). }
    apply hqlthtoleh, (pr2 (pr2 q)). }
  exists (pr1 q,,Hq).
  split.
  - change (D (NonnegativeRationals_to_Rationals
                 (pr1 q,,Hq))).
    exact (pr1 (pr2 q)).
  - rewrite ltNonnegativeRationals_correct.
    change (pr1 r < (NonnegativeRationals_to_Rationals (pr1 q,,Hq))).
    exact (pr2 (pr2 q)).
Qed.

Lemma isOneSided_translation :
  ∏ (D : hq → hProp) (c : hq),
  isOneSided D → isOneSided (λ q, D (q + c)).
Proof.
  intros D c Hd.
  split ; split.
  - generalize (pr1 (pr1 Hd)).
    apply hinhfun.
    intros r.
    exists (pr1 r - c).
    unfold hqminus.
    rewrite hqplusassoc, hqlminus, hqplusr0.
    exact (pr2 r).
  - generalize (pr2 (pr1 Hd)).
    apply hinhfun.
    intros r.
    exists (pr1 r - c).
    unfold hqminus.
    rewrite hqplusassoc, hqlminus, hqplusr0.
    exact (pr2 r).
  - intros r D'r.
    generalize (pr1 (pr2 Hd) _ D'r).
    apply hinhfun.
    intros q.
    exists (pr1 q - c).
    split.
    + unfold hqminus.
      rewrite hqplusassoc, hqlminus, hqplusr0.
      exact (pr1 (pr2 q)).
    + apply hqlthandplusrinv with c.
      unfold hqminus.
      rewrite hqplusassoc, hqlminus, hqplusr0.
      exact (pr2 (pr2 q)).
  - intros r s Hrs.
    apply (pr2 (pr2 Hd)).
    apply hqlthandplusr, Hrs.
Qed.
Lemma isOneSided_Dcuts_corr :
  ∏ D, isOneSided D → Dcuts_def_corr (λ r, D (pr1 r)).
Proof.
  intros D H c Hc.
  rewrite ltNonnegativeRationals_correct in Hc.
  generalize (pr2 (pr2 H) _ _ Hc).
  apply hinhuniv ; intros H0.
  apply coprodcomm in H0.
  revert H0 ; apply sumofmaps ; intros H0.
  { apply hinhpr, ii1, H0. }
  enough (Hq : ∃ q : NonnegativeRationals, D (pr1 q) × ¬ D (pr1 (q + c)%NRat)).
  { revert Hq.
    apply hinhfun, ii2. }

  generalize (pr2 (pr1 H)).
  apply hinhuniv.
  intros r.
  generalize (isarchhq (hqdiv (pr1 r) (hqdiv (pr1 c) 2%hq))).
  apply hinhuniv.
  intros n.
  assert (Hc' : hqdiv (pr1 c) 2 > 0).
  { apply hqmultgth0gth0.
    { exact Hc. }
    apply hqgthandmultlinv with 2.
    { exact hq2_gt0. }
    rewrite hqmultx0, hqisrinvmultinv.
    { exact hq1_gt0. }
    apply hqgth_hqneq, hq2_gt0. }
  assert (H1 : hqlth (pr1 r) (nattoring (pr1 n) * (hqdiv (pr1 c) 2))).
  { unfold hqlth in Hc.
    apply hqgthandmultrinv with (/ (hqdiv (pr1 c) 2)).
    - apply hqgthandmultlinv with (hqdiv (pr1 c) 2).
      + exact Hc'.
      + rewrite hqmultx0, hqisrinvmultinv.
        { exact hq1_gt0. }
        apply hqgth_hqneq, Hc'.
    - rewrite hqmultassoc, hqisrinvmultinv.
      + rewrite hqmultr1.
        unfold hqdiv in n.
        exact (pr2 n).
      + apply hqgth_hqneq, Hc'. }
  assert (Hn : ¬ D (nattoring (pr1 n) * hqdiv (pr1 c) 2)).
  { generalize (pr2 (pr2 H) _ _ H1).
    apply (hinhuniv (P := hneg _)), sumofmaps ; intro H2.
    - apply fromempty, (pr2 r), H2.
    - apply H2. }
  assert (H2 : ∏ (m : nat),
               nattoring m * hqdiv (pr1 c) 2 + pr1 c = nattoring (m + 2) * hqdiv (pr1 c) 2).
  { intros m.
    unfold nattoring.
    rewrite 2!(@nattorig_natmult hq).
    rewrite natmult_plus.
    apply maponpaths.
    simpl.
    unfold hqdiv.
    rewrite <- hqmult2r, hqmultassoc.
    rewrite hqislinvmultinv.
    - apply pathsinv0, hqmultr1.
    - apply hqgth_hqneq, hq2_gt0. }

  generalize (pr1 n) Hn.
  clear -H H0 Hc Hc' H2 ; intros n Hn.
  assert (Hm : D (nattoring O * hqdiv (pr1 c) 2)).
  { rewrite hqmult0x.
    exact H0. }
  destruct n.
  { apply fromempty, Hn, Hm. }
  rewrite <- (natplusl0 n), plus_n_Sm in Hn.
  revert Hm Hn.
  set (m := O).
  change (D (nattoring m * hqdiv (pr1 c) 2)
  → ¬ D (nattoring (m + S n) * hqdiv (pr1 c) 2)
    → ∃ q : NonnegativeRationals, D (pr1 q) × ¬ D (pr1 (q + c)%NRat)).
  generalize m ; clear m H0.
  revert D H.
  induction n as [ | n IHn] ; intros D H m Hm Hn.
  - apply hinhpr.
    use tpair.
    + use tpair.
      * apply (nattoring m * hqdiv (pr1 c) 2).
      * abstract (apply hq0lehandmult ;
                  [ clear ;
                    induction m ;
                    [ apply isreflhqleh
                    | unfold nattoring ;
                      rewrite nattorigS ;
                      apply hq0lehandplus ;
                      [ exact hq1ge0 | exact IHm ]]
                  | apply hqlthtoleh, Hc' ]).
    + simpl.
      split.
      * exact Hm.
      * change (¬ D ((nattoring m * hqdiv (pr1 c) 2) + (pr1 c))).
        intros H0.
        refine (factor_through_squash isapropempty _ _).
        2: apply (pr2 (pr2 H) (nattoring (m + 1) * hqdiv (pr1 c) 2) (nattoring m * hqdiv (pr1 c) 2 + pr1 c)).
        ** apply sumofmaps.
           *** exact Hn.
           *** intros H1 ; apply H1, H0.
        ** rewrite H2.
           apply hqlthandmultr.
           *** exact Hc'.
           *** unfold nattoring.
               rewrite <- (plus_n_Sm m 1%nat).
               rewrite nattorigS, hqpluscomm.
               apply hqlthnsn.
  - refine (hinhuniv _ _).
    2: apply (pr2 (pr2 H) (nattoring (m + 1) * hqdiv (pr1 c) 2) (nattoring (m + 2) * hqdiv (pr1 c) 2)).
    + apply sumofmaps ; intros Hm'.
      * apply IHn with (m + 1)%nat.
        ** exact H.
        ** exact Hm'.
        ** rewrite natplusassoc.
           exact Hn.
      * apply hinhpr.
        use tpair.
        ** use tpair.
           *** apply (nattoring m * hqdiv (pr1 c) 2).
           *** abstract (apply hq0lehandmult ;
                         [ clear ;
                           induction m ;
                           [ apply isreflhqleh
                           | unfold nattoring ;
                             rewrite nattorigS ;
                             apply hq0lehandplus ;
                             [ exact hq1ge0 | exact IHm ]]
                         | apply hqlthtoleh, Hc' ]).
        ** simpl.
           split.
           *** exact Hm.
           *** change (¬ D ((nattoring m * hqdiv (pr1 c) 2) + (pr1 c))).
               rewrite H2.
               exact Hm'.
    + apply hqlthandmultr.
      * exact Hc'.
      * unfold nattoring.
        rewrite <- (plus_n_Sm m 1%nat).
        rewrite nattorigS, hqpluscomm.
        apply hqlthnsn.
Qed.

Lemma isDcuts_OneSided :
  ∏ (D : NonnegativeRationals → hProp),
  Dcuts_def_bot D → Dcuts_def_open D → Dcuts_def_corr D
  → isOneSided (λ q : hq, sumofmaps (λ _ : 0 > q, htrue) (λ Hq : 0 <= q, D (q,, Hq)) (hqgthorleh 0 q)).
Proof.
  intros D Hbot Hopen Hcorr.
  split ; split.
  - apply hinhpr.
    exists (-(1)).
    induction (hqgthorleh 0 (- (1))) as [H | H].
    + exact tt.
    + apply fromempty.
      refine (hqlehtoneghqgth _ _ _ _).
      * apply H.
      * apply hqgthandplusrinv with 1.
        rewrite hqlminus, hqplusl0.
        exact hq1_gt0.
  - generalize (Hcorr _ ispositive_oneNonnegativeRationals).
    apply hinhfun, sumofmaps ; intros H.
    + exists 1.
      induction (hqgthorleh 0 1) as [H0 | H0].
      * apply fromempty.
        refine (hqgthtoneghqleh _ _ _ _).
        ** exact H0.
        ** exact hq1ge0.
      * assert (H1 : 1%NRat = (1 ,, H0))
          by (apply subtypePath_prop ; reflexivity).
        rewrite H1 in H.
        exact H.
    + rename H into q.
      exists (pr1 (pr1 q) + 1).
      induction (hqgthorleh 0 (pr1 (pr1 q) + 1)) as [H0 | H0].
      * apply fromempty.
        refine (hqgthtoneghqleh _ _ _ _).
        ** apply H0.
        ** apply hq0lehandplus.
           *** exact (pr2 (pr1 q)).
           *** exact hq1ge0.
      * assert (Hq1 : (pr1 q + 1)%NRat = (pr1 (pr1 q) + 1 ,, H0))
          by (apply subtypePath_prop ; reflexivity).
        generalize (pr2 (pr2 q)) ; intro Hq.
        rewrite Hq1 in Hq.
        exact Hq.
  - intros r Dr.
    induction (hqgthorleh 0 r) as [Hr | Hr].
    + set (q := hqlth_between _ _ Hr).
      apply hinhpr.
      exists (pr1 q).
      split.
      * induction (hqgthorleh 0 (pr1 q)) as [Hq | Hq].
        ** exact tt.
        ** apply fromempty.
           refine (hqlehtoneghqgth _ _ _ _).
           *** exact Hq.
           *** unfold hqlth in q.
               exact (pr2 (pr2 q)).
      * exact (pr1 (pr2 q)).
    + generalize (Hopen _ Dr).
      apply hinhfun.
      intros q.
      exists (pr1 (pr1 q)).
      induction (hqgthorleh 0 (pr1 (pr1 q))) as [Hq | Hq].
      * apply fromempty.
        refine (hqgthtoneghqleh _ _ _ _).
        ** apply Hq.
        ** exact (pr2 (pr1 q)).
      * split.
        ** assert (Hq1 : pr1 q = (pr1 (pr1 q) ,, Hq))
             by (apply subtypePath_prop ; reflexivity).
           generalize (pr1 (pr2 q)) ; intro Hq'.
           rewrite Hq1 in Hq'.
           exact Hq'.
        ** generalize (pr2 (pr2 q)) ; intro Hq'.
           rewrite ltNonnegativeRationals_correct in Hq'.
           exact Hq'.
  -intros r q Hrq.
    induction (hqgthorleh 0 r) as [Hr | Hr].
    { apply hinhpr, ii1, tt. }
    induction (hqgthorleh 0 q) as [Hq | Hq].
    + apply fromempty.
      refine (hqlehtoneghqgth _ _ _ _).
      * apply Hr.
      * apply istranshqgth with q.
        ** exact Hq.
        ** unfold hqlth in Hrq.
           exact Hrq.
    + apply (Dcuts_locatedness (D,,Hbot,,Hopen,,Hcorr)).
      rewrite ltNonnegativeRationals_correct.
      exact Hrq.
Qed.

Lemma weqOneSidedDcuts :
  weq (∑ S : hq → hProp, isOneSided S × ∏ q : hq, q < 0 → S q) Dcuts.
Proof.
  set (f := (λ (D : ∑ S : hq → hProp, isOneSided S × (∏ q : hq, q < 0 → S q)),
             make_Dcuts (λ r : NonnegativeRationals, pr1 D (pr1 r))
                     (isOneSided_Dcuts_bot (pr1 D) (pr1 (pr2 D)))
                     (isOneSided_Dcuts_open (pr1 D) (pr1 (pr2 D)))
                     (isOneSided_Dcuts_corr (pr1 D) (pr1 (pr2 D))))
            : (∑ S : hq → hProp, isOneSided S × (∏ q : hq, q < 0 → S q)) → Dcuts).
  assert (Hg : ∏ (D : Dcuts) (q : hq),
               q < 0
               → sumofmaps (λ _ : 0 > q, htrue) (λ Hq : 0 <= q, pr1 D (q,, Hq)) (hqgthorleh 0 q)).
  { intros D q Hq.
    induction (hqgthorleh 0 q) as [Hq' | Hq'].
    { exact tt. }
    apply fromempty.
    refine (hqlehtoneghqgth _ _ _ _).
    - apply Hq'.
    - unfold hqlth in Hq.
      exact Hq. }
set (g := (λ D : Dcuts,
    (λ q : hq,
     sumofmaps (λ _ : 0 > q, htrue) (λ Hq : 0 <= q, pr1 D (q,, Hq))
       (hqgthorleh 0 q)),,
    isDcuts_OneSided (pr1 D) (is_Dcuts_bot D) (is_Dcuts_open D)
    (is_Dcuts_corr D),, Hg D)
          : Dcuts → ∑ S : hq → hProp, isOneSided S × (∏ q : hq, q < 0 → S q)).
  apply (weq_iso f g).
  - intros D.
    simple refine (subtypePath_prop (B := λ _, make_hProp _ _) _).
    + apply isapropdirprod.
      * apply isapropdirprod.
        ** apply propproperty.
        ** apply isapropdirprod.
           *** apply impred_isaprop ; intro r.
               apply isapropimpl, propproperty.
           *** apply impred_isaprop ; intro r.
               apply impred_isaprop ; intro s.
               apply isapropimpl, propproperty.
      * apply impred_isaprop ; intro q.
        apply isapropimpl, propproperty.
    + apply funextfun ; intros q.
      apply hPropUnivalence.
      * change (sumofmaps (λ _ : 0 > q, htrue) (λ _ : ¬ (0 > q), pr1 D q) (hqgthorleh 0 q) → pr1 D q).
        induction (hqgthorleh 0 q) as [Hq | Hq].
        ** intros _.
           apply (pr2 (pr2 D)).
           exact Hq.
        ** intros H ; apply H.
      * change (pr1 D q → sumofmaps (λ _ : 0 > q, htrue) (λ _ : ¬ (0 > q), pr1 D q) (hqgthorleh 0 q)).
        intros Dq.
        induction (hqgthorleh 0 q) as [Hq | Hq].
        ** exact tt.
        ** exact Dq.
  - intros D.
    apply subtypePath_prop.
    apply funextfun ; intros q.
    apply hPropUnivalence.
    + change (sumofmaps (λ _ : 0 > pr1 q, htrue)
                        (λ Hq : ¬ (0 > pr1 q), pr1 D (pr1 q,, Hq)) (hqgthorleh 0 (pr1 q))
              → pr1 D q).
      induction (hqgthorleh 0 (pr1 q)) as [Hq | Hq].
      * apply fromempty.
        refine (hqlehtoneghqgth _ _ _ _).
        ** exact (pr2 q).
        ** exact Hq.
      * intros H.
        assert (Hq1 : q = (pr1 q,, Hq))
          by (apply subtypePath_prop ; reflexivity).
        rewrite Hq1 ; exact H.
    + change (pr1 D q
  → sumofmaps (λ _ : 0 > pr1 q, htrue)
              (λ Hq : ¬ (0 > pr1 q), pr1 D (pr1 q,, Hq)) (hqgthorleh 0 (pr1 q))).
      intros Dq.
      induction (hqgthorleh 0 (pr1 q)) as [Hq | Hq].
      * apply fromempty.
        refine (hqlehtoneghqgth _ _ _ _).
        ** exact (pr2 q).
        ** exact Hq.
      * assert (Hq1 : q = (pr1 q,, Hq))
          by (apply subtypePath_prop ; reflexivity).
        rewrite Hq1 in Dq ; exact Dq.
Qed.


From iris.algebra Require Export excl local_updates.
From iris.algebra Require Import proofmode_classes.
From iris.base_logic Require Import base_logic.
Set Default Proof Using "Type".

Record auth (A : Type) := Auth { authoritative : excl' A; auth_own : A }.
Add Printing Constructor auth.
Arguments Auth {_} _ _.
Arguments authoritative {_} _.
Arguments auth_own {_} _.
Instance: Params (@Auth) 1.
Instance: Params (@authoritative) 1.
Instance: Params (@auth_own) 1.
Notation "◯ a" := (Auth None a) (at level 20).
Notation "● a" := (Auth (Excl' a) ε) (at level 20).

(* COFE *)
Section cofe.
Context {A : ofeT}.
Implicit Types a : excl' A.
Implicit Types b : A.
Implicit Types x y : auth A.

Instance auth_equiv : Equiv (auth A) := λ x y,
  authoritative x ≡ authoritative y ∧ auth_own x ≡ auth_own y.
Instance auth_dist : Dist (auth A) := λ n x y,
  authoritative x ≡{n}≡ authoritative y ∧ auth_own x ≡{n}≡ auth_own y.

Global Instance Auth_ne : NonExpansive2 (@Auth A).
Proof. by split. Qed.
Global Instance Auth_proper : Proper ((≡) ==> (≡) ==> (≡)) (@Auth A).
Proof. by split. Qed.
Global Instance authoritative_ne: NonExpansive (@authoritative A).
Proof. by destruct 1. Qed.
Global Instance authoritative_proper : Proper ((≡) ==> (≡)) (@authoritative A).
Proof. by destruct 1. Qed.
Global Instance own_ne : NonExpansive (@auth_own A).
Proof. by destruct 1. Qed.
Global Instance own_proper : Proper ((≡) ==> (≡)) (@auth_own A).
Proof. by destruct 1. Qed.

Definition auth_ofe_mixin : OfeMixin (auth A).
Proof. by apply (iso_ofe_mixin (λ x, (authoritative x, auth_own x))). Qed.
Canonical Structure authC := OfeT (auth A) auth_ofe_mixin.

Global Instance auth_cofe `{Cofe A} : Cofe authC.
Proof.
  apply (iso_cofe (λ y : _ * _, Auth (y.1) (y.2))
    (λ x, (authoritative x, auth_own x))); by repeat intro.
Qed.

Global Instance Auth_discrete a b :
  Discrete a → Discrete b → Discrete (Auth a b).
Proof. by intros ?? [??] [??]; split; apply: discrete. Qed.
Global Instance auth_ofe_discrete : OfeDiscrete A → OfeDiscrete authC.
Proof. intros ? [??]; apply _. Qed.
Global Instance auth_leibniz : LeibnizEquiv A → LeibnizEquiv (auth A).
Proof. by intros ? [??] [??] [??]; f_equal/=; apply leibniz_equiv. Qed.
End cofe.

Arguments authC : clear implicits.

(* CMRA *)
Section cmra.
Context {A : ucmraT}.
Implicit Types a b : A.
Implicit Types x y : auth A.

Instance auth_valid : Valid (auth A) := λ x,
  match authoritative x with
  | Excl' a => (∀ n, auth_own x ≼{n} a) ∧ ✓ a
  | None => ✓ auth_own x
  | ExclBot' => False
  end.
Global Arguments auth_valid !_ /.
Instance auth_validN : ValidN (auth A) := λ n x,
  match authoritative x with
  | Excl' a => auth_own x ≼{n} a ∧ ✓{n} a
  | None => ✓{n} auth_own x
  | ExclBot' => False
  end.
Global Arguments auth_validN _ !_ /.
Instance auth_pcore : PCore (auth A) := λ x,
  Some (Auth (core (authoritative x)) (core (auth_own x))).
Instance auth_op : Op (auth A) := λ x y,
  Auth (authoritative x ⋅ authoritative y) (auth_own x ⋅ auth_own y).

Definition auth_valid_eq :
  valid = λ x, match authoritative x with
               | Excl' a => (∀ n, auth_own x ≼{n} a) ∧ ✓ a
               | None => ✓ auth_own x
               | ExclBot' => False
               end := eq_refl _.
Definition auth_validN_eq :
  validN = λ n x, match authoritative x with
                  | Excl' a => auth_own x ≼{n} a ∧ ✓{n} a
                  | None => ✓{n} auth_own x
                  | ExclBot' => False
                  end := eq_refl _.

Lemma auth_included (x y : auth A) :
  x ≼ y ↔ authoritative x ≼ authoritative y ∧ auth_own x ≼ auth_own y.
Proof.
  split; [intros [[z1 z2] Hz]; split; [exists z1|exists z2]; apply Hz|].
  intros [[z1 Hz1] [z2 Hz2]]; exists (Auth z1 z2); split; auto.
Qed.

Lemma authoritative_validN n x : ✓{n} x → ✓{n} authoritative x.
Proof. by destruct x as [[[]|]]. Qed.
Lemma auth_own_validN n x : ✓{n} x → ✓{n} auth_own x.
Proof.
  rewrite auth_validN_eq.
  destruct x as [[[]|]]; naive_solver eauto using cmra_validN_includedN.
Qed.

Lemma auth_valid_discrete `{CmraDiscrete A} x :
  ✓ x ↔ match authoritative x with
        | Excl' a => auth_own x ≼ a ∧ ✓ a
        | None => ✓ auth_own x
        | ExclBot' => False
        end.
Proof.
  rewrite auth_valid_eq. destruct x as [[[?|]|] ?]; simpl; try done.
  setoid_rewrite <-cmra_discrete_included_iff; naive_solver eauto using 0.
Qed.
Lemma auth_validN_2 n a b : ✓{n} (● a ⋅ ◯ b) ↔ b ≼{n} a ∧ ✓{n} a.
Proof. by rewrite auth_validN_eq /= left_id. Qed.
Lemma auth_valid_discrete_2 `{CmraDiscrete A} a b : ✓ (● a ⋅ ◯ b) ↔ b ≼ a ∧ ✓ a.
Proof. by rewrite auth_valid_discrete /= left_id. Qed.

Lemma authoritative_valid  x : ✓ x → ✓ authoritative x.
Proof. by destruct x as [[[]|]]. Qed.
Lemma auth_own_valid `{CmraDiscrete A} x : ✓ x → ✓ auth_own x.
Proof.
  rewrite auth_valid_discrete.
  destruct x as [[[]|]]; naive_solver eauto using cmra_valid_included.
Qed.

Lemma auth_cmra_mixin : CmraMixin (auth A).
Proof.
  apply cmra_total_mixin.
  - eauto.
  - by intros n x y1 y2 [Hy Hy']; split; simpl; rewrite ?Hy ?Hy'.
  - by intros n y1 y2 [Hy Hy']; split; simpl; rewrite ?Hy ?Hy'.
  - intros n [x a] [y b] [Hx Ha]; simpl in *. rewrite !auth_validN_eq.
    destruct Hx as [?? Hx|]; first destruct Hx; intros ?; ofe_subst; auto.
  - intros [[[?|]|] ?]; rewrite /= ?auth_valid_eq
      ?auth_validN_eq /= ?cmra_included_includedN ?cmra_valid_validN;
      naive_solver eauto using O.
  - intros n [[[]|] ?]; rewrite !auth_validN_eq /=;
      naive_solver eauto using cmra_includedN_S, cmra_validN_S.
  - by split; simpl; rewrite assoc.
  - by split; simpl; rewrite comm.
  - by split; simpl; rewrite ?cmra_core_l.
  - by split; simpl; rewrite ?cmra_core_idemp.
  - intros ??; rewrite! auth_included; intros [??].
    by split; simpl; apply: cmra_core_mono. (* FIXME: apply cmra_core_mono. fails *)
  - assert (∀ n (a b1 b2 : A), b1 ⋅ b2 ≼{n} a → b1 ≼{n} a).
    { intros n a b1 b2 <-; apply cmra_includedN_l. }
   intros n [[[a1|]|] b1] [[[a2|]|] b2]; rewrite auth_validN_eq;
     naive_solver eauto using cmra_validN_op_l, cmra_validN_includedN.
  - intros n x y1 y2 ? [??]; simpl in *.
    destruct (cmra_extend n (authoritative x) (authoritative y1)
      (authoritative y2)) as (ea1&ea2&?&?&?); auto using authoritative_validN.
    destruct (cmra_extend n (auth_own x) (auth_own y1) (auth_own y2))
      as (b1&b2&?&?&?); auto using auth_own_validN.
    by exists (Auth ea1 b1), (Auth ea2 b2).
Qed.
Canonical Structure authR := CmraT (auth A) auth_cmra_mixin.

Global Instance auth_cmra_discrete : CmraDiscrete A → CmraDiscrete authR.
Proof.
  split; first apply _.
  intros [[[?|]|] ?]; rewrite auth_valid_eq auth_validN_eq /=; auto.
  - setoid_rewrite <-cmra_discrete_included_iff.
    rewrite -cmra_discrete_valid_iff. tauto.
  - by rewrite -cmra_discrete_valid_iff.
Qed.

Instance auth_empty : Unit (auth A) := Auth ε ε.
Lemma auth_ucmra_mixin : UcmraMixin (auth A).
Proof.
  split; simpl.
  - rewrite auth_valid_eq /=. apply ucmra_unit_valid.
  - by intros x; constructor; rewrite /= left_id.
  - do 2 constructor; simpl; apply (core_id_core _).
Qed.
Canonical Structure authUR := UcmraT (auth A) auth_ucmra_mixin.

Global Instance auth_frag_core_id a : CoreId a → CoreId (◯ a).
Proof. do 2 constructor; simpl; auto. by apply core_id_core. Qed.

(** Internalized properties *)
Lemma auth_equivI {M} (x y : auth A) :
  x ≡ y ⊣⊢ (authoritative x ≡ authoritative y ∧ auth_own x ≡ auth_own y : uPred M).
Proof. by uPred.unseal. Qed.
Lemma auth_validI {M} (x : auth A) :
  ✓ x ⊣⊢ (match authoritative x with
          | Excl' a => (∃ b, a ≡ auth_own x ⋅ b) ∧ ✓ a
          | None => ✓ auth_own x
          | ExclBot' => False
          end : uPred M).
Proof. uPred.unseal. by destruct x as [[[]|]]. Qed.

Lemma auth_frag_op a b : ◯ (a ⋅ b) = ◯ a ⋅ ◯ b.
Proof. done. Qed.
Lemma auth_frag_mono a b : a ≼ b → ◯ a ≼ ◯ b.
Proof. intros [c ->]. rewrite auth_frag_op. apply cmra_included_l. Qed.

Global Instance auth_frag_sep_homomorphism :
  MonoidHomomorphism op op (≡) (@Auth A None).
Proof. by split; [split; try apply _|]. Qed.

Lemma auth_both_op a b : Auth (Excl' a) b ≡ ● a ⋅ ◯ b.
Proof. by rewrite /op /auth_op /= left_id. Qed.
Lemma auth_auth_valid a : ✓ a → ✓ (● a).
Proof. intros; split; simpl; auto using ucmra_unit_leastN. Qed.

Lemma auth_update a b a' b' :
  (a,b) ~l~> (a',b') → ● a ⋅ ◯ b ~~> ● a' ⋅ ◯ b'.
Proof.
  intros Hup; apply cmra_total_update.
  move=> n [[[?|]|] bf1] // [[bf2 Ha] ?]; do 2 red; simpl in *.
  move: Ha; rewrite !left_id -assoc=> Ha.
  destruct (Hup n (Some (bf1 ⋅ bf2))); auto.
  split; last done. exists bf2. by rewrite -assoc.
Qed.

Lemma auth_update_alloc a a' b' : (a,ε) ~l~> (a',b') → ● a ~~> ● a' ⋅ ◯ b'.
Proof. intros. rewrite -(right_id _ _ (● a)). by apply auth_update. Qed.
Lemma auth_update_dealloc a b a' : (a,b) ~l~> (a',ε) → ● a ⋅ ◯ b ~~> ● a'.
Proof. intros. rewrite -(right_id _ _ (● a')). by apply auth_update. Qed.

Lemma auth_local_update (a b0 b1 a' b0' b1': A) :
  (b0, b1) ~l~> (b0', b1') → b0' ≼ a' → ✓ a' →
  (● a ⋅ ◯ b0, ● a ⋅ ◯ b1) ~l~> (● a' ⋅ ◯ b0', ● a' ⋅ ◯ b1').
Proof.
  rewrite !local_update_unital=> Hup ? ? n /=.
  move=> [[[ac|]|] bc] /auth_validN_2 [Le Val] [] /=;
    inversion_clear 1 as [?? Ha|]; inversion_clear Ha. (* need setoid_discriminate! *)
  rewrite !left_id=> ?.
  destruct (Hup n bc) as [Hval' Heq]; eauto using cmra_validN_includedN.
  rewrite -!auth_both_op auth_validN_eq /=.
  split_and!; [by apply cmra_included_includedN|by apply cmra_valid_validN|done].
Qed.
End cmra.

Arguments authR : clear implicits.
Arguments authUR : clear implicits.

(* Proof mode class instances *)
Instance is_op_auth_frag {A : ucmraT} (a b1 b2 : A) :
  IsOp a b1 b2 → IsOp' (◯ a) (◯ b1) (◯ b2).
Proof. done. Qed.

(* Functor *)
Definition auth_map {A B} (f : A → B) (x : auth A) : auth B :=
  Auth (excl_map f <$> authoritative x) (f (auth_own x)).
Lemma auth_map_id {A} (x : auth A) : auth_map id x = x.
Proof. by destruct x as [[[]|]]. Qed.
Lemma auth_map_compose {A B C} (f : A → B) (g : B → C) (x : auth A) :
  auth_map (g ∘ f) x = auth_map g (auth_map f x).
Proof. by destruct x as [[[]|]]. Qed.
Lemma auth_map_ext {A B : ofeT} (f g : A → B) x :
  (∀ x, f x ≡ g x) → auth_map f x ≡ auth_map g x.
Proof.
  constructor; simpl; auto.
  apply option_fmap_equiv_ext=> a; by apply excl_map_ext.
Qed.
Instance auth_map_ne {A B : ofeT} n :
  Proper ((dist n ==> dist n) ==> dist n ==> dist n) (@auth_map A B).
Proof.
  intros f g Hf [??] [??] [??]; split; simpl in *; [|by apply Hf].
  apply option_fmap_ne; [|done]=> x y ?; by apply excl_map_ne.
Qed.
Instance auth_map_cmra_morphism {A B : ucmraT} (f : A → B) :
  CmraMorphism f → CmraMorphism (auth_map f).
Proof.
  split; try apply _.
  - intros n [[[a|]|] b]; rewrite !auth_validN_eq; try
      naive_solver eauto using cmra_morphism_monotoneN, cmra_morphism_validN.
  - intros [??]. apply Some_proper; rewrite /auth_map /=.
    by f_equiv; rewrite /= cmra_morphism_core.
  - intros [[?|]?] [[?|]?]; try apply Auth_proper=>//=; by rewrite cmra_morphism_op.
Qed.
Definition authC_map {A B} (f : A -n> B) : authC A -n> authC B :=
  CofeMor (auth_map f).
Lemma authC_map_ne A B : NonExpansive (@authC_map A B).
Proof. intros n f f' Hf [[[a|]|] b]; repeat constructor; apply Hf. Qed.

Program Definition authRF (F : urFunctor) : rFunctor := {|
  rFunctor_car A B := authR (urFunctor_car F A B);
  rFunctor_map A1 A2 B1 B2 fg := authC_map (urFunctor_map F fg)
|}.
Next Obligation.
  by intros F A1 A2 B1 B2 n f g Hfg; apply authC_map_ne, urFunctor_ne.
Qed.
Next Obligation.
  intros F A B x. rewrite /= -{2}(auth_map_id x).
  apply auth_map_ext=>y; apply urFunctor_id.
Qed.
Next Obligation.
  intros F A1 A2 A3 B1 B2 B3 f g f' g' x. rewrite /= -auth_map_compose.
  apply auth_map_ext=>y; apply urFunctor_compose.
Qed.

Instance authRF_contractive F :
  urFunctorContractive F → rFunctorContractive (authRF F).
Proof.
  by intros ? A1 A2 B1 B2 n f g Hfg; apply authC_map_ne, urFunctor_contractive.
Qed.

Program Definition authURF (F : urFunctor) : urFunctor := {|
  urFunctor_car A B := authUR (urFunctor_car F A B);
  urFunctor_map A1 A2 B1 B2 fg := authC_map (urFunctor_map F fg)
|}.
Next Obligation.
  by intros F A1 A2 B1 B2 n f g Hfg; apply authC_map_ne, urFunctor_ne.
Qed.
Next Obligation.
  intros F A B x. rewrite /= -{2}(auth_map_id x).
  apply auth_map_ext=>y; apply urFunctor_id.
Qed.
Next Obligation.
  intros F A1 A2 A3 B1 B2 B3 f g f' g' x. rewrite /= -auth_map_compose.
  apply auth_map_ext=>y; apply urFunctor_compose.
Qed.

Instance authURF_contractive F :
  urFunctorContractive F → urFunctorContractive (authURF F).
Proof.
  by intros ? A1 A2 B1 B2 n f g Hfg; apply authC_map_ne, urFunctor_contractive.
Qed.


(*
   Currently, this module is BROKEN.

   Experimental extraction using iRRAM-style real numbers as intervals with
   a fixed precision and fast re-start when it is found that the precision is insufficient.
   It relies on a hack to quickly propagate a failure due to insufficient precision.
   The hack is that the M monad is not used for non-determinism but for efficiently
   signalling such a failure.  This works sometimes but not always.
*)

Require Import Extraction.
Require ExtrHaskellBasic.
Require ExtrHaskellNatInteger.
Require ExtrHaskellZInteger.
Require Import Real.
Require Import IVT.
Require Import Minmax.
Require Import sqrt.
Require Import testsearch.

Extraction Language Haskell.

(* Real is Real, K is LazyBoolean, and M T is T *)
Extract Inlined Constant Real => "(WithCurrentPrec (CN MPBall) p)".
Extract Inlined Constant K => "Kleenean".

(* Axioms for Kleenean *)
Extract Inlined Constant trueK => "(kleenean True)".
Extract Inlined Constant falseK => "(kleenean False)".

Extract Inlined Constant kneg => "not".
Extract Inlined Constant kland => "(&&)".
Extract Inlined Constant klor => "(||)".

Extract Inlined Constant choose => "select".

(* Axioms for Multivalueness *)
Extract Constant M "a" => " CN a ".
Extract Inlined Constant unitM => "cn".
Extract Inlined Constant multM => "join".
Extract Inlined Constant liftM => "Prelude.fmap".

Extract Inlined Constant mjoin => "Prelude.fmap".
(* Extract Inlined Constant mjoin => "liftTakeErrors". *)
(* mjoin is more-or-less the identity function,
but it needs to correctly propagate CN and WithCurrentPrec wrappers. *)

(* Extract Inlined Constant countableLiftM => "(\f -> cn (unCN . f))". *)
(* Extract Inlined Constant singletonM => "unCN". *)

(* Exact Real Number Operations *)
Extract Inlined Constant Real0 => "0".
Extract Inlined Constant Real1 => "1".

Extract Inlined Constant Realplus => "(+)".
Extract Inlined Constant Realmult => "(*)".
Extract Inlined Constant Realopp => "negate".
Extract Inlined Constant Realinv => "recip".
Extract Inlined Constant Reallt_semidec => "(<)".
Extract Inlined Constant Realgt_semidec => "(>)".
Extract Inlined Constant Real_limit_p => "limit".
(* Extract Inlined Constant slimit => "limit". *)
(* Extract Inlined Constant mslimit => "limit". *)

(* Extract Inductive bool => "Bool" [ "True" "False" ]. *)
Extract Inductive sumbool => "Bool" [ "True" "False" ].
(* The missing CN in the constants is compensated for
   by our mapping for mjoin. *)

(* some shortcuts for efficiency. Not necessary *)
Extract Inlined Constant  Real2 => "2".
Extract Inlined Constant  Real3 => "3".
Extract Inlined Constant Realminus => "(-)".
Extract Inlined Constant Realdiv => "(/)".
Extract Inlined Constant prec => "(0.5^)".

Extract Inductive sigT => "(,)" ["(,)"].
Extract Inductive prod => "(,)"  [ "(,)" ].

Extract Inlined Constant Nat.log2 => "(integer . integerLog2)".

(* Maximum *)

(* root finding function *)
Extraction "IVTMB" CIVT.

(* maximum *)
Extraction "MaxMB" Realmax.

(* sqrt *)
Extraction "SqrtMB" restr_sqrt.

(* magnitude *)
Extraction "MagnitudeMB" magnitude.

(*

The Haskell module will require the following packages:
- cdar-mBound >= 0.1.0.1
- collect-errors >= 0.1.4
- mixed-types-num >= 0.5.3
- aern2-mp >= 0.2.1
- aern2-real >= 0.2.1
- integer-logarithms

The generated Haskell files need the following edits to make them work:

(1) Add the following language options at the start of the file:

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE PolyKinds #-}

(2) Add the following imports after "import qualified Prelude":

import Prelude hiding (pred, succ, (==),(/=),(<),(<=),(>),(>=),not,(&&),(||))
import Control.Monad (join)
import Numeric.OrdGenericBool
import MixedTypesNumPrelude (ifThenElse, integer, Kleenean(..), kleenean)
import Math.NumberTheory.Logarithms (integerLog2)
import Numeric.CollectErrors (CN,cn,liftTakeErrors)
import AERN2.MP
import AERN2.MP.Dyadic ()
import AERN2.MP.WithCurrentPrec
import AERN2.Real hiding (pi)

(3) Add "(HasCurrentPrecision p) => " to every function signature that features
the type variable "p", eg:

realgtb :: (HasCurrentPrecision p) => (WithPrecision (CN MPBall) p)
	       ->
           (WithPrecision (CN MPBall) p)
           -> (CN Kleenean)
realgtb z1 z2 =
  (<) z2 z1

(4) To use the generated functions to compute a real number, use eg:

testRealmax1 :: CN MPBall
testRealmax1 = runWithPrec (prec 1000000) $ realmax (pi-pi) 0

testRealmax2 :: CReal
testRealmax2 = creal $ WithAnyPrec $ realmax (pi-pi) 0

*)


Require Import List Map Envs AllInRel Exp MoreList.
Require Import IL Annotation.
Require Import Liveness.Liveness.
Require Import ExpVarsBounded SpillSound SpillUtil.
Require Import PartialOrder.

Set Implicit Arguments.

Definition is_rlive_min k ZL Λ s sl Rlv
  := forall R M, spill_sound k ZL Λ (R,M) s sl
                 -> Rlv ⊆ R.

Inductive rlive_min (k:nat)
  : list params -> list (⦃var⦄ * ⦃var⦄) -> ⦃var⦄ -> stmt -> spilling -> ann ⦃var⦄ -> Prop :=
| RMinLet ZL Λ x e s an sl Rlv rlv G
  : rlive_min k ZL Λ (singleton x) s sl rlv
    -> is_rlive_min k ZL Λ (stmtLet x e s) (ann1 an sl) (Rlv \ G)
    -> rlive_min k ZL Λ G (stmtLet x e s) (ann1 an sl) (ann1 Rlv rlv)
| RMinIf ZL Λ e s1 s2 an sl1 sl2 Rlv rlv1 rlv2 G
  : rlive_min k ZL Λ ∅ s1 sl1 rlv1
    -> rlive_min k ZL Λ ∅ s2 sl2 rlv2
    -> is_rlive_min k ZL Λ (stmtIf e s1 s2) (ann2 an sl1 sl2) (Rlv \ G)
    -> rlive_min k ZL Λ G (stmtIf e s1 s2) (ann2 an sl1 sl2) (ann2 Rlv rlv1 rlv2)
| RMinReturn ZL Λ e an Rlv G
  : is_rlive_min k ZL Λ (stmtReturn e) (ann0 an) (Rlv \ G)
    -> rlive_min k ZL Λ G (stmtReturn e) (ann0 an) (ann0 Rlv)
| RMinApp ZL Λ f Y an Rlv G
  : is_rlive_min k ZL Λ (stmtApp f Y) (ann0 an) (Rlv \ G)
    -> rlive_min k ZL Λ G (stmtApp f Y) (ann0 an) (ann0 Rlv)
| RSpillFun ZL Λ G F t spl rms sl_F sl_t Rlv rlv_F rlv_t
  : (forall n Zs sl_s rlv_s rm,
        get F n Zs
        -> get sl_F n sl_s
        -> get rlv_F n rlv_s
        -> get rms n rm
        -> rlive_min k (fst ⊝ F ++ ZL) (rms ++ Λ) (fst rm) (snd Zs) sl_s rlv_s)
    -> rlive_min k (fst ⊝ F ++ ZL) (rms ++ Λ) ∅ t sl_t rlv_t
    -> is_rlive_min k ZL Λ (stmtFun F t) (annF (spl, rms) sl_F sl_t) (Rlv \ G)
    -> rlive_min k ZL Λ G (stmtFun F t) (annF (spl, rms) sl_F sl_t) (annF Rlv rlv_F rlv_t).

Lemma rlive_min_G_anti k ZL Λ G G' s sl rlv
  : rlive_min k ZL Λ G s sl rlv
    -> G ⊆ G'
    -> rlive_min k ZL Λ G' s sl rlv.
Proof.
  intros RLM Incl.
  general induction RLM; econstructor; intros; eauto;
    hnf; intros; rewrite <- Incl; eauto.
Qed.

Lemma rlive_min_getAnn k ZL Λ s sl rlv R M
  : rlive_min k ZL Λ ∅ s sl rlv
    -> spill_sound k ZL Λ (R,M) s sl
    -> getAnn rlv ⊆ R.
Proof.
  intros rliveMin spillSnd. general induction rliveMin; cbn; unfold is_rlive_min in H;
                              rewrite <-minus_empty; try eapply H; eauto.
Qed.

Lemma rlive_min_getAnn_G k ZL Λ G s sl rlv
  : rlive_min k ZL Λ G s sl rlv
    -> (forall R M, spill_sound k ZL Λ (R,M) s sl -> getAnn rlv ⊆ R)
    -> rlive_min k ZL Λ ∅ s sl rlv.
Proof.
  intros rliveMin isMin.
  general induction rliveMin; econstructor; cbn in *; eauto;
    unfold is_rlive_min; intros; rewrite minus_empty; eapply isMin; eauto.
Qed.

Lemma rlive_min_incl_R k ZL Λ s sl rlv R M G
  : G ⊆ R
    -> spill_sound k ZL Λ (R, M) s sl
    -> rlive_min k ZL Λ G s sl rlv
    -> getAnn rlv ⊆ R.
Proof.
  intros Geq spillSnd rlive.
  general induction rlive; cbn;
    unfold is_rlive_min in *; rewrite <-union_subset_equal with (s':=R); eauto;
      apply incl_minus_incl_union; [| | | |eapply H1;eauto]; eapply H; eauto.
Qed.

Lemma is_rlive_min_ext Λ Λ' k ZL s sl LV
  : poEq Λ Λ'
    -> is_rlive_min k ZL Λ  s sl LV
    -> is_rlive_min k ZL Λ' s sl LV.
Proof.
  intros pir2 H. unfold is_rlive_min in *.
  intros. eapply spill_sound_ext in H0; eauto.
Qed.

Lemma rlive_min_ext Λ Λ' k ZL G s sl lv
  : poEq Λ Λ'
    -> rlive_min k ZL Λ  G s sl lv
    -> rlive_min k ZL Λ' G s sl lv.
Proof.
  intros Λeq lvMin. general induction lvMin; unfold is_rlive_min;
                      econstructor; eauto using is_rlive_min_ext.
Qed.

Lemma is_rlive_min_monotone Λ Λ' k ZL s sl LV
  : poLe Λ Λ'
    -> is_rlive_min k ZL Λ  s sl LV
    -> is_rlive_min k ZL Λ' s sl LV.
Proof.
  intros pir2 H. unfold is_rlive_min in *.
  intros. eapply spill_sound_monotone in H0; eauto.
Qed.

Lemma rlive_min_monotone Λ Λ' k ZL G s sl lv
  : poLe Λ Λ'
    -> rlive_min k ZL Λ  G s sl lv
    -> rlive_min k ZL Λ' G s sl lv.
Proof.
  intros Λeq lvMin. general induction lvMin; unfold is_rlive_min;
                      econstructor; eauto using is_rlive_min_monotone.
Qed.


Require Import Coq.Program.Equality.
Require Import GDTC.
Require Import CaseStudy.Arith.
Require Import CaseStudy.Lambda.
Require Import CaseStudy.Names.
Require Import CaseStudy.PNames.

Section Lambda_Arith.

  Variable D : Set -> Set.
  Context `{spf_D : SPF D}.
  Context {Sub_AType_D : AType :<: D}.
  Context {Sub_LType_D : LType :<: D}.
  Context {WF_Sub_AType_D : WF_Functor _ _ Sub_AType_D}.
  Context {WF_Sub_LType_D : WF_Functor _ _ Sub_LType_D}.

  Variable E : Set -> Set -> Set.
  Context {fun_E : forall A, Functor (E A)}.
  Context {pfun_E: forall A, PFunctor (E A)}.
  Context {spf_E : forall A, SPF (E A)}.
  Context {Sub_Arith_E : forall A, Arith :<: (E A)}.

  Variable EQV_E : forall A B, (eqv_i E A B -> Prop) -> eqv_i E A B -> Prop.
  Context {ifun_EQV_E : forall A B, iFunctor (EQV_E A B)}.
  Context {ispf_EQV_E : forall A B, iSPF (EQV_E A B)}.

  Variable V : Set -> Set.
  Context `{spf_V : SPF V}.
  Context {Sub_NatValue_V : NatValue :<: V}.
  Context {Sub_BotValue_V : BotValue :<: V}.
  Context {Sub_ClosValue_V : ClosValue E :<: V}.

  Variable WFV : (WFValue_i D V -> Prop) -> WFValue_i D V -> Prop.
  Context `{spfWFV : iSPF _ WFV}.

  Context {Dis_VI_Clos : Distinct_Sub_Functor NatValue (ClosValue E) V}.
  Context {WF_Sub_ClosValue_V : WF_Functor (ClosValue E) V Sub_ClosValue_V}.
  Context {WF_Sub_NatValue_V : WF_Functor NatValue V Sub_NatValue_V}.

  Context {Sub_WFV_VI_WFV : Sub_iFunctor (WFValue_VI D V) WFV}.
  Context {Dis_LType_AType : Distinct_Sub_Functor LType AType D}.

  Global Instance PAlgebra_WF_invertClos_VI typeof_rec :
    iPAlgebra WF_invertClos_Name (WF_invertClos_P D E V EQV_E WFV typeof_rec) (WFValue_VI D V).
  Proof.
    constructor; unfold iAlgebra, WF_invertClos_P.
    inversion 1; subst; simpl; split.
    - apply (inject_i (subGF := Sub_WFV_VI_WFV)); constructor.
    - intros ? ? Heq; discriminate_inject Heq.
  Qed.

  Global Instance PAlgebra_WF_invertClos'_VI typeof_rec :
    iPAlgebra WF_invertClos'_Name (WF_invertClos'_P D E V EQV_E WFV typeof_rec) (WFValue_VI D V).
  Proof.
    constructor; unfold iAlgebra, WF_invertClos_P.
    inversion 1; subst; simpl; split.
    - apply (inject_i (subGF := Sub_WFV_VI_WFV)); constructor.
    - intros ? Heq; discriminate_inject Heq.
  Qed.

  (* ============================================== *)
  (* EQUIVALENCE OF ARITHMETIC EXPRESSIONS          *)
  (* ============================================== *)

  Inductive Arith_eqv (A B : Set) (C : eqv_i E A B -> Prop) : eqv_i E A B -> Prop :=
  | Lit_eqv : forall (gamma : Env _) gamma' n,
    Arith_eqv A B C (mk_eqv_i _ _ _ gamma gamma' (lit (E A) n) (lit (E B) n))
  | Add_eqv : forall (gamma : Env _) gamma' a b a' b',
    C (mk_eqv_i _ _ _ gamma gamma' a a') ->
    C (mk_eqv_i _ _ _ gamma gamma' b b') ->
    Arith_eqv A B C (mk_eqv_i _ _ _ gamma gamma' (add (E _) a b) (add (E _) a' b')).

  Lemma Arith_eqv_impl_NP_eqv A B C i :
    Arith_eqv A B C i -> NP_Functor_eqv E Arith A B C i.
  Proof.
    intros; destruct H.
    unfold lit in *; simpl in *.
    constructor 1 with (np := fun D => Lit D n); auto.
    simpl; intros; dependent destruction p; auto.
    constructor 3 with (a := a) (a' := a') (b := b) (b' := b') (np := Add); auto.
    simpl; intros; dependent destruction p; auto.
    simpl; congruence.
  Qed.

End Lambda_Arith.