(**************************************************************************************************)
(* Total Constructor/Destructorization for Local (Co)pattern Matching.                                   *)
(*                                                                                *)
(* File: Sublists.v                                                                               *)
(*                                                                                *)
(**************************************************************************************************)

Require Import Coq.Lists.List.
Import ListNotations.
Require Import Unique.

Require Import ProgramDef.

Inductive Sublist {A : Type} : (list A) -> (list A) ->  Prop :=
| Sublist_nil : forall ys, Sublist [] ys
| Sublist_eq : forall xs ys z, Sublist xs ys -> Sublist (z :: xs) (z :: ys)
| Sublist_cons : forall xs ys  y, Sublist xs ys -> Sublist xs (y :: ys).

Lemma Unique_sublist : forall {A : Type} (xs ys : list A),
    Sublist xs ys ->
    unique ys ->
    unique ys.
Proof.
  intros. inversion H; subst.
  -assumption.
  -apply Unique_cons.
   +  inversion H0; subst. assumption.
   + inversion H0; subst. assumption.
  - apply Unique_cons.
    + inversion H0; subst. assumption.
    + inversion H0; subst. assumption.
Qed.

Lemma Sublist_refl : forall {A  : Type} (xs : list A),
    Sublist xs xs.
Proof.
  intros. induction xs.
  - apply Sublist_nil.
  - apply Sublist_eq. assumption.
Qed.

Lemma Sublist_app_r : forall {A : Type} (xs xs' ys : list A),
    Sublist xs xs' ->
    Sublist xs (ys ++ xs').
Proof.
  intros. induction ys.
  - simpl. assumption.
  - simpl. apply Sublist_cons. assumption.
Qed.

Lemma Sublist_app_l : forall {A : Type} (xs xs' ys : list A),
    Sublist xs xs' ->
    Sublist xs (xs' ++ ys).
Proof.
  intros. generalize dependent xs. generalize dependent ys.
  induction xs'; intros; simpl in *.
  - inversion H; subst. apply Sublist_nil.
  - inversion H; subst.
    + apply Sublist_nil.
    + apply Sublist_eq. apply IHxs'. assumption.
    + apply Sublist_cons. apply IHxs'. assumption.
Qed.

Lemma Sublist_app_cons_r : forall {A : Type} (xs xs' : list A) (a : A),
    Sublist xs xs' ->
    Sublist (xs ++ [a]) (xs' ++ [a]).
Proof.
  intros A xs xs' a H. generalize dependent xs. induction xs'; simpl; intros.
  - inversion H; subst. simpl. apply Sublist_refl.
  - inversion H; subst; simpl in *.
    * clear. apply Sublist_cons. induction xs'.
      ** simpl. apply Sublist_refl.
      ** simpl. apply Sublist_cons. assumption.
    * apply Sublist_eq. apply IHxs'. assumption.
    * apply Sublist_cons. apply IHxs'. assumption.
Qed.

Lemma app_cons : forall {A : Type} (xs ys : list A) (y : A),
    xs ++ (y :: ys) = (xs ++ [y]) ++ ys.
Proof.
  intros A xs ys y. rewrite <- app_assoc. simpl. reflexivity.
Qed.

Lemma Sublist_app_same_r : forall {A : Type} (xs xs' ys : list A),
    Sublist xs xs' ->
    Sublist (xs ++ ys) (xs' ++ ys).
Proof.
  intros A xs xs' ys H. generalize dependent xs. generalize dependent xs'.
  induction ys.
  - intros xs' xs H. repeat rewrite app_nil_r. assumption.
  - intros. rewrite app_cons. rewrite (app_cons xs'). apply IHys.
    apply Sublist_app_cons_r. assumption.
Qed.

Lemma Sublist_app_same_l : forall {A : Type} (xs xs' ys : list A),
    Sublist xs xs' ->
    Sublist (ys ++ xs) (ys ++ xs').
Proof.
  intros. induction ys.
  - simpl. assumption.
  - simpl. apply Sublist_eq. assumption.
Qed.

Lemma Sublist_app : forall {A : Type} (xs xs' ys ys' : list A),
    Sublist xs xs' ->
    Sublist ys ys' ->
    Sublist (xs ++ ys) (xs' ++ ys').
Proof.
  intros A xs xs' ys ys' H H0.
  generalize dependent xs. generalize dependent ys. generalize dependent ys'.
  induction xs'; intros.
  - simpl. inversion H; subst. simpl. assumption.
  - inversion H; subst; simpl in *.
    + apply Sublist_cons. apply Sublist_app_r. assumption.
    + apply Sublist_eq. apply IHxs'; try assumption.
    + specialize (IHxs' ys' ys H0).
      inversion H; subst; simpl in *.
      * pose proof (Sublist_app_r ys ys' (a :: xs')).
        simpl in H1. apply H1. assumption.
      * apply Sublist_eq. apply IHxs'; try assumption.
      * apply Sublist_cons. apply IHxs'. assumption.
Qed.


Require Export GeoCoq.Elements.OriginalProofs.lemma_TCreflexive.

Section Euclid.

Context `{Ax:area}.

Lemma lemma_ETreflexive :
   forall A B C,
   Triangle A B C ->
   ET A B C A B C.
Proof.
intros.
assert (nCol A B C) by (conclude_def Triangle ).
assert (Cong_3 A B C A B C) by (conclude lemma_TCreflexive).
assert (ET A B C A B C) by (conclude axiom_congruentequal).
close.
Qed.

End Euclid.


From Undecidability.L Require Export Datatypes.LNat Datatypes.LBool Tactics.LTactics Computability.Computability Tactics.Lbeta.

Section MuRecursor.

Variable P : term.
Hypothesis P_proc : proc P.
Local Hint Resolve P_proc : LProc.

Hypothesis dec'_P : forall (n:nat), (exists (b:bool), app P (ext n) == ext b ).

Lemma dec_P : forall n:nat, {b:bool | app P (ext n) == ext b}.
Proof using dec'_P.
  intros. eapply lcomp_comp.
  -apply bool_enc_inv_correct.
  -apply dec'_P.
Qed.

Section hoas.
  Import HOAS_Notations.
  Definition mu' := Eval cbn -[enc] in rho (convert (λ mu P n, (P n) (!!K n) (λ Sn, mu P Sn) (!!(ext S) n))).
End hoas.

Import L_Notations.

Lemma mu'_proc : proc mu'.
Proof.
  unfold mu'; Lproc.
Qed.

Local Hint Resolve mu'_proc : LProc.

Lemma mu'_n_false n: P (ext n)  == ext false -> mu' P (ext n) >* mu' P (ext (S n)).
Proof using P_proc.
  intros R. apply equiv_lambda in R;[|Lproc]. recStep mu'. unfold K. now Lsimpl.
Qed.

Lemma mu'_0_false n: (forall n', n' < n -> P (ext n')  == ext false) -> mu' P (ext 0) >* mu' P (ext n).
Proof using P_proc.
  intros H. induction n.
  -reflexivity.
  -rewrite IHn.
   +apply mu'_n_false. apply H. lia.
   +intros. apply H. lia.
Qed.

Lemma mu'_n_true (n:nat): P (ext n)  == ext true -> mu' P (ext n) == ext n.
Proof using P_proc.
  intros R. recStep mu'. Lsimpl. rewrite R. unfold K. now Lsimpl.
Qed.

(* TODO: mu' sound*)
Lemma mu'_sound v n: proc v -> mu' P (ext (n:nat)) == v ->
                     (forall n', n' < n -> P (ext n') == ext false) ->
                     exists n0, n0 >= n /\ P (ext n0) == ext true /\ v == ext n0
                                /\ forall n', n' < n0 -> P (ext (n':nat)) == ext false.
Proof using P_proc dec'_P.
  intros pv. intros R. apply equiv_lambda in R;try Lproc. apply star_pow in R. destruct R as [k R]. revert n R. apply complete_induction with (x:=k);clear k;intros k. intros IH n R H.
  specialize (dec_P n).
  destruct (dec_P n) as [[] eq].
  -exists n;intuition. apply pow_star in R. apply star_equiv in R. rewrite <- R. now rewrite mu'_n_true.
  -assert (R':=mu'_n_false eq). apply star_pow in R'. destruct R' as [k' R'].
   destruct (parametrized_confluence uniform_confluence R R') as [x [l [u [le1 [le2 [R1 [R2 eq']]]]]]]. destruct x.
   +inv R1. apply IH in R2 as [n0 [ge1 [Rn0 [eq0 H0]]]].
    *exists n0. repeat split;try assumption;lia.
    *decide (l=k);[|lia]. subst l. assert (k'=0) by lia. subst k'. inv R'. apply inj_enc in H1. lia.
    *intros. decide (n'=n). subst. tauto.  apply H. lia.
   +destruct R1 as [? [C _]]. destruct pv as [_ [v']]. subst v. inv C.
Qed.

Lemma mu'_complete n0 : P (ext n0) == ext true
                        -> (forall n', n' < n0 -> P (ext n') == ext false)
                        -> mu' P (ext 0) == ext n0.
Proof using P_proc.
  intros. rewrite mu'_0_false with (n:=n0);try tauto.
  -recStep mu'. Lsimpl. rewrite H. unfold K. now Lsimpl.
Qed.

(* the mu combinator:*)

Definition mu :term := lam (mu' #0 (ext 0)).

Lemma mu_proc : proc mu.
Proof.
  unfold mu. Lproc.
Qed.

Local Hint Resolve mu_proc : LProc.

Lemma mu_sound v : lambda v -> mu P == v -> exists n, v = ext n /\ P (ext n) == ext true /\ (forall n', n' < n -> P (ext n') == ext false).
Proof using P_proc dec'_P.
  unfold mu. intros lv R. standardizeHypo 100. apply mu'_sound in R.
  -destruct R as [n ?]. exists n. intuition. apply unique_normal_forms;try Lproc. assumption.
  -split;[|Lproc]. apply equiv_lambda in R;auto. apply closed_star in R;Lproc.
  -intros. lia.
Qed.

Lemma mu_complete' (n:nat) : P (ext n) == ext true -> exists n0:nat, mu P == ext n0 /\ P (ext n0) == ext true.
Proof using P_proc dec'_P.
  remember 0 as n0.
  assert (forall n':nat, n'< n-(n-n0) -> P (ext n') == ext false) by (intros;lia).
  assert ((n-n0)+n0=n) by lia. remember (n-n0) as k. clear Heqk Heqn0 H0 n0. induction k.
  - simpl in *. subst. intros.
    eexists. unfold mu. split.
    + Lsimpl. apply mu'_complete;eauto. intros. apply H. lia.
    + eauto.
  - intros. destruct (dec_P (n-S k)) as [y P'].
    destruct y.
    + eexists. unfold mu. split.
      * Lsimpl. apply mu'_complete. exact P'. exact H.
      * eauto.
    + apply IHk. intros. decide (n' = n - (S k)).
      * subst. exact P'.
      * apply H. lia.
      * assumption.
Qed.

Lemma mu_complete (n:nat) : P (ext n) == ext true -> exists n0:nat, mu P == ext n0.
Proof using P_proc dec'_P.
  intros [? []] % mu_complete'; eauto.
Qed.

Lemma mu_spec : converges (mu P) <-> exists n : nat, P (ext n) == ext true.
Proof using P_proc dec'_P.
  split.
  - intros (? & ? & ?). eapply mu_sound in H as (? & ? & ? & ?); eauto.
  - intros []. eapply mu_complete in H as []. exists (ext x0). split. eauto. eapply proc_ext.
Qed.

End MuRecursor.

#[export] Hint Resolve mu'_proc : LProc.
#[export] Hint Resolve mu_proc : LProc.


Require Import ZArith.
Require Import NatPolS.
Require Import PolSBase.
Require Import PolFBase.
Require Import PolAux.
Require Import PolAuxList.
Require Import NatSignTac.

Definition Zfactor :=
  factor Z Zplus Zmult Z.opp 0%Z 1%Z is_Z1 is_Z0 is_Zpos is_Zdiv Z.div Zgcd.

Definition Zfactor_minus :=
  factor_sub Z Zplus Zmult Z.opp 0%Z 1%Z is_Z1 is_Z0 is_Zpos is_Zdiv Z.div Zgcd.

Definition Zget_delta :=
 get_delta Z Zplus Zmult Z.opp 0%Z 1%Z is_Z1 is_Z0 is_Zpos is_Zdiv Z.div Zgcd.

Ltac
Natfactor_term term1 term2 :=
let term := constr:(minus term1 term2) in
let rfv := FV NatCst plus mult minus Natopp term (@nil nat) in
let fv := Trev rfv in
let expr1 := mkPolexpr Z NatCst plus mult minus Natopp term1 fv in
let expr2 := mkPolexpr Z NatCst plus mult minus Natopp term2 fv in
let re := eval vm_compute in (Zfactor_minus (PEsub expr1 expr2)) in
let factor := match re with (PEmul ?X1 _) => X1 end in
let expr3 := match re with (PEmul _ (PEsub ?X1 _)) => X1 end in
let expr4 := match re with (PEmul _ (PEsub _ ?X1 )) => X1 end in
let
 re1' :=
  eval
     unfold
      Natconvert_back, convert_back,  pos_nth,  jump,
         hd,  tl in (Natconvert_back (PEmul factor expr3) fv) in
let re1'' := eval lazy beta in re1' in
let re1''' := clean_zabs re1'' in
let
 re2' :=
  eval
     unfold
      Natconvert_back, convert_back,  pos_nth,  jump,
         hd,  tl in (Natconvert_back (PEmul factor expr4) fv) in
let re2'' := eval lazy beta in re2' in
let re2''' := clean_zabs re2'' in
replace2_tac term1 term2 re1''' re2'''; [idtac| ring | ring].

Ltac npolf :=
progress (
(try
match goal with
| |- (?X1 = ?X2)%nat =>  Natfactor_term X1 X2
| |- (?X1 <> ?X2)%nat =>  Natfactor_term X1 X2
| |- lt ?X1 ?X2 => Natfactor_term X1 X2
| |- gt ?X1 ?X2 =>Natfactor_term X1 X2
| |- le ?X1 ?X2 => Natfactor_term X1 X2
| |- ge ?X1 ?X2 =>Natfactor_term X1 X2
| _ => fail end)); try (nsign_tac); try repeat (rewrite mult_1_l || rewrite mult_1_r).

Ltac hyp_npolf H :=
progress (
generalize H;
(try
match type of H with
  (?X1 = ?X2)%nat =>  Natfactor_term X1 X2
| (?X1 <> ?X2)%nat =>  Natfactor_term X1 X2
| lt ?X1 ?X2 => Natfactor_term X1 X2
| gt ?X1 ?X2 =>Natfactor_term X1 X2
| le ?X1 ?X2 => Natfactor_term X1 X2
| ge ?X1 ?X2 =>Natfactor_term X1 X2
| _ => fail end)); clear H; intros H; try hyp_nsign_tac H; try repeat rewrite mult_1_l in H.


Require Import compcert.lib.Coqlib.
Require Import compcert.lib.Maps.

Section FINITE.

Variable A: Type.

Lemma ptree_finite:
  forall (t: PTree.t A), exists p, forall n, (p <= n)%positive -> PTree.get n t = None.
Proof.
  induction t.
- (* Leaf case *)
  exists 1%positive; intros. apply PTree.gempty.
- (* Node case *)
  destruct IHt1 as [p1 N1]. destruct IHt2 as [p2 N2].
  exists (Pos.max (xO p1) (xI p2)); intros.
  destruct n; simpl.
  apply N2. zify; omega.
  apply N1. zify; omega.
  zify; omegaContradiction.
Qed.

Lemma pmap_finite:
  forall (m: PMap.t A), exists p, forall n, (p <= n)%positive -> PMap.get n m = fst m.
Proof.
  intros. destruct m as [dfl t]; simpl.
  destruct (ptree_finite t) as [p N].
  exists p; intros. unfold PMap.get. simpl. rewrite N; auto.
Qed.

Lemma pmap_construct:
  forall (f: positive -> A) hi dfl,
  (forall n, (n >= hi)%positive -> f n = dfl) ->
  exists m: PMap.t A, forall n, PMap.get n m = f n.
Proof.
  intros until dfl; intros OUTSIDE.
  assert (REC: forall x, (x <= hi)%positive ->
          exists m, forall n, (n < x \/ n >= hi)%positive ->
                    PMap.get n m = f n).
  {
    intros x0; pattern x0.
    apply Pos.peano_rect; intros.
    exists (PMap.init dfl). intros. rewrite PMap.gi.
      destruct H0. xomega.
      symmetry. apply OUTSIDE. assumption.
  - (* Inductive case *)
    assert (HP: (p <= hi)%positive). xomega.
    destruct (H HP) as [m P]. clear H HP.
    exists (PMap.set p (f p) m); intros.
    rewrite PMap.gsspec.
    destruct (peq n p).
    congruence.
    apply P. destruct H. left. xomega. right; assumption.
  }
  destruct (REC hi) as [m P]. xomega.
  exists m; intros. apply P. xomega.
Qed.

Lemma zmap_finite:
  forall (m: ZMap.t A), exists lo, exists hi, forall n, n < lo \/ n > hi -> ZMap.get n m = fst m.
Proof.
  intros.
  destruct (pmap_finite m) as [p D].
  exists (-2 * Z.pos p); exists (2 * Z.pos p); intros.
  unfold ZMap.get. apply D.
  unfold ZIndexed.index. destruct n; zify; omega.
Qed.

Require Import Coq.ZArith.Zwf.

Lemma zmap_construct:
  forall (f: Z -> A) lo hi dfl,
  (forall n, n < lo \/ n > hi -> f n = dfl) ->
  exists m: ZMap.t A, forall n, ZMap.get n m = f n.
Proof.
  intros until dfl; intros OUTSIDE.
  assert (REC: forall x, x <= hi ->
          exists m, forall n, n <= x \/ n > hi -> ZMap.get n m = f n).
  {
    intros x0; pattern x0; apply (well_founded_ind (Zwf_well_founded lo)); intros.
    destruct (zlt x lo).
  - (* Base case *)
    exists (ZMap.init dfl). intros. rewrite ZMap.gi. symmetry. apply OUTSIDE. omega.
  - (* Inductive case *)
    destruct (H (x - 1)) as [m P].
    red. omega. omega.
    exists (ZMap.set x (f x) m); intros.
    rewrite ZMap.gsspec. unfold ZIndexed.eq. destruct (zeq n x).
    congruence.
    apply P. omega.
  }
  destruct (REC hi) as [m P]. omega.
  exists m; intros. apply P. omega.
Qed.

End FINITE.

Section FINITE_CONSTRUCTIVE.

Variable A: Type.

Fixpoint p_tree_finite_c (t: PTree.t A) : positive :=
  match t with
    PTree.Leaf => 1%positive
  | PTree.Node l _ r => Pos.max (xO (p_tree_finite_c l)) (xI (p_tree_finite_c r))
  end.

Lemma ptree_finite_c_sound:
  forall (t: PTree.t A) n, ((p_tree_finite_c t) <= n)%positive -> PTree.get n t = None.
Proof.
  induction t.
- (* Leaf case *)
  simpl. intros. apply PTree.gempty.
- (* Node case *)
  (*destruct IHt1 as [p1 N1]. destruct IHt2 as [p2 N2].
  exists (Pos.max (xO p1) (xI p2));*)
  intros.
  destruct n; simpl in *.
  apply IHt2. zify; omega.
  apply IHt1. zify; omega.
  zify; omegaContradiction.
Qed.

Definition pmap_finite_c (m: PMap.t A) : positive :=
           p_tree_finite_c (snd m).

Lemma pmap_finite_sound_c:
  forall (m: PMap.t A) n, ((pmap_finite_c m) <= n)%positive -> PMap.get n m = fst m.
Proof.
  intros. unfold pmap_finite_c in H.
  destruct m as [dfl t]; simpl in *.
  unfold PMap.get. simpl.
  rewrite (ptree_finite_c_sound _ _ H); trivial.
Qed.

Definition REC_p (f: positive -> A) (hi:positive) (dfl:A)
  (OUTSIDE: forall n, (n >= hi)%positive -> f n = dfl):
 forall x, (x <= hi)%positive ->
   {m: PMap.t A | fst m = dfl /\
                  forall n, (n < x \/ n >= hi)%positive ->
                            PMap.get n m = f n}.
Proof.
    intros x0; pattern x0.
    apply Pos.peano_rect; intros.
    exists (PMap.init dfl). simpl.
    split; trivial.
    intros. rewrite PMap.gi.
      destruct H0. xomega.
      symmetry. apply OUTSIDE. assumption.
  - (* Inductive case *)
    assert (HP: (p <= hi)%positive). xomega.
    destruct (X HP) as [m [PDef P]]. clear X HP.
    exists (PMap.set p (f p) m); simpl.
    split; trivial.
    intros. rewrite PMap.gsspec.
       destruct (peq n p).
       congruence.
       apply P. destruct H0. left. xomega. right; assumption.
Defined.

Definition pmap_construct_c
          (f: positive -> A) hi dfl
          (OUTSIDE: forall n, (n >= hi)%positive -> f n = dfl):
   {m: PMap.t A | fst m = dfl /\
                  forall n, PMap.get n m = f n}.
Proof.
 destruct (REC_p f hi dfl OUTSIDE hi) as [m [PDef P]].
   xomega.
   exists m.
   split; trivial.
   intros. apply P. xomega.
Defined.

(*I'd really like to replace dfl hi with dfl n in OUTSIDE,
 so that unreachable elements can have different defaults -- but
  what should I replace fst m = dfl hi with then?*)
Definition REC_d (f: positive -> A) (hi:positive) (dfl:positive -> A)
  (OUTSIDE: forall n, (n >= hi)%positive -> f n = dfl hi):
 forall x, (x <= hi)%positive ->
   {m: PMap.t A | fst m = (dfl hi) /\
                  forall n, (n < x \/ n >= hi)%positive ->
                            PMap.get n m = f n}.
Proof.
    intros x0; pattern x0.
    apply Pos.peano_rect; intros.
    exists (PMap.init (dfl hi)). simpl.
    split; trivial.
    intros. rewrite PMap.gi.
      destruct H0. xomega.
      symmetry. apply OUTSIDE. assumption.
  - (* Inductive case *)
    assert (HP: (p <= hi)%positive). xomega.
    destruct (X HP) as [m [PDef P]]. clear X HP.
    exists (PMap.set p (f p) m); simpl.
    split; trivial.
    intros. rewrite PMap.gsspec.
       destruct (peq n p).
       congruence.
       apply P. destruct H0. left. xomega. right; assumption.
Defined.

Definition pmap_construct_dep
          (f: positive -> A) hi (dfl : positive -> A)
          (OUTSIDE: forall n, (n >= hi)%positive -> f n = dfl hi):
   {m: PMap.t A | fst m = dfl hi /\
                  forall n, PMap.get n m = f n}.
Proof.
 destruct (REC_d f hi dfl OUTSIDE hi) as [m [PDef P]].
   xomega.
   exists m.
   split; trivial.
   intros. apply P. xomega.
Defined.

Definition zmap_finite_c (m: ZMap.t A): Z * Z :=
  (-2 * Z.pos (pmap_finite_c m), 2 * Z.pos (pmap_finite_c m)).

Lemma zmap_finite_sound_c:
  forall (m: ZMap.t A) lo hi, zmap_finite_c m = (lo,hi) ->
    forall n, n < lo \/ n > hi -> ZMap.get n m = fst m.
Proof.
  intros.
  assert (D:= pmap_finite_sound_c m).
  unfold zmap_finite_c in H. inv H.
  unfold ZMap.get. apply D.
  unfold ZIndexed.index. destruct n; zify; omega.
Qed.

Definition REC (f: Z -> A) (lo hi:Z) (dfl:A)
  (OUTSIDE: forall n, n < lo \/ n > hi -> f n = dfl):
 forall x,
  x <= hi -> {m: ZMap.t A | fst m = dfl /\ forall n, n <= x \/ n > hi -> ZMap.get n m = f n}.
intros x0; pattern x0.
apply (well_founded_induction_type (Zwf_well_founded lo)); intros.
    destruct (zlt x lo).
  - (* Base case *)
     exists (ZMap.init dfl).
      split. reflexivity.
      intros. rewrite ZMap.gi.
              symmetry. apply OUTSIDE. omega.
  - (* Inductive case *)
    destruct (X (x - 1)) as [m [Pdef P]].
    red. omega. omega.
    exists (ZMap.set x (f x) m); intros.
    simpl.
    split; trivial.
    intros. rewrite ZMap.gsspec. unfold ZIndexed.eq.
    destruct (zeq n x).
           congruence.
           apply P. omega.
Defined.

Definition zmap_construct_c
    (f: Z -> A) (lo hi:Z) (dfl:A)
    (OUTSIDE: forall n, n < lo \/ n > hi -> f n = dfl) :
  { m : ZMap.t A | fst m = dfl /\ forall n,  ZMap.get n m = f n}.
 destruct (REC f lo hi dfl OUTSIDE hi) as [m [PDef P]].
   omega.
   exists m. split; trivial. intros. apply P. omega.
Defined.

End FINITE_CONSTRUCTIVE.


Require Export P01.

(** **** Exercise: 3 stars (two_loops)  *)
(** Here is a very inefficient way of adding 3 numbers:
  X ::= 0;;
  Y ::= 0;;
  Z ::= c;;
  WHILE X <> a DO
    X ::= X + 1;;
    Z ::= Z + 1
  END;;
  WHILE Y <> b DO
    Y ::= Y + 1;;
    Z ::= Z + 1
  END

    Show that it does what it should by filling in the blanks in the
    following decorated program.

    {{ True }} ->>
    {{ c = 0 + 0 + c }}
  X ::= 0;;
    {{ c = X + 0 + c }}
  Y ::= 0;;
    {{ c = X + Y + c }}
  Z ::= c;;
    {{ Z = X + Y + c }}
  WHILE X <> a DO
      {{ Z = X + Y + c /\ X <> a }} ->>
      {{ (Z+1) = (X+1) + Y + c }}
    X ::= X + 1;;
      {{ (Z+1) = X + Y + c }}
    Z ::= Z + 1
      {{ Z = X + Y + c }}
  END;;
    {{ Z = X + Y + c /\ X = a }} ->>
    {{ Z = a + Y + c }}
  WHILE Y <> b DO
      {{ Z = a + Y + c /\ Y <> b }} ->>
      {{ (Z+1) = a + (Y+1) + c }}
    Y ::= Y + 1;;
      {{ (Z+1) = a + Y + c }}
    Z ::= Z + 1
      {{ Z = a + Y + c }}
  END
    {{ Z = a + Y + c /\ Y = b }} ->>
    {{ Z = a + b + c }}
*)

Theorem add_three_numbers_correct: forall a b c,
  {{ fun st => True }}
  X ::= ANum 0;;
  Y ::= ANum 0;;
  Z ::= ANum c;;
  WHILE BNot (BEq (AId X) (ANum a)) DO
    X ::= APlus (AId X) (ANum 1);;
    Z ::= APlus (AId Z) (ANum 1)
  END;;
  WHILE BNot (BEq (AId Y) (ANum b)) DO
    Y ::= APlus (AId Y) (ANum 1);;
    Z ::= APlus (AId Z) (ANum 1)
  END
  {{ fun st => st Z = a + b + c }}.
Proof.
  intros a b c.
  apply hoare_consequence with (P' := fun st => c = c) (Q' := fun st => st Z = a + st Y + c /\ st Y = b).
  - apply hoare_seq with (Q := fun st => c = st X + c).
    apply hoare_seq with (Q := fun st => c = st X + st Y + c).
    apply hoare_seq with (Q := fun st => st Z = st X + st Y + c).
    apply hoare_seq with (Q := fun st => st Z = a + st Y + c).
    * eapply hoare_consequence_post. apply hoare_while.
      { apply hoare_consequence_pre with (P' := fun st => st Z + 1 = a + (st Y + 1) + c).
        - apply hoare_seq with (Q := fun st => st Z + 1 = a + st Y + c).
          + eapply hoare_consequence_pre. eapply hoare_asgn.
            unfold assert_implies, assn_sub. intros. simpl.
            rewrite t_update_eq. rewrite t_update_neq. assumption.
            unfold not. intros. inversion H0.
          + eapply hoare_consequence_pre. eapply hoare_asgn.
            unfold assert_implies, assn_sub. intros. simpl.
            rewrite t_update_eq. rewrite t_update_neq. assumption.
            unfold not. intros. inversion H0.
        - unfold assert_implies. intros st [H HY]. omega. }
      { unfold assert_implies. intros st [H HY]. split.
        - assumption.
        - unfold not, bassn in HY. simpl in HY. rewrite negb_true_iff in HY.
          apply eq_false_true_abs in HY. apply beq_nat_true in HY. assumption. }
    * eapply hoare_consequence_post. apply hoare_while.
      { apply hoare_consequence_pre with (P' := fun st => st Z + 1 = (st X + 1) + st Y + c).
        - apply hoare_seq with (Q := fun st => st Z + 1 = st X + st Y + c).
          + unfold hoare_triple. intros st st' HZ H. inversion HZ. subst. simpl.
            rewrite t_update_eq. rewrite t_update_neq. rewrite t_update_neq. assumption.
            unfold not. intros Hcontra. inversion Hcontra.
            unfold not. intros Hcontra. inversion Hcontra.
          + unfold hoare_triple. intros st st' HX H. inversion HX. subst. simpl.
            rewrite t_update_eq. rewrite t_update_neq. rewrite t_update_neq. assumption.
            unfold not. intros Hcontra. inversion Hcontra.
            unfold not. intros Hcontra. inversion Hcontra.
        - unfold assert_implies. intros st [H HX]. omega. }
      { unfold assert_implies. intros st [H HX].
        unfold not, bassn in HX. simpl in HX. rewrite negb_true_iff in HX.
        apply eq_false_true_abs in HX. apply beq_nat_true in HX. omega. }
    * unfold hoare_triple. intros st st' HZ H. inversion HZ. subst n x a1 st0 st'. simpl.
      rewrite t_update_eq. rewrite t_update_neq. rewrite t_update_neq. assumption.
      unfold not. intros Hcontra. inversion Hcontra.
      unfold not. intros Hcontra. inversion Hcontra.
    * unfold hoare_triple. intros st st' HY H. inversion HY. subst n x a1 st0 st'. simpl.
      rewrite t_update_eq. rewrite t_update_neq. omega.
      unfold not. intros Hcontra. inversion Hcontra.
    * unfold hoare_triple. intros st st' HX H. inversion HX. subst. reflexivity.
  - unfold assert_implies. intros. reflexivity.
  - unfold assert_implies. intros st [H HY]. rewrite <- HY. assumption.
Qed.


Theorem proof : forall A B , A /\ B -> B /\ A.
intros.
elim H.
split.
Restart.
intros.
elim H.
auto. Show Proof.
Qed.


Require Import List.
Require Import QArith.

Definition l23 : list Q
  := 2#1 :: 3#1 :: nil.
Definition l123 : list Q
  := 1#1 :: l23.

Eval compute in (hd l123).

FixedPoint sum_list (A: (list Q)):=
match hd A


(***************************************************************************
* STLC + capabilities + =>, based on formalization                         *
* in the library _locally nameless_                                        *
***************************************************************************)

Set Implicit Arguments.
Require Import LibLN.

(* ********************************************************************** *)
(* ********************************************************************** *)
(* ********************************************************************** *)
(** * Definitions *)

(* ********************************************************************** *)
(** ** Grammars *)

Inductive typ : Set :=
  | typ_top          : typ
  | typ_base         : typ
  | typ_eff          : typ
  | typ_arrow        : typ -> typ -> typ
  | typ_stoic        : typ -> typ -> typ.

Inductive trm : Set :=
  | trm_top  : trm
  | trm_bvar : nat -> trm
  | trm_fvar : var -> trm
  | trm_abs  : typ -> trm -> trm
  | trm_app  : trm -> trm -> trm.

Coercion trm_bvar : nat >-> trm.
Coercion trm_fvar : var >-> trm.

(* ********************************************************************** *)
(** ** Opening *)

Fixpoint open_rec (k : nat) (u : trm) (t : trm) {struct t} : trm :=
  match t with
  | trm_bvar i    => If k = i then u else (trm_bvar i)
  | trm_fvar x    => trm_fvar x
  | trm_top       => trm_top
  | trm_abs T t1  => trm_abs T (open_rec (S k) u t1)
  | trm_app t1 t2 => trm_app (open_rec k u t1) (open_rec k u t2)
  end.

Definition open t u := open_rec 0 u t.

Notation "{ k ~> u } t" := (open_rec k u t) (at level 67).
Notation "t ^^ u" := (open t u) (at level 67).
Notation "t ^ x" := (open t (trm_fvar x)).

(* ********************************************************************** *)
(** ** Local closure *)

Inductive term : trm -> Prop :=
  | term_top : term trm_top
  | term_var : forall x,
      term (trm_fvar x)
  | term_abs : forall L T t1,
      (forall x, x \notin L -> term (t1 ^ x)) ->
      term (trm_abs T t1)
  | term_app : forall t1 t2,
      term t1 ->
      term t2 ->
      term (trm_app t1 t2).

(* ********************************************************************** *)
(** ** Semantics *)

Inductive value : trm -> Prop :=
  | value_top : value trm_top
  | value_abs : forall t1 T,
      term (trm_abs T t1) -> value (trm_abs T t1)
  | value_var : forall x, value (trm_fvar x).

Reserved Notation "t --> t'" (at level 68).

Inductive red : trm -> trm -> Prop :=
  | red_beta_abs : forall t1 t2 T,
      term (trm_abs T t1) -> T <> typ_top ->
      value t2 ->
      (trm_app (trm_abs T t1) t2) --> (t1 ^^ t2)
  | red_beta_top : forall t1 t2 T,
      term (trm_abs T t1) -> T = typ_top ->
      value t2 ->
      (trm_app (trm_abs T t1) t2) --> (t1 ^^ trm_top)
  | red_app_1 : forall t1 t1' t2,
      term t2 ->
      t1 --> t1' ->
      (trm_app t1 t2) --> (trm_app t1' t2)
  | red_app_2 : forall t1 t2 t2',
      value t1 ->
      t2 --> t2' ->
      (trm_app t1 t2) --> (trm_app t1 t2')

where "t --> t'" := (red t t').

(* ********************************************************************** *)
(** ** Environments *)

Definition ctx := env typ.

Fixpoint closed_typ(t: typ) := match t with
  | typ_top             => true
  | typ_base            => true
  | typ_eff             => false
  | typ_arrow U V       => false
  | typ_stoic U V       => true
  end.

Fixpoint pure(E: ctx) := match E with
  | nil => nil
  | cons (x, T) E' => if closed_typ T then
                        cons (x, T) (pure E')
                      else
                        pure E'
  end.

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

Inductive sub: typ -> typ -> Prop :=
  | sub_top : forall T, sub T typ_top
  | sub_refl: forall T, sub T T
  | sub_trans: forall S T U, sub S T -> sub T U -> sub S U
  | sub_degen: forall S T, sub (typ_stoic S T) (typ_arrow S T)
  | sub_arrow : forall S1 S2 T1 T2,
      sub T1 S1 ->
      sub S2 T2 ->
      sub (typ_arrow S1 S2) (typ_arrow T1 T2)
  | sub_stoic : forall S1 S2 T1 T2,
      sub T1 S1 ->
      sub S2 T2 ->
      sub (typ_stoic S1 S2) (typ_stoic T1 T2).

Reserved Notation "E |= t ~: T" (at level 69).

Inductive typing : ctx -> trm -> typ -> Prop :=
  | typing_top : forall E, ok E -> E |= trm_top ~: typ_top
  | typing_var : forall E x T,
      ok E ->
      binds x T E ->
      E |= (trm_fvar x) ~: T
  | typing_abs: forall L E V e1 T1,
      ok E ->
      (forall x, x \notin L ->
         (E & x ~ V) |= (e1 ^ x) ~: T1) ->
      E |= (trm_abs V e1) ~: (typ_arrow V T1)
  | typing_stoic: forall L E V e1 T1,
      ok E ->
      (forall x, x \notin L ->
         ((pure E) & x ~ V) |= (e1 ^ x) ~: T1) ->
      E |= (trm_abs V e1) ~: (typ_stoic V T1)
  | typing_app : forall S T E t1 t2,
      E |= t1 ~: (typ_arrow S T) ->
      E |= t2 ~: S ->
      E |= (trm_app t1 t2) ~: T
  | typing_sub : forall S E e T,
      E |= e ~: S ->
      sub S T ->
      E |= e ~: T

where "E |= t ~: T" := (typing E t T).

Axiom typing_equiv_top : forall E S T t,
  E |= t ~: typ_stoic typ_top (typ_arrow S T) ->
  E |= t ~: typ_stoic typ_top (typ_stoic S T).

Axiom typing_equiv_base : forall E S T t,
  E |= t ~: typ_stoic typ_base (typ_arrow S T) ->
  E |= t ~: typ_stoic typ_base (typ_stoic S T).

Axiom typing_equiv_stoic : forall E U V S T t,
  E |= t ~: typ_stoic (typ_stoic U V) (typ_arrow S T) ->
  E |= t ~: typ_stoic (typ_stoic U V) (typ_stoic S T).

Axiom typing_poly : forall E U V S T t1 t2,
  E |= t1 ~: typ_stoic (typ_arrow U V) (typ_arrow S T) ->
  E |= t2 ~: typ_stoic U V ->
  E |= trm_app t1 t2 ~: typ_stoic S T.

(* ********************************************************************** *)
(** ** Statement of theorems *)

Definition preservation_statement := forall E t t' T,
  E |= t ~: T ->
  t --> t' ->
  E |= t' ~: T.

Definition progress_statement := forall t T,
  empty |= t ~: T ->
     value t
  \/ exists t', t --> t'.

(* inhabitable env *)
Inductive inhabitable: ctx -> Prop :=
  | inhabitable_empty: inhabitable empty
  | inhabitable_push: forall x y z t T E,
                        inhabitable E ->
                        value t ->
                        x ~ typ_base & y ~ typ_eff |= t ~: T ->
                        z # E ->
                        inhabitable (E & z ~ T).

(* Capability-safe types are not capability producing, i.e. capable of
   creating an instance of E *)

Inductive capsafe: typ -> Prop :=
| capsafe_top: capsafe typ_top
| capsafe_base: capsafe typ_base
| capsafe_eff_any: forall S T, caprod S -> capsafe (typ_stoic S T)
| capsafe_any_safe: forall S T, capsafe T -> capsafe (typ_stoic S T)
| capsafe_eff_any_free: forall S T, caprod S -> capsafe (typ_arrow S T)
| capsafe_any_safe_free: forall S T, capsafe T -> capsafe (typ_arrow S T)

with caprod: typ -> Prop :=
 | caprod_eff: caprod typ_eff
 | caprod_safe_eff: forall S T, capsafe S -> caprod T -> caprod (typ_stoic S T)
 | caprod_safe_eff_free: forall S T, capsafe S -> caprod T -> caprod (typ_arrow S T).

(* capsafe environment *)
Inductive healthy: ctx -> Prop :=
  | healthy_empty: healthy empty
  | healthy_push: forall x E T, capsafe T -> healthy E ->
                                healthy (E & x ~ T).

Definition inhabitable_pure_healthy_statement := forall E,
  inhabitable E -> pure E = E -> healthy E.

Definition effect_safety_no_capability := forall E, healthy E ->
  ~exists e, typing E e typ_eff.

Definition effect_safety_arrow_closed := forall E t1 t2 T, healthy E ->
  pure E = E ->
  typing E (trm_app t1 t2) T  ->
  exists S1 S2, typing E t1 (typ_stoic S1 S2).

(* ********************************************************************** *)
(* ********************************************************************** *)
(* ********************************************************************** *)
(** * Infrastructure *)

(** ** Free variables *)

Fixpoint fv (t : trm) {struct t} : vars :=
  match t with
  | trm_bvar i    => \{}
  | trm_top       => \{}
  | trm_fvar x    => \{x}
  | trm_abs T t1  => (fv t1)
  | trm_app t1 t2 => (fv t1) \u (fv t2)
  end.

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

Reserved Notation "[ z ~> u ] t" (at level 69).

Fixpoint subst (z : var) (u : trm) (t : trm) {struct t} : trm :=
  match t with
  | trm_bvar i    => trm_bvar i
  | trm_top       => trm_top
  | trm_fvar x    => If x = z then u else (trm_fvar x)
  | trm_abs T t1    => trm_abs T ([ z ~> u ] t1)
  | trm_app t1 t2 => trm_app ([ z ~> u ] t1) ([ z ~> u ] t2)
  end

where "[ z ~> u ] t" := (subst z u t).

(* ********************************************************************** *)
(** ** Tactics *)

Ltac gather_vars :=
  let A := gather_vars_with (fun x : vars => x) in
  let B := gather_vars_with (fun x : var => \{x}) in
  let C := gather_vars_with (fun x : ctx => dom x) in
  let D := gather_vars_with (fun x : trm => fv x) in
  constr:(A \u B \u C \u D).

Ltac pick_fresh x :=
  let L := gather_vars in (pick_fresh_gen L x).

Tactic Notation "apply_fresh" constr(T) "as" ident(x) :=
  apply_fresh_base T gather_vars x.

Tactic Notation "apply_fresh" "*" constr(T) "as" ident(x) :=
  apply_fresh T as x; autos*.
Tactic Notation "apply_fresh" constr(T) :=
  apply_fresh_base T gather_vars ltac_no_arg.
Tactic Notation "apply_fresh" "*" constr(T) :=
  apply_fresh T; auto_star.

(* ********************************************************************** *)
(** ** Automation *)

Hint Constructors term value red sub typing.

(* ********************************************************************** *)
(* ********************************************************************** *)
(* ********************************************************************** *)
(** * Safty *)

(* ********************************************************************** *)
(** ** lemmas *)

Lemma open_rec_term_core :forall t j v i u, i <> j ->
  {j ~> v}t = {i ~> u}({j ~> v}t) -> t = {i ~> u}t.
Proof.
  induction t; introv Neq Equ; simpls; inversion* Equ; fequals*.
  case_nat*. case_nat*.
Qed.

Lemma open_rec_term : forall t u,
  term t -> forall k, t = {k ~> u}t.
Proof.
  induction 1; intros; simpl; fequals*. unfolds open.
  pick_fresh x. apply* (@open_rec_term_core t1 0 (trm_fvar x)).
Qed.

Lemma subst_fresh : forall x t u,
  x \notin fv t ->  [x ~> u] t = t.
Proof. intros. induction t; simpls; fequals*. case_var*. Qed.

Lemma subst_open : forall x u t1 t2, term u ->
  [x ~> u] (t1 ^^ t2) = ([x ~> u]t1) ^^ ([x ~> u]t2).
Proof.
  intros. unfold open. generalize 0.
  induction t1; intros; simpl; fequals*.
  case_nat*. case_var*. apply* open_rec_term.
Qed.

Lemma subst_open_var : forall x y u t, y <> x -> term u ->
  ([x ~> u]t) ^ y = [x ~> u] (t ^ y).
Proof. introv Neq Wu. rewrite* subst_open. simpl. case_var*. Qed.

Lemma subst_intro : forall x t u,
  x \notin (fv t) -> term u ->
  t ^^ u = [x ~> u](t ^ x).
Proof.
  introv Fr Wu. rewrite* subst_open.
  rewrite* subst_fresh. simpl. case_var*.
Qed.

(* ********************************************************************** *)
(** ** Preservation of local closure *)

Definition body t :=
  exists L, forall x, x \notin L -> term (t ^ x).

Lemma term_abs_to_body : forall t1 T,
  term (trm_abs T t1) -> body t1.
Proof. intros. unfold body. inversion* H. Qed.

Lemma body_to_term_abs : forall t1 T,
  body t1 -> term (trm_abs T t1).
Proof. intros. inversion* H. Qed.

Hint Resolve term_abs_to_body body_to_term_abs.

Lemma subst_term : forall t z u,
  term u -> term t -> term ([z ~> u]t).
Proof.
  induction 2; simpls*.
  case_var*.
  apply_fresh term_abs. rewrite* subst_open_var.
Qed.

Hint Resolve subst_term.

Lemma open_term : forall t u,
  body t -> term u -> term (t ^^ u).
Proof.
  intros. destruct H. pick_fresh y. rewrite* (@subst_intro y).
Qed.

Hint Resolve open_term.

(* ********************************************************************** *)
(** ** Regularity of relations *)

Lemma typing_regular : forall E e T,
  typing E e T -> ok E /\ term e.
Proof.
  split. induction* H.

  induction H; autos; eapply term_abs; eauto.
Qed.

Lemma open_fv_subset: forall e x k,
  fv e \c fv ({k ~> x}e).
Proof. intros. gen k. induction e; intros; simpl;
                      autos* subset_empty_l subset_refl  subset_union_2.
Qed.

Lemma subset_trans: forall (T: Type) (a b c: fset T),
  a \c b -> b \c c -> a \c c.
Proof. unfolds subset. autos. Qed.

Lemma subset_strengthen: forall (T: Type) (a b: fset T) (x: T),
  a \c (b \u \{x}) -> x \notin a -> a \c b.
Proof. unfolds subset. intros. forwards K: (H x0 H1).
  rewrite in_union in K. destruct* K.
  rewrite in_singleton in H2. subst.
  tryfalse.
Qed.

Lemma value_regular : forall e,
  value e -> term e.
Proof. induction 1; autos*. Qed.

Lemma red_regular : forall e e',
  red e e' -> term e /\ term e'.
Proof. induction 1; autos* value_regular. Qed.

Hint Extern 1 (ok ?E) =>
  match goal with
  | H: typing E _ _ |- _ => apply (proj1 (typing_regular H))
  end.

Hint Extern 1 (term ?t) =>
  match goal with
  | H: typing _ t _ |- _ => apply (proj2 (typing_regular H))
  | H: red t _ |- _ => apply (proj1 (red_regular H))
  | H: red _ t |- _ => apply (proj2 (red_regular H))
  | H: value t |- _ => apply (value_regular H)
  end.

(* ********************************************************************** *)
(** * Properties of environment *)

Lemma pure_closed: forall E x T, binds x T (pure E) -> closed_typ T = true.
Proof. intros. inductions E.
  simpls. rewrite <- empty_def in H. false* binds_empty_inv.
  destruct a. simpls. cases* (closed_typ t).
    rewrite cons_to_push in H. destruct (classic (x = v)).
    substs. lets: binds_push_eq_inv H. subst*.
    lets*: binds_push_neq_inv H H0.
Qed.

Lemma pure_dist: forall E F, pure (E & F) = pure E & pure F.
Proof. rewrite concat_def. intros. gen E. induction F; intros E; autos.
  rewrite LibList.app_cons. destruct a.
  simpl. destruct* (closed_typ t). rewrite LibList.app_cons. rewrite* <- IHF.
Qed.

Lemma pure_dom_subset : forall E, dom (pure E) \c dom E.
Proof. intros. induction E.
  simpl. apply subset_refl.
  destruct a. cases t; simpls;
   try match goal with
           [|- dom (cons _ _) \c dom (cons _ _)] =>
           repeat(rewrite cons_to_push);
             repeat(rewrite dom_to_push);
             repeat(rewrite dom_concat);
             autos* subset_union_2 subset_refl subset_trans
         | [|- dom _ \c dom (cons _ _)] =>
           rewrite cons_to_push; rewrite dom_push;
           autos* subset_trans IHE subset_union_weak_r
       end.
Qed.

Lemma pure_binds: forall E x v, ok E -> binds x v (pure E) -> binds x v E.
Proof. intros. induction E.
  simpl in *. autos.
  destruct a.
    simpl in *.  rewrite cons_to_push in *. destruct (closed_typ t).
      destruct (binds_push_inv H0).
        destruct H1. substs. apply* binds_push_eq.
        destruct H1. apply* binds_push_neq.
      rewrite <- concat_empty_r. apply binds_weaken; rewrite* concat_empty_r.
Qed.

Lemma pure_binds_in: forall E x T, closed_typ T = true ->
   binds x T E -> binds x T (pure E).
Proof. intros. induction E.
  (* nil *)
  rewrite <- empty_def in H0. destruct(binds_empty_inv H0).
  (* x::xs *)
  destruct a.
    simpls. rewrite cons_to_push in *. destruct (binds_push_inv H0).
    destruct H1. inversions H2. rewrite* H.
    destruct H1. destruct* (closed_typ t).
Qed.

Lemma pure_ok : forall E,
  ok E -> ok (pure E).
Proof. intros. induction* E.
  destruct a. rewrite cons_to_push in H.
    destructs (ok_push_inv H). simpl. destruct* (closed_typ t).
    rewrite cons_to_push. apply ok_push. autos.
    lets: pure_dom_subset E. unfolds subset.
    unfolds notin. autos.
Qed.

Lemma pure_empty : pure empty = empty.
Proof. rewrite empty_def. reflexivity. Qed.

Lemma pure_single_true : forall x U, closed_typ U = true ->
  pure (x ~ U) = x ~ U.
Proof. intros.
  replace (x ~ U) with (empty & x ~ U) by rewrite* concat_empty_l.
  rewrite <- cons_to_push. simpls. rewrite H.
  rewrite pure_empty. reflexivity.
Qed.

Lemma pure_single_false : forall x U, closed_typ U = false ->
  pure (x ~ U) = empty.
Proof. intros.
  replace (x ~ U) with (empty & x ~ U) by rewrite* concat_empty_l.
  rewrite <- cons_to_push. simpls. rewrite H.
  rewrite pure_empty. reflexivity.
Qed.

Lemma pure_eq : forall E, pure (pure E) = pure E.
Proof. intros. induction E; autos.
  destruct a.
  simpls. remember (closed_typ t). symmetry in Heqb. destruct* b.
    simpls. rewrite* Heqb. rewrite* IHE.
Qed.

Lemma typing_env_fv : forall E e T,
  typing E e T -> fv e \c dom E.
Proof. intros. induction* H; subst; simpl; try solve [apply subset_empty_l].
  (* var *)
  forwards~ K:  get_some_inv (binds_get H0).
  unfolds. intros. rewrite in_singleton in H1. subst*.
  (* abs *)
  pick_fresh x. forwards~ K: H1 x.
  rewrite dom_concat in K. rewrite dom_single in K.
  forwards~ : subset_strengthen (subset_trans (@open_fv_subset e1 x 0) K).
  (* stoic *)
  pick_fresh x. forwards~ K: H1 x.
  rewrite dom_concat in K. rewrite dom_single in K.
  forwards~ : subset_strengthen (subset_trans (@open_fv_subset e1 x 0) K).
  eapply subset_trans. apply H2. apply pure_dom_subset.
  (* app *)
  replace (dom E) with (dom E \u dom E) by (autos* union_same).
    apply subset_union_2; autos.
Qed.

(* ********************************************************************** *)
(** ** subtyping properties *)

Lemma sub_stoic_inv: forall T U1 U2,
  sub T (typ_stoic U1 U2) ->
  exists S1 S2, T = typ_stoic S1 S2 /\ sub U1 S1 /\ sub S2 U2.
Proof. intros. gen_eq S: (typ_stoic U1 U2). gen U1 U2.
  inductions H; intros; substs; tryfalse; jauto.
  forwards~ : IHsub2 U1 U2. destruct H1 as [M1 [M2 H1]].
    forwards~ : IHsub1 M1 M2; jauto.
  inversions* H1.
Qed.

Lemma sub_arrow_inv: forall T U1 U2,
  sub T (typ_arrow U1 U2) ->
  exists S1 S2, (T = typ_arrow S1 S2 \/ T = typ_stoic S1 S2) /\ sub U1 S1 /\ sub S2 U2.
Proof. intros.
  gen_eq S: (typ_arrow U1 U2).  gen U1 U2.
  inductions H; intros; substs; tryfalse; jauto.
  forwards~ : IHsub2 U1 U2. destruct* H1 as [M1 [M2 [H1 [H2 H3]]]]. destruct* H1.
    substs. forwards~ : IHsub1 M1 M2. forwards~ : IHsub2 U1 U2. jauto.
    substs. lets*: sub_stoic_inv H. jauto.
  inversions H0. jauto.
  inversions H1. jauto.
Qed.

Lemma sub_arrow_inv_sub: forall S1 S2 U1 U2,
  sub (typ_arrow S1 S2) (typ_arrow U1 U2) ->
  sub U1 S1 /\ sub S2 U2.
Proof. intros. lets: sub_arrow_inv H. destruct H0 as [S3 [S4 [H1 [H2 H3]]]].
  destruct H1 as [H4 | H4]; inversion* H4.
Qed.

Lemma sub_stoic_inv_sub: forall S1 S2 U1 U2,
  sub (typ_stoic S1 S2) (typ_stoic U1 U2) ->
  sub U1 S1 /\ sub S2 U2.
Proof. intros. lets: sub_stoic_inv H. destruct H0 as [S3 [S4 [H1 [H2 H3]]]].
  inversions* H1.
Qed.

Lemma sub_arrow_mixed_inv_sub: forall S1 S2 U1 U2,
  sub (typ_stoic S1 S2) (typ_arrow U1 U2) ->
  sub U1 S1 /\ sub S2 U2.
Proof. intros. lets: sub_arrow_inv H. destruct H0 as [S3 [S4 [H1 [H2 H3]]]].
  destruct H1 as [H1 | H1]; inversions* H1.
Qed.

Lemma sub_arrow_mixed_inv_false: forall S1 S2 U1 U2,
  sub (typ_arrow S1 S2) (typ_stoic U1 U2) -> False.
Proof. intros. lets: sub_stoic_inv H. false* H0. Qed.

Lemma sub_base_eq: forall S, sub S typ_base -> S = typ_base.
Proof. intros. inductions H; auto. Qed.

Lemma sub_top_eq: forall S, sub typ_top S -> S = typ_top.
Proof. intros. inductions H; auto. Qed.

Lemma sub_top_neq: forall S T, sub S T -> T <> typ_top -> S <> typ_top.
Proof. intros. inductions H; try solve [intros Hc; false]; auto. Qed.

Lemma sub_closed: forall S T, sub S T -> T <> typ_top ->
  closed_typ T = true -> closed_typ S = true.
Proof. intros. destruct T; auto.
  lets: sub_base_eq H. substs*.
  lets: sub_stoic_inv H. destruct H2 as [S1 [S2 [H2 _]]]. substs*.
Qed.

Hint Resolve sub_arrow_mixed_inv_false sub_base_eq.

(* ********************************************************************** *)
(** * capsafe/caprod properties *)

Hint Constructors capsafe caprod.

Lemma capsafe_not_caprod : forall T, capsafe T -> ~ caprod T.
Proof. intros T H Hc. inductions T; inversions Hc;
  try solve [inversions H | inversions H; auto].
Qed.

Lemma caprod_not_capsafe : forall T, caprod T -> ~capsafe T.
Proof. intros T H Hc. inductions T; inversions Hc;
  try solve [inversions H | inversions H; auto].
Qed.

Lemma capsafe_caprod_classic : forall T, capsafe T \/ caprod T.
Proof. intros T. inductions T; jauto; destruct* IHT2. Qed.

Lemma capsafe_decidable: forall T, capsafe T \/ ~ capsafe T.
Proof. intros. destruct (capsafe_caprod_classic T); auto.
  lets*: caprod_not_capsafe H.
Qed.

Lemma not_capsafe_caprod : forall T, ~capsafe T -> caprod T.
Proof. intros. destruct* (capsafe_caprod_classic T). Qed.

Lemma healthy_env_capsafe : forall E S x, healthy E ->
   binds x S E ->  capsafe S.
Proof. introv H Hb. inductions H.
  false. apply* binds_empty_inv.
  destruct (binds_push_inv Hb).
    destruct H1. subst. destruct* H.
    destruct H1. autos.
Qed.

Hint Resolve healthy_env_capsafe.

(* ********************************************************************** *)
(** ** typing properties *)

Lemma typing_weaken : forall G E F t T,
   (E & G) |= t ~: T ->
   ok (E & F & G) ->
   (E & F & G) |= t ~: T.
Proof.
  introv Typ. gen_eq H: (E & G). gen E F G.
  inductions Typ; intros; subst; autos.
  apply* typing_var. apply* binds_weaken.
  apply_fresh* typing_abs as y. apply_ih_bind* H1.
  apply_fresh* typing_stoic as y.
    repeat(rewrite pure_dist in *). rewrite <- concat_assoc.
    apply* H1. rewrite* concat_assoc.
    rewrite concat_assoc. apply ok_push.
    repeat(rewrite <- pure_dist). apply* pure_ok.
    assert (Ha: y \notin dom E0 \u dom F \u dom G) by autos.
    intros HI. apply Ha. repeat(rewrite dom_concat in HI).
    repeat(rewrite in_union in *). rewrite or_assoc in HI. branches HI.
      branch 1. lets*: pure_dom_subset E0.
      branch 2. lets*: pure_dom_subset F.
      branch 3. lets*: pure_dom_subset G.
  apply* typing_app.
  apply* typing_sub.
Qed.

Lemma typing_weakening_env : forall E F G e T,
  typing (E & (pure F) & G) e T ->
  ok (E & F & G) ->
  typing (E & F & G) e T.
Proof. intros. inductions H; autos.
  apply* typing_var. binds_cases H0; autos.
    apply* binds_weaken. apply* binds_concat_left.
    apply binds_concat_right. apply* pure_binds.
    autos* ok_concat_inv_l ok_concat_inv_r.
  apply_fresh typing_abs as x. auto. apply_ih_bind* H1.
  apply_fresh typing_stoic as x. auto.
    repeat(rewrite pure_dist in *). rewrite pure_eq in *.
    apply_ih_bind* H1. rewrite* pure_eq. forwards~ : H0 x.
  apply* typing_app.
  apply* typing_sub.
Qed.

Lemma typing_inv_abs : forall E S1 e1 T,
  typing E (trm_abs S1 e1) T ->
  forall U1 U2, sub T (typ_arrow U1 U2) ->
     sub U1 S1
  /\ exists S2, exists L, forall x, x \notin L ->
     typing (E & x ~ S1) (e1 ^^ x) S2 /\ sub S2 U2.
Proof.
  introv Typ. gen_eq e: (trm_abs S1 e1). gen S1 e1.
  induction Typ; intros S1 b1 EQ U1 U2 Sub; inversions EQ.
  destruct* (sub_arrow_inv_sub Sub).
  destruct (sub_arrow_mixed_inv_sub Sub). split*.
    let L' := gather_vars in exists T1 L'. intros.
    forwards~ : H0 x. split*.
    rewrite <- (@concat_empty_l typ E). apply typing_weakening_env;
    rewrite* concat_empty_l.
  forwards~ : IHTyp S1 b1. apply sub_trans with T; eauto. jauto.
Qed.

Lemma typing_inv_top : forall E T, E |= trm_top ~: T -> T = typ_top.
Proof. intros. inductions H; auto. substs. lets*: sub_top_eq H0. Qed.

Lemma typing_strengthen_env: forall E u U, value u -> typing E u U -> U <> typ_top ->
  closed_typ U = true -> typing (pure E) u U.
Proof. intros. induction H0; simpls; tryfalse.
  apply typing_var. apply* pure_ok. apply* pure_binds_in.
  apply_fresh* typing_stoic as y. apply* pure_ok. rewrite* pure_eq.
  inversion H.
  apply typing_sub with S; auto. apply IHtyping; auto.
    forwards~ : sub_top_neq H3 H1. forwards~ : sub_closed H3 H1 H2.
Qed.

Lemma typing_subst : forall F E t T z u U,
  value u -> U <> typ_top ->
  (E & z ~ U & F) |= t ~: T ->
  E |= u ~: U ->
  (E & F) |= [z ~> u]t ~: T.
Proof.
  introv Htop Hv Typt Typu. gen_eq G: (E & z ~ U & F). gen E F.
  induction Typt; intros; subst; simpl subst.
  apply* typing_top.
  case_var.
    binds_get H0. apply_empty* typing_weaken.
    binds_cases H0; apply* typing_var.
  apply_fresh typing_abs as y. auto. rewrite* subst_open_var. apply_ih_bind* H1.
  apply_fresh typing_stoic as y. autos.
    rewrite* subst_open_var.
    (* if U is closed, then use IH; else  x is free in e1; *)
    repeat(rewrite pure_dist in *). cases (closed_typ U).
      (* closed_typ U = true *)
      rewrite* pure_single_true in H1. rewrite <- concat_assoc.
      apply* H1. apply* typing_strengthen_env.
      rewrite* concat_assoc.
      (* closed_typ U = false, z is free in e1 *)
      rewrite* pure_single_false in H0. rewrite concat_empty_r in H0.
      destruct (ok_middle_inv H). forwards~ HI: H0 y.
      rewrite* subst_fresh. lets: typing_env_fv HI. unfolds notin. intros HII.
      assert (HIII: z \in dom (pure E0 & pure F & y ~ V)) by unfolds* subset.
      repeat(rewrite dom_concat in HIII). repeat(rewrite in_union in HIII).
      rewrite dom_single in HIII. rewrite or_assoc in HIII. branches HIII.
        apply H2. lets*: pure_dom_subset E0.
        apply H3. lets*: pure_dom_subset F.
        rewrite in_singleton in H5. substs. apply* Fry. repeat(rewrite in_union).
          autos* in_singleton_self.
  apply* typing_app.
  apply* typing_sub.
Qed.

Lemma typing_subst_top : forall F E t z T,
  (E & z ~ typ_top & F) |= t ~: T ->
  (E & F) |= [z ~> trm_top]t ~: T.
Proof. introv Ht. inductions Ht; simpl; auto.
  case_var.
    binds_get H0. apply* typing_top.
    binds_cases H0; apply* typing_var.
  apply_fresh typing_abs as y. auto. rewrite* subst_open_var. apply_ih_bind* H1.
  apply_fresh typing_stoic as y. autos.
    rewrite* subst_open_var.
    repeat(rewrite pure_dist in *).
    rewrite* pure_single_true in H1. rewrite <- concat_assoc.
    apply* H1. rewrite* concat_assoc.
  apply* typing_app.
  apply* typing_sub.
Qed.

Lemma preservation_result : preservation_statement.
Proof.
  introv Typ. gen t'.
  induction Typ; intros t' Red; inversions Red; try solve [apply* typing_sub].

  lets: typing_inv_abs Typ1. forwards~ : H S T. destruct H0 as [H5 [T1 [L H6]]].
    pick_fresh x. forwards~ : H6 x. rewrite* (@subst_intro x). apply_empty* typing_subst.

  lets: typing_inv_abs Typ1.  forwards~ : H S T. destruct H0 as [H5 [T1 [L H6]]].
    pick_fresh x. forwards~ : H6 x. rewrite* (@subst_intro x). apply_empty* typing_subst_top.
Qed.

Lemma canonical_form_abs : forall t U1 U2,
  value t -> typing empty t (typ_arrow U1 U2) ->
  exists V e1, t = trm_abs V e1.
Proof. introv Val Typ. inductions Typ; inversions Val; jauto.
  false* binds_empty_inv.
  lets*: sub_arrow_inv H. destruct H0 as [S1 [S2 [H1 _]]].
    lets*: typing_inv_top Typ. destruct H1; false.
  clear H IHTyp. false. inductions Typ.
    false* binds_empty_inv. apply* IHTyp.
Qed.

Lemma progress_result : progress_statement.
Proof.
  introv Typ. gen_eq E: (empty:ctx). lets Typ': Typ.
  inductions Typ; intros; subst; autos.
  (* false* binds_empty_inv. *)
  right.
    destruct~ IHTyp1 as [Val1 | [t1' Red1]].
    destruct~ IHTyp2 as [Val2 | [t2' Red2]].
      forwards~ : canonical_form_abs Typ1. destruct H as [V [e H]].
        inversions H. destruct (classic (V = typ_top)).
          exists* (e ^^ trm_top).
          exists* (e ^^ t2).
      exists* (trm_app t1 t2').
      exists* (trm_app t1' t2).
Qed.

(* ********************************************************************** *)
(** * effect safety *)

Lemma capsafe_sub: forall S T, capsafe S -> sub S T -> capsafe T.
Proof.  intros. inductions H0; auto.
  inversions* H.
  inversions* H. destruct* (capsafe_decidable T1).
    lets*: caprod_not_capsafe H1.
    lets*: not_capsafe_caprod H.
  inversions* H. destruct* (capsafe_decidable T1).
    lets*: caprod_not_capsafe H1.
    lets*: not_capsafe_caprod H.
Qed.

Lemma healthy_pure: forall E, healthy E -> healthy (pure E).
Proof. intros. inductions E; simpls*.
  inversions H. rewrite empty_def in H1. inversion H1.
    rewrite <- cons_to_push in H0. inversions H0.
    cases* (closed_typ T). rewrite cons_to_push. apply* healthy_push.
Qed.

Lemma healthy_env_term_capsafe: forall E t T,
  healthy E ->
  E |= t ~: T ->
  capsafe T.
Proof. intros. inductions H0; jauto.
  pick_fresh x. forwards~ : H1 x. destruct* (capsafe_decidable V).
    apply capsafe_any_safe_free. apply* (H2 x).
      apply* healthy_push.
      apply capsafe_eff_any_free. apply* not_capsafe_caprod.
  pick_fresh x. forwards~ : H1 x. destruct* (capsafe_decidable V).
    apply capsafe_any_safe. apply* (H2 x).
      applys~ healthy_push. apply* healthy_pure.
      apply capsafe_eff_any. apply* not_capsafe_caprod.
  forwards~ : IHtyping1 H. forwards~ : IHtyping2 H. inversions* H0.
    lets*: capsafe_not_caprod S.
  forwards~ : capsafe_sub H1.
Qed.

Lemma effect_safety_result_1 : effect_safety_no_capability.
Proof. intros E H He. destruct He.
  lets*: healthy_env_term_capsafe H0. inversions H1.
Qed.

Lemma effect_polymorphism: forall E t T1 T2,
  healthy E -> pure E = E ->
  E |= t ~: typ_arrow T1 T2 ->
  E |= t ~: typ_stoic T1 T2.
Proof. intros E t T1 T2 H Hc Ha. inductions Ha.
  rewrite <- Hc in H0. lets: pure_closed H0. false.
  rewrite <- Hc in H0. apply* typing_stoic.

  (* t = t1 t2 *)
  forwards~ : IHHa1. destruct S.
  forwards~ : typing_equiv_top H0. apply* typing_app.
  forwards~ : typing_equiv_base H0. apply* typing_app.
  lets: healthy_env_term_capsafe H Ha2. inversion H1.
  forwards~ : IHHa2. apply* typing_poly.
  forwards~ : typing_equiv_stoic H0. apply* typing_app.

  lets: sub_arrow_inv H0. destruct H1 as [S1 [S2 [H3 [H4 H5]]]].
    destruct H3. substs. eapply typing_sub; auto.
    assert (sub S (typ_stoic T1 T2)) by (substs; auto).
    apply typing_sub with S; auto.
Qed.

Lemma effect_safety_result_2 : effect_safety_arrow_closed.
Proof. intros E t1 t2 T H1 H2 H3.
  inductions H3; try solve [forwards~ : IHtyping t1 t2].
  forwards~ : effect_polymorphism E t1 S T. iauto.
Qed.

(* This proof ensures that all inhabitable types are capsafe, thus
   justifies the definition of capsafe/caprod.

   This theorem assumes that all inhabitable types in the system can
   be inhabited by a value in the environment {x:B, y:E}. Note that
   variables are values in the system, thus B and E are inhabitable.

   If the term t is not a value, it should be able to take a step and
   preserves the type.

*)

Theorem inhabitable_capsafe: forall x y t T,
  typing (x ~ typ_base & y ~ typ_eff) t T -> value t ->
  capsafe T \/ closed_typ T = false.
Proof. introv Typ Val. inductions Typ; auto.
  destruct (binds_push_inv H0) as [Inv | Inv]; destruct Inv.
    subst. auto.
    destructs (binds_single_inv H2). subst. auto.
  pick_fresh z. forwards~ IH: H0 z. destruct (capsafe_decidable V) as [Case | Case].
    (* capsafe V -> healthy E -> capsafe T1 *)
    rewrite pure_dist, pure_single_true, pure_single_false, concat_empty_r in IH; auto.
    forwards~ Hcap : healthy_env_term_capsafe IH.
      rewrite <- concat_empty_l, concat_assoc. repeat(apply* healthy_push). apply healthy_empty.
    (* caprod V -> capsafe V -> T1 *)
    forwards~ Vcap : not_capsafe_caprod Case.
  inversion Val.
  forwards~ IH : IHTyp. destruct IH.
    left. apply* capsafe_sub. destruct S; try solve [inversion H0].
    destruct T; auto. false (sub_stoic_inv H).
    destruct T; auto. false (sub_stoic_inv H).
Qed.

Theorem inhabitable_pure_healthy: inhabitable_pure_healthy_statement.
Proof. introv In Pure. inductions In.
  apply healthy_empty.
  assert (Closed: closed_typ T = true).
    applys~ pure_closed (E & z ~ T) z.
    rewrite Pure. apply binds_tail.
  forwards~ IH: inhabitable_capsafe H0. destruct IH.
    rewrite pure_dist, pure_single_true in Pure; auto.
      rewrite <- ?cons_to_push in Pure. inversion Pure. rewrite H4.
      apply* healthy_push.
    substs. false*.
Qed.


Require Export com. Import ImpNotations.
Require Export state. Import StateNotations.
Require Export aexp.
Require Export bexp.
Require Import map.

From Coq Require Import Program.Equality.

Reserved Notation
  "'[' c ','  st ']' '~>' st'"
  (at level 40, c custom com at level 99,
    st constr, st' constr at next level).

(* big step evaluation *)
Inductive big_step : com -> state -> state -> Prop :=
  | BS_Skip : forall st,
      [ skip, st ] ~> st
  | BS_Asgn : forall st a x,
      [ x := a, st ] ~> (x !-> aeval st a; st)
  | BS_Seq : forall c1 c2 st st' st'',
      [ c1, st ] ~> st'' ->
      [ c2, st'' ] ~> st' ->
      [ c1 ; c2, st ] ~> st'
  | BS_IfTrue : forall st st' b c1 c2,
      beval st b = true ->
      [ c1, st ] ~> st' ->
      [ if b then c1 else c2 end, st] ~> st'
  | BS_IfFalse : forall st st' b c1 c2,
      beval st b = false ->
      [ c2, st ] ~> st' ->
      [ if b then c1 else c2 end, st] ~> st'
  | BS_WhileFalse : forall st b c,
      beval st b = false ->
      [ while b do c end, st ] ~> st
  | BS_WhileTrue : forall st st' st'' b c,
      beval st b = true ->
      [ c, st ] ~> st'' ->
      [ while b do c end, st'' ] ~> st' ->
      [ while b do c end, st ] ~> st'
  | BS_RepeatTrue : forall st st' b c,
      [ c, st ] ~> st' ->
      beval st' b = true ->
      [ repeat c until b end, st ] ~> st'
  | BS_RepeatFalse : forall st st' st'' b c,
      [ c, st ] ~> st'' ->
      beval st'' b = false ->
      [ repeat c until b end, st'' ] ~> st' ->
      [ repeat c until b end, st ] ~> st'
  where "'[' c ',' st ']' '~>' st'" := (big_step c st st').

Example bs_eval_example1:
  [ x := 2;
    if (x <= 1)
      then y := 3
      else z := 4
    end,
    empty_st
  ] ~>
  (z !-> 4 ; x !-> 2).
Proof.
  apply BS_Seq with (x !-> 2).
  - apply BS_Asgn.

  - apply BS_IfFalse.
    reflexivity.
    apply BS_Asgn.
Qed.

Definition cequiv (c1 c2 : com) : Prop :=
  forall (st st' : state),
    ([ c1, st ] ~> st') <-> ([ c2, st ] ~> st').

Theorem skip_left : forall c,
  cequiv
    <{ skip; c }>
    c.
Proof.
  intros.
  split; intros.
  - inversion H. subst.
    inversion H2. subst.
    exact H5.
  - apply BS_Seq with st.
    apply BS_Skip.
    exact H.
Qed.

Theorem skip_right : forall c,
  cequiv <{ c ; skip }> c.
Proof.
  intros.
  split; intros.
  - inversion H. subst.
    inversion H5. subst.
    exact H2.
  - apply BS_Seq with st'.
    exact H. apply BS_Skip.
Qed.

Theorem if_true: forall b c1 c2,
  bequiv b <{true}> ->
  cequiv
    <{ if b then c1 else c2 end }>
    c1.
Proof.
  intros b c1 c2 Hb.
  split; intros H.
  - inversion H. subst.
    + assumption.
    + unfold bequiv in Hb. simpl in Hb.
      rewrite Hb in H5.
      discriminate.
  - apply BS_IfTrue; try assumption.
    unfold bequiv in Hb. simpl in Hb.
    apply Hb.
Qed.

Theorem if_false: forall b c1 c2,
  bequiv b <{false}> ->
  cequiv
    <{ if b then c1 else c2 end }>
    c2.
Proof.
  intros b c1 c2 Hb.
  split; intros H.
  - inversion H. subst.
    + unfold bequiv in Hb. simpl in Hb.
      rewrite Hb in H5.
      discriminate.
    + assumption.
  - apply BS_IfFalse.
    unfold bequiv in Hb. simpl in Hb.
    apply Hb. assumption.
Qed.

Theorem while_unroll : forall b c,
  cequiv
    <{ while b do c end }>
    <{ if b then c ; while b do c end else skip end }>.
Proof.
  intros b c st st'.
  split; intros Hce.
  - inversion Hce; subst.
    + apply BS_IfFalse. assumption. apply BS_Skip.
    + apply BS_IfTrue. assumption.
      apply BS_Seq with st''. assumption. assumption.
  - inversion Hce; subst.
    + inversion H5; subst.
      apply BS_WhileTrue with st''.
      assumption. assumption. assumption.
    + inversion H5; subst. apply BS_WhileFalse. assumption.
Qed.

(* exercise 2.6 *)
Lemma concat_assoc: forall c c' c'',
  cequiv <{(c; c'); c''}> <{c; (c'; c'')}>.
Proof.
  intros c c' c'' st st'.
  split; intros.
  - inversion H. subst.
    inversion H2. subst.
    apply BS_Seq with st''0.
    assumption.
    apply BS_Seq with st''.
    assumption. assumption.
  - inversion H. subst.
    inversion H5. subst.
    apply BS_Seq with st''0.
    apply BS_Seq with st''.
    assumption. assumption. assumption.
Qed.

(* exercise 2.7 *)
Lemma repeat_unroll: forall b c,
  let r := <{repeat c until b end}> in
  cequiv <{c; if b then skip else r end}> <{r}>.
Proof.
  intros b c r st st'.
  split; intros.
  - inversion H; subst.
    inversion H5; subst.
    inversion H8; subst.
    + apply BS_RepeatTrue. assumption. assumption.
    + apply BS_RepeatFalse with st''.
      assumption. assumption. assumption.
  - inversion H; subst.
    + apply BS_Seq with st'. assumption.
      apply BS_IfTrue. assumption. apply BS_Skip.
    + subst. apply BS_Seq with st''. assumption.
      apply BS_IfFalse. assumption. assumption.
Qed.

Lemma while_true_nonterm : forall b c st st',
  bequiv b <{true}> ->
  ~[ while b do c end, st ] ~> st'.
Proof.
  intros.
  intros Hf.
  remember <{ while b do c end }> as cw eqn:Heqcw.
  induction Hf;
  inversion Heqcw; subst; clear Heqcw.
  - unfold bequiv in H.
    rewrite H in H0. discriminate.
  - apply IHHf2. reflexivity.
Qed.

Theorem bs_eval_deterministic: forall c st st1 st2,
     [c, st] ~> st1 ->
     [c, st] ~> st2 ->
     st1 = st2.
Proof.
  intros c st st1 st2 E1 E2.
  generalize dependent st2.
  induction E1; intros st2 E2; inversion E2; subst.
  - (* BS_Skip *) reflexivity.
  - (* BS_Asgn *) reflexivity.
  - (* BS_Seq *)
    rewrite (IHE1_1 st''0 H1) in *.
    apply IHE1_2. assumption.
  - (* BS_IfTrue, b evaluates to true *)
      apply IHE1. assumption.
  - (* BS_IfTrue,  b evaluates to false (contradiction) *)
      rewrite H in H5. discriminate.
  - (* BS_IfFalse, b evaluates to true (contradiction) *)
      rewrite H in H5. discriminate.
  - (* BS_IfFalse, b evaluates to false *)
      apply IHE1. assumption.
  - (* BS_WhileFalse, b evaluates to false *)
    reflexivity.
  - (* BS_WhileFalse, b evaluates to true (contradiction) *)
    rewrite H in H2. discriminate.
  - (* BS_WhileTrue, b evaluates to false (contradiction) *)
    rewrite H in H4. discriminate.
  - (* BS_WhileTrue, b evaluates to true *)
    rewrite (IHE1_1 st''0 H3) in *.
    apply IHE1_2. assumption.
  - (* BS_RepeatTrue, b evaluates to true *)
    rewrite (IHE1 st2 H2) in *.
    reflexivity.
  - (* BS_RepeatTrue, b evaluates to false (contradiction) *)
    rewrite (IHE1 st'' H2) in *.
    rewrite H in H3. discriminate.
  - (* BS_RepeatFalse, b evaluates to true (contradiction) *)
    rewrite (IHE1_1 st2 H2) in *.
    rewrite H in H5. discriminate.
  - (* BS_RepeatFalse, b evaluates to false *)
    rewrite (IHE1_1 st''0 H2) in *.
    rewrite (IHE1_2 st2 H6) in *.
    reflexivity.
Qed.

(* exercise 2.8 *)
Theorem repeat_equiv_while : forall b c,
  cequiv <{repeat c until b end}> <{c; while ~b do c end}>.
Proof.
  intros. split; intros.
  - dependent induction H; subst.
    + apply BS_Seq with st'. assumption.
      apply BS_WhileFalse. apply bev_not_true_iff_false.
      rewrite <- H0. apply bev_negb_involutive.
    + apply BS_Seq with st''. assumption.
      assert (IHbs_eval3 : [ c; while ~ b do c end, st'' ]~> st').
      apply IHbig_step2. reflexivity.
      dependent destruction IHbs_eval3.
      apply BS_WhileTrue with st''.
      apply bev_not_true_iff_false in H0.
      assumption. assumption. assumption.
  - inversion H; subst; clear H.
    generalize st H2; clear st H2.
    dependent induction H5; intros st0 H2.
    + apply BS_RepeatTrue. assumption.
      apply bev_not_true_iff_false in H.
      rewrite <- H. symmetry.
      apply bev_negb_involutive.
    + apply BS_RepeatFalse with st. assumption.
      apply bev_not_true_iff_false.
      assumption.
      apply IHbig_step2. reflexivity. assumption.
Qed.

Theorem identity_assignment : forall x,
  cequiv <{ x := x }> <{ skip }>.
Proof.
  intros.
  split; intro H; inversion H; subst; clear H.
  - rewrite t_update_same.
    apply BS_Skip.
  - assert (Hx : [ x := x, st' ] ~> (x !-> st' x; st')).
    { apply BS_Asgn. }
    rewrite t_update_same in Hx.
    apply Hx.
Qed.


Load LFindLoad.
From lfind Require Import LFind.
Unset Printing Notations.
Set Printing Implicit.

From QuickChick Require Import QuickChick.
Inductive natural : Type := Succ : natural -> natural |  Zero : natural.
Derive Show for natural. Derive Arbitrary for natural.  Instance Dec_Eq_natural : Dec_Eq natural. Proof. dec_eq. Qed.
Inductive lst : Type := Cons : natural -> lst -> lst |  Nil : lst.

Inductive tree : Type := Node : natural -> tree -> tree -> tree |  Leaf : tree.

Inductive Pair : Type := mkpair : natural -> natural -> Pair
with Zlst : Type := zcons : Pair -> Zlst -> Zlst |  znil : Zlst.

Fixpoint append (append_arg0 : lst) (append_arg1 : lst) : lst
           := match append_arg0, append_arg1 with
              | Nil, x => x
              | Cons x y, z => Cons x (append y z)
              end.

Fixpoint rev (rev_arg0 : lst) : lst
           := match rev_arg0 with
              | Nil => Nil
              | Cons x y => append (rev y) (Cons x Nil)
              end.

Fixpoint qreva (qreva_arg0 : lst) (qreva_arg1 : lst) : lst
           := match qreva_arg0, qreva_arg1 with
              | Nil, x => x
              | Cons z x, y => qreva x (Cons z y)
              end.

Theorem append_nil: forall (l: lst), append l Nil = l.
Proof.
   induction l.
   { simpl. f_equal. assumption. }
   { simpl. reflexivity. }
Qed.

Theorem append_assoc:
   forall (l1 l2 l3: lst), append l1 (append l2 l3) = append (append l1 l2) l3.
Proof.
   induction l1; induction l2; induction l3; try (simpl; reflexivity).
   { simpl. rewrite <- IHl1. f_equal. }
   { simpl. rewrite 2 append_nil. reflexivity. }
   { simpl. rewrite append_nil.  reflexivity. }
   { simpl. rewrite 2 append_nil. reflexivity. }
Qed.

Theorem qreva_append : forall (x y : lst), (qreva x y) = (append (rev x) y).
Proof.
   induction x; induction y; simpl; try reflexivity.
   { rewrite IHx.
   rewrite <- append_assoc.
   f_equal. }
   { rewrite IHx.
   lfind. Admitted.


Require Export Setoid Coq.Classes.Morphisms.
Require Export Sets SetInterface SetConstructs SetProperties.
Require Import EqDec CSetNotation CSetTac Util CSetComputable.

Section theorems.
  Variable X : Type.
  Context `{OrderedType X}.

  Lemma in_add_case s (x y:X)
    : y ∈ {{x}} ∪ s -> x===y \/ (x =/= y /\ y ∈ s).
  Proof.
    cset_tac.
  Qed.

  Lemma in_in_neq s (x y:X)
    : x ∈ s -> ~y ∈ s -> x =/= y.
  Proof.
    cset_tac.
  Qed.

  Lemma minus_inane s (x:X)
    : x ∉ s
    -> s [=] (s\{{x}}).
  Proof.
    cset_tac.
  Qed.

  Lemma incl_set_decomp (s t:set X)
    : s ⊆ t -> t [=] s ∪ (t \ s).
  Proof.
    cset_tac.
  Qed.

  Lemma incl_union_minus (s t:set X)
    : s ⊆ (t ∪ (s \ t)).
  Proof.
    cset_tac.
  Qed.

  Lemma union_minus s (x:X)
    : x ∉ s -> s [=] ({{x}} ∪ s) \ {{x}}.
  Proof.
    cset_tac.
  Qed.

  Lemma set_fact_1 s t (x:X)
    : x ∉ t
    -> {{x}} ∪ (s \ ({{x}} ∪ t)) [=] {{x}} ∪ s \ t.
  Proof.
    cset_tac.
  Qed.

  Lemma incl_not_in (x:X) s t
    : x ∉ s -> s\{{x}} ⊆ t -> s ⊆ t.
  Proof.
    cset_tac.
  Qed.

  Lemma minus_incl_special (c c' d : set X)
    : c ⊆ c'
    -> c ∪ (c' \ (c \ d)) [=] c'.
  Proof.
    cset_tac'.
  Qed.

  Lemma minus_incl_meet_special (c c' d : set X)
    : d ⊆ c
    -> c ⊆ c'
    -> c ∩ (c' \ (c \ d)) [=] d.
  Proof.
    cset_tac.
  Qed.

  Lemma minus_minus_id (s t: set X)
    : s ⊆ t
    -> s [=] t \ (t \ s).
  Proof.
    cset_tac.
  Qed.
End theorems.


Require Import XRbase.
Require Import XRfunctions.
Require Import XRseries.
Require Import XSeqProp.
Require Import Max.
Require Import Nat.
Local Open Scope XR_scope.

Lemma lt_0_5 : R0 < IZR 5.
Proof.
  apply Rplus_lt_0_compat.
  apply Rlt_0_1.
  apply Rmult_lt_0_compat.
  apply Rplus_lt_0_compat.
  apply Rlt_0_1.
  apply Rlt_0_1.
  apply Rplus_lt_0_compat.
  apply Rlt_0_1.
  apply Rlt_0_1.
Qed.

Lemma neq_5_0 : IZR 5 <> IZR 0.
Proof.
  apply IZR_neq. intro h. inversion h.
Qed.

Lemma technic1 : forall eps, eps / (IZR 5) + (IZR 3) * (eps / (IZR 5)) + eps / (IZR 5) = eps.
Proof.
  intro eps.
  replace eps with ((IZR 5) * (eps / (IZR 5))) at 4.
  {
  unfold Rdiv.
  rewrite <- Rmult_assoc.
  rewrite (Rmult_comm _ eps).
  rewrite Rplus_assoc.
  rewrite Rmult_assoc.
  rewrite <- Rmult_plus_distr_l.
  rewrite <- Rmult_plus_distr_l.
  pattern (/ IZR 5) at 1;rewrite <- Rmult_1_l.
  pattern (/ IZR 5) at 3;rewrite <- Rmult_1_l.
  rewrite <- Rmult_plus_distr_r.
  rewrite <- Rmult_plus_distr_r.
  replace R1 with (IZR 1).
  rewrite <- plus_IZR.
  rewrite <- plus_IZR.
  simpl.
  rewrite Rinv_r.
  rewrite Rmult_1_r.
  rewrite Rmult_comm.
  rewrite Rmult_assoc.
  rewrite Rinv_l.
  rewrite Rmult_1_r.
  reflexivity.
  exact neq_5_0.
  exact neq_5_0.
  reflexivity.
  }
    unfold Rdiv. (* Rdiv = (r1, r2) => r1 * / r2 *)
    rewrite <- Rmult_assoc. (*  r1 * r2 * r3 = r1 * (r2 * r3) *)
    apply Rinv_r_simpl_m. (* r1 <> 0 -> r1 * r2 * / r1 = r2 *)
    { apply neq_5_0. }
Qed.

Lemma technic2 : forall eps, R0 < eps ->  R0 < eps / (IZR 5).
Proof.
  intros eps h.
  unfold Rdiv. (* Rdiv = (r1, r2) => r1 * / r2 *)
  apply Rmult_lt_0_compat. (* 0 < r1 -> 0 < r2 -> 0 < r1 * r2 *)
  { apply h. }
  apply Rinv_0_lt_compat. (* 0 < r -> 0 < / r *)
  apply lt_0_5.
Qed.

Local Open Scope nat_scope.

Lemma technic3 : forall N1 N2 N3, max (max N1 N2) N3 >= N2.
Proof.
  intros.
  unfold ge.
  apply le_trans with (max N1 N2). (* n <= m -> m <= p -> n <= p *)
  {
    apply le_max_r. (* n <= max n m *)
  }
  apply le_max_l. (* n <= max n m *)
Qed.

Lemma technic4 : forall N1 N2 N3 k2, max (max N1 N2) N3 + k2 >= N3.
Proof.
intros.
unfold ge.
apply le_trans with (max (max N1 N2) N3).
apply le_max_r.
apply le_plus_l.
Qed.

Local Close Scope nat_scope.

Lemma technic5 : forall x, x / (IZR 3) + x / (IZR 3) + x / (IZR 3) = x.
Proof.
  intro x.
  pattern x at 4; replace x with ((IZR 3) * (x / (IZR 3))).
  {
  unfold Rdiv.
  rewrite <- Rmult_plus_distr_r.
  rewrite <- Rmult_plus_distr_r.
  pattern x at 1 2 3;rewrite <- Rmult_1_r.
  rewrite <- Rmult_plus_distr_l.
  rewrite <- Rmult_plus_distr_l.
  replace R1 with (IZR 1).
  rewrite <- plus_IZR.
  rewrite <- plus_IZR.
  simpl.
  rewrite (Rmult_comm x).
  rewrite Rmult_assoc.
  reflexivity.
  reflexivity.
  }
  unfold Rdiv.
  rewrite <- Rmult_assoc.
  apply Rinv_r_simpl_m.
  replace R0 with (IZR 0).
  apply IZR_neq.
  intro eq;inversion eq.
  reflexivity.
Qed.

Lemma technic6 : forall x, R0 < x -> R0 < x / (IZR 3).
Proof.
  intros x h.
  unfold Rdiv.
  apply Rmult_lt_0_compat.
  apply h.
  apply Rinv_0_lt_compat.
  apply Rplus_lt_0_compat.
  apply Rlt_0_1.
  unfold IPR_2.
  apply Rplus_lt_0_compat.
  apply Rlt_0_1.
  apply Rlt_0_1.
Qed.

Lemma technic7 : forall x, (IZR 3) * x = x + x + x.
Proof.
  intro x.
  pattern x at 2 3 4;rewrite <- Rmult_1_l.
  rewrite <- Rmult_plus_distr_r.
  rewrite <- Rmult_plus_distr_r.
  replace R1 with (IZR 1) ; [ idtac | reflexivity ].
  rewrite <- plus_IZR.
  rewrite <- plus_IZR.
  simpl.
  reflexivity.
Qed.

Lemma insert_in_minus : forall a b c, a - c = a - b + (b - c).
Proof.
  intros.
  unfold Rminus.
  repeat rewrite Rplus_assoc.
  apply Rplus_eq_compat_l.
  repeat rewrite <- Rplus_assoc.
  rewrite Rplus_opp_l.
  rewrite Rplus_0_l.
  reflexivity.
Qed.

Theorem R_complete :
  forall U:nat -> R, Cauchy_crit U -> { l:R | Un_cv U l } .
Proof.
  intros.

  (* opp_seq =  n => - U n *)
  (* EUn = exists i, r = Un i *)
  (* bound = exists m, is_upper_bound E m *)

  (* has_lb = bound (EUn (opp_seq Un)) *)
  (* has_ub = bound (EUn Un) *)

  (* sequence_lb : has_lb U -> nat -> R *)
  (* sequence_ub : has_ub U -> nat -> R *)

  (* cauchy_min : Cauchy_crit Un -> has_lb Un *)
  (* cauchy_maj : Cauchy_crit Un -> has_ub Un *)

  set (Uinf := sequence_lb U (cauchy_min U H)). (* nat -> R *)
  set (Usup := sequence_ub U (cauchy_maj U H)). (* nat -> R *)

  (* min_cv : {l : R | Un_cv (sequence_lb Un (cauchy_min Un H)) l} *)
  (* maj_cv : {l : R | Un_cv (sequence_ub Un (cauchy_maj Un pr)) l} *)

  destruct (min_cv U H) as (linf,hinf).
  fold Uinf in hinf.

  destruct (maj_cv U H) as (lsup, hsup).
  fold Usup in hsup.

  cut (lsup = linf).
  {
    intros eq.
    rewrite <- eq in hinf. clear eq. rename lsup into l. clear linf.
    exists l.
    unfold Un_cv.
    intros eps H0.

    cut (R0 < eps / (IZR 3)).
    {

      intro H4.

      unfold Un_cv in hinf.
      specialize (hinf (eps / (IZR 3))).
      specialize (hinf H4).
      destruct hinf as [x0 H2].

      unfold Un_cv in hsup.
      specialize (hsup (eps / (IZR 3))).
      specialize (hsup H4).
      destruct hsup as [x H1].

      exists (max x x0).
      intros n H3.
      unfold R_dist.

      apply Rle_lt_trans with (Rabs (U n - Uinf n) + Rabs (Uinf n - l)).
      {
        rewrite (insert_in_minus _ (Uinf n) _).
        apply Rabs_triang.
      }
      apply Rle_lt_trans with (Rabs (Usup n - Uinf n) + Rabs (Uinf n - l)).
      {
        rewrite <- (Rplus_comm (Rabs (Uinf n - l))).
        rewrite <- (Rplus_comm (Rabs (Uinf n - l))).
        apply Rplus_le_compat_l.
        rewrite Rabs_right. (* r >= 0 -> Rabs r = r *)
        rewrite Rabs_right.
        {
          unfold Rminus.
          rewrite <- (Rplus_comm (- Uinf n)).
          rewrite <- (Rplus_comm (- Uinf n)).
          apply Rplus_le_compat_l.

          (* Vn_Un_Wn_order :
              V : has_ub Un /\ W : has_lb Un
             sequence_lb Un V n <= U n <= sequence_ub Un W n
          *)
          destruct (Vn_Un_Wn_order U (cauchy_maj U H) (cauchy_min U H) n) as [H5 H8].
          fold Uinf in H5.
          fold Usup in H8.

          apply H8.
        }
        {
          apply Rplus_le_reg_l with (Uinf n).
          rewrite Rplus_0_r.
          rewrite Rplus_minus.

          (* Vn_Un_Wn_order *)
          destruct (Vn_Un_Wn_order U (cauchy_maj U H) (cauchy_min U H) n) as [H5 H6].
          fold Uinf in H5.
          fold Usup in H6.

          apply Rle_trans with (U n).
          apply H5.
          apply H6.
        }
        {
          apply Rplus_le_reg_l with (Uinf n).
          rewrite Rplus_0_r.
          rewrite Rplus_minus.

          (* Vn_Un_Wn_order *)
          destruct (Vn_Un_Wn_order U (cauchy_maj U H) (cauchy_min U H) n) as [H5 H6].
          fold Uinf in H5.
          fold Usup in H6.

          apply H5.
        }
      }
      apply Rle_lt_trans with (Rabs (Usup n - l) + Rabs (l - Uinf n) + Rabs (Uinf n - l)).
      {
        rewrite <- (Rplus_comm (Rabs (Uinf n - l))).
        rewrite <- (Rplus_comm (Rabs (Uinf n - l))).
        apply Rplus_le_compat_l.
        rewrite (insert_in_minus (Usup n) l (Uinf n) ).
        apply Rabs_triang.
      }
      apply Rlt_le_trans with (eps / (IZR 3) + eps / (IZR 3) + eps / (IZR 3)).
      {
        apply Rplus_lt_compat.
        apply Rplus_lt_compat.
        {
          unfold R_dist in H1.
          apply H1.
          unfold ge. apply le_trans with (max x x0).
          apply le_max_l.
          apply H3.
        }
        {
          rewrite <- Rabs_Ropp.
          rewrite Ropp_minus_distr.
          unfold R_dist in H2.
          apply H2.
          unfold ge.
          apply le_trans with (max x x0).
          apply le_max_r.
          apply H3.
        }
        unfold R_dist in H2.
        apply H2.
        unfold ge.
        apply le_trans with (max x x0).
        apply le_max_r.
        apply H3.
      }
      right.
      apply technic5.
    }
    apply technic6.
    apply H0.
  }

  apply cond_eq. (* 0 < e -> | x - y | < e ) -> x = y *)
  intros eps H0.
  cut (R0 < eps / (IZR 5)).
  {
    intro H1.
    unfold Un_cv in hsup, hinf.
    unfold R_dist in hsup, hinf.

    specialize (hsup (eps / (IZR 5))).
    specialize (hinf (eps / (IZR 5))).

    specialize (hsup H1).
    specialize (hinf H1).

    destruct hsup as [N1 H4].
    destruct hinf as [N2 H5].

    unfold Cauchy_crit in H.
    unfold R_dist in H.

    destruct (H (eps / (IZR 5)) H1) as [N3 H6].
    set (N := max (max N1 N2) N3).
    apply Rle_lt_trans with (Rabs (lsup - Usup N) + Rabs (Usup N - linf)).
    {
      rewrite (insert_in_minus lsup (Usup N) linf).
      apply Rabs_triang.
    }
    apply Rle_lt_trans with
    (Rabs (lsup - Usup N) + Rabs (Usup N - Uinf N) + Rabs (Uinf N - linf)).
    {
      rewrite Rplus_assoc.
      apply Rplus_le_compat_l.
      rewrite (insert_in_minus (Usup N) (Uinf N) linf).
      apply Rabs_triang.
    }
    rewrite <- technic1.
    {
      apply Rplus_lt_compat.
      apply Rplus_lt_compat.
      {
        rewrite <- Rabs_Ropp.
        rewrite Ropp_minus_distr.
        apply H4.
        unfold ge.
        unfold N.
        apply le_trans with (max N1 N2).
        apply le_max_l.
        apply le_max_l.
      }
      {
        unfold Usup, Uinf.
        unfold sequence_majorant, sequence_minorant.

        (* approx_maj :
          h : has_ub Un
          0 < eps
          ->  exists k, Rabs (lub Un h - Un k) < eps
        *)
        (* maj_ss : has_ub Un -> has_ub (i => Un (k + i)) *)
          (* cauchy_maj : Cauchy_crit Un -> has_ub Un *)

        assert
          (H7 :=
            approx_maj (fun k:nat => U (N + k)%nat) (maj_ss U N (cauchy_maj U H))).

        assert
          (H8 :=
            approx_min (fun k:nat => U (N + k)%nat) (min_ss U N (cauchy_min U H))).
        cut
          (Usup N =
            majorant (fun k:nat => U (N + k)%nat) (maj_ss U N (cauchy_maj U H))).
        {
          cut
            (Uinf N =
              minorant (fun k:nat => U (N + k)%nat) (min_ss U N (cauchy_min U H))).
          {
            intros H9 H10.
            rewrite <- H9 in H8 |- *.
            rewrite <- H10 in H7 |- *.
            destruct (H7 (eps / (IZR 5)) H1) as [k2 H11].
            destruct (H8 (eps / (IZR 5)) H1) as [k1 H12].

            apply Rle_lt_trans with
              (Rabs (Usup N - U (N + k2)%nat) + Rabs (U (N + k2)%nat - Uinf N)).
            (* r1 <= r2 -> r2 < r3 -> r1 < r3 *)
            {
              rewrite (insert_in_minus (Usup N) (U (N + k2)%nat) (Uinf N)).
              apply Rabs_triang. (* Rabs (a + b) <= Rabs a + Rabs b *)
            }
            apply Rle_lt_trans with
              (Rabs (Usup N - U (N + k2)%nat) + Rabs (U (N + k2)%nat - U (N + k1)%nat) +
                Rabs (U (N + k1)%nat - Uinf N)). (* r1 <= r2 -> r2 < r3 -> r1 < r3 *)
            {
              rewrite Rplus_assoc. (*  r1 + r2 + r3 = r1 + (r2 + r3) *)
              apply Rplus_le_compat_l. (* r1 <= r2 -> r + r1 <= r + r2 *)
              rewrite (insert_in_minus (U (N + k2)%nat) (U (N + k1)%nat) (Uinf N)).
              apply Rabs_triang. (* Rabs (a + b) <= Rabs a + Rabs b *)
            }
            rewrite technic7.
            apply Rplus_lt_compat. (* r1 < r2 -> r3 < r4 -> r1 + r3 < r2 + r4 *)
            apply Rplus_lt_compat. (* r1 < r2 -> r3 < r4 -> r1 + r3 < r2 + r4 *)
            {
              apply H11.
            }
            {
              apply H6.
              { unfold N. apply technic4. }
              { unfold N. apply technic4. }
            }
            rewrite <- Rabs_Ropp. (* Rabs (- x) = Rabs x *)
            replace
            (- (U (N + k1)%nat - Uinf N)) with
            (Uinf N - U (N + k1)%nat).
            { apply H12. }
            {
			unfold Rminus.
			rewrite Ropp_plus_distr.
			rewrite Ropp_involutive.
			rewrite Rplus_comm.
			reflexivity.
			}
          }
          unfold Uinf. unfold sequence_lb.
          reflexivity.
        }
        unfold Usup. unfold sequence_ub.
        reflexivity.
      }
      apply H5.
      unfold N.
      apply technic3.
    }
  }
  apply technic2.
  apply H0.
Qed.


(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *         Copyright INRIA, CNRS and contributors             *)
(* <O___,, * (see version control and CREDITS file for authors & dates) *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)

Require Import Fairness.OrderedType.
Require Import ZArith_base.
Require Import PeanoNat.
Require Import Ascii String.
Require Import NArith Ndec.
Require Import Compare_dec.

(** * Examples of Ordered Type structures. *)

(** First, a particular case of [OrderedType] where
    the equality is the usual one of Coq. *)

Module Type UsualOrderedType.
 Parameter Inline t : Type.
 Definition eq := @eq t.
 Parameter Inline lt : t -> t -> Prop.
 Definition eq_refl := @eq_refl t.
 Definition eq_sym := @eq_sym t.
 Definition eq_trans := @eq_trans t.
 Axiom lt_trans : forall x y z : t, lt x y -> lt y z -> lt x z.
 Axiom lt_not_eq : forall x y : t, lt x y -> ~ eq x y.
 Parameter compare : forall x y : t, Compare lt eq x y.
 Parameter eq_dec : forall x y : t, { eq x y } + { ~ eq x y }.
End UsualOrderedType.

(** a [UsualOrderedType] is in particular an [OrderedType]. *)

Module UOT_to_OT (U:UsualOrderedType) <: OrderedType := U.

(** [nat] is an ordered type with respect to the usual order on natural numbers. *)

Module Nat_as_OT <: UsualOrderedType.

  Definition t := nat.

  Definition eq := @eq nat.
  Definition eq_refl := @eq_refl t.
  Definition eq_sym := @eq_sym t.
  Definition eq_trans := @eq_trans t.

  Definition lt := lt.

  Lemma lt_trans : forall x y z : t, lt x y -> lt y z -> lt x z.
  Proof. unfold lt; intros; apply lt_trans with y; auto. Qed.

  Lemma lt_not_eq : forall x y : t, lt x y -> ~ eq x y.
  Proof. unfold lt, eq; intros ? ? LT ->; revert LT; apply Nat.lt_irrefl. Qed.

  Definition compare x y : Compare lt eq x y.
  Proof.
    case_eq (Nat.compare x y); intro.
    - apply EQ. now apply nat_compare_eq.
    - apply LT. now apply nat_compare_Lt_lt.
    - apply GT. now apply nat_compare_Gt_gt.
  Defined.

  Definition eq_dec := eq_nat_dec.

End Nat_as_OT.

(** [Z] is an ordered type with respect to the usual order on integers. *)

Local Open Scope Z_scope.

Module Z_as_OT <: UsualOrderedType.

  Definition t := Z.
  Definition eq := @eq Z.
  Definition eq_refl := @eq_refl t.
  Definition eq_sym := @eq_sym t.
  Definition eq_trans := @eq_trans t.

  Definition lt (x y:Z) := (x<y).

  Lemma lt_trans : forall x y z, x<y -> y<z -> x<z.
  Proof. exact Z.lt_trans. Qed.

  Lemma lt_not_eq : forall x y, x<y -> ~ x=y.
  Proof. intros x y LT ->; revert LT; apply Z.lt_irrefl. Qed.

  Definition compare x y : Compare lt eq x y.
  Proof.
    case_eq (x ?= y); intro.
    - apply EQ. now apply Z.compare_eq.
    - apply LT. assumption.
    - apply GT. now apply Z.gt_lt.
  Defined.

  Definition eq_dec := Z.eq_dec.

End Z_as_OT.

(** [positive] is an ordered type with respect to the usual order on natural numbers. *)

Local Open Scope positive_scope.

Module Positive_as_OT <: UsualOrderedType.
  Definition t:=positive.
  Definition eq:=@eq positive.
  Definition eq_refl := @eq_refl t.
  Definition eq_sym := @eq_sym t.
  Definition eq_trans := @eq_trans t.

  Definition lt := Pos.lt.

  Definition lt_trans := Pos.lt_trans.

  Lemma lt_not_eq : forall x y : t, lt x y -> ~ eq x y.
  Proof.
  intros x y H. contradict H. rewrite H. apply Pos.lt_irrefl.
  Qed.

  Definition compare x y : Compare lt eq x y.
  Proof.
  case_eq (x ?= y); intros H.
  - apply EQ. now apply Pos.compare_eq.
  - apply LT; assumption.
  - apply GT. now apply Pos.gt_lt.
  Defined.

  Definition eq_dec := Pos.eq_dec.

End Positive_as_OT.

(** [N] is an ordered type with respect to the usual order on natural numbers. *)

Module N_as_OT <: UsualOrderedType.
  Definition t:=N.
  Definition eq:=@eq N.
  Definition eq_refl := @eq_refl t.
  Definition eq_sym := @eq_sym t.
  Definition eq_trans := @eq_trans t.

  Definition lt := N.lt.
  Definition lt_trans := N.lt_trans.
  Definition lt_not_eq := N.lt_neq.

  Definition compare x y : Compare lt eq x y.
  Proof.
  case_eq (x ?= y)%N; intro.
  - apply EQ. now apply N.compare_eq.
  - apply LT. assumption.
  - apply GT. now apply N.gt_lt.
  Defined.

  Definition eq_dec := N.eq_dec.

End N_as_OT.

(** From two ordered types, we can build a new OrderedType
   over their cartesian product, using the lexicographic order. *)

Module PairOrderedType(O1 O2:OrderedType) <: OrderedType.
 Module MO1:=OrderedTypeFacts(O1).
 Module MO2:=OrderedTypeFacts(O2).

 Definition t := prod O1.t O2.t.

 Definition eq x y := O1.eq (fst x) (fst y) /\ O2.eq (snd x) (snd y).

 Definition lt x y :=
    O1.lt (fst x) (fst y) \/
    (O1.eq (fst x) (fst y) /\ O2.lt (snd x) (snd y)).

 Lemma eq_refl : forall x : t, eq x x.
 Proof.
 intros (x1,x2); red; simpl; auto with ordered_type.
 Qed.

 Lemma eq_sym : forall x y : t, eq x y -> eq y x.
 Proof.
 intros (x1,x2) (y1,y2); unfold eq; simpl; intuition.
 Qed.

 Lemma eq_trans : forall x y z : t, eq x y -> eq y z -> eq x z.
 Proof.
 intros (x1,x2) (y1,y2) (z1,z2); unfold eq; simpl; intuition eauto with ordered_type.
 Qed.

 Lemma lt_trans : forall x y z : t, lt x y -> lt y z -> lt x z.
 Proof.
 intros (x1,x2) (y1,y2) (z1,z2); unfold eq, lt; simpl; intuition.
 left; eauto with ordered_type.
 left; eapply MO1.lt_eq; eauto.
 left; eapply MO1.eq_lt; eauto.
 right; split; eauto with ordered_type.
 Qed.

 Lemma lt_not_eq : forall x y : t, lt x y -> ~ eq x y.
 Proof.
 intros (x1,x2) (y1,y2); unfold eq, lt; simpl; intuition.
 apply (O1.lt_not_eq H0 H1).
 apply (O2.lt_not_eq H3 H2).
 Qed.

 Definition compare : forall x y : t, Compare lt eq x y.
 intros (x1,x2) (y1,y2).
 destruct (O1.compare x1 y1).
 apply LT; unfold lt; auto.
 destruct (O2.compare x2 y2).
 apply LT; unfold lt; auto.
 apply EQ; unfold eq; auto.
 apply GT; unfold lt; auto with ordered_type.
 apply GT; unfold lt; auto.
 Defined.

 Definition eq_dec : forall x y : t, {eq x y} + {~ eq x y}.
 Proof.
 intros; elim (compare x y); intro H; [ right | left | right ]; auto.
 auto using lt_not_eq.
 assert (~ eq y x); auto using lt_not_eq, eq_sym.
 Defined.

End PairOrderedType.

(** Even if [positive] can be seen as an ordered type with respect to the
  usual order (see above), we can also use a lexicographic order over bits
  (lower bits are considered first). This is more natural when using
  [positive] as indexes for sets or maps (see FSetPositive and FMapPositive. *)

Module PositiveOrderedTypeBits <: UsualOrderedType.
  Definition t:=positive.
  Definition eq:=@eq positive.
  Definition eq_refl := @eq_refl t.
  Definition eq_sym := @eq_sym t.
  Definition eq_trans := @eq_trans t.

  Fixpoint bits_lt (p q:positive) : Prop :=
   match p, q with
   | xH, xI _ => True
   | xH, _ => False
   | xO p, xO q => bits_lt p q
   | xO _, _ => True
   | xI p, xI q => bits_lt p q
   | xI _, _ => False
   end.

  Definition lt:=bits_lt.

  Lemma bits_lt_trans :
    forall x y z : positive, bits_lt x y -> bits_lt y z -> bits_lt x z.
  Proof.
  induction x.
  induction y; destruct z; simpl; eauto; intuition.
  induction y; destruct z; simpl; eauto; intuition.
  induction y; destruct z; simpl; eauto; intuition.
  Qed.

  Lemma lt_trans : forall x y z : t, lt x y -> lt y z -> lt x z.
  Proof.
  exact bits_lt_trans.
  Qed.

  Lemma bits_lt_antirefl : forall x : positive, ~ bits_lt x x.
  Proof.
  induction x; simpl; auto.
  Qed.

  Lemma lt_not_eq : forall x y : t, lt x y -> ~ eq x y.
  Proof.
  intros; intro.
  rewrite <- H0 in H; clear H0 y.
  unfold lt in H.
  exact (bits_lt_antirefl x H).
  Qed.

  Definition compare : forall x y : t, Compare lt eq x y.
  Proof.
  induction x; destruct y.
  - (* I I *)
    destruct (IHx y) as [l|e|g].
    apply LT; auto.
    apply EQ; rewrite e; red; auto.
    apply GT; auto.
  - (* I O *)
    apply GT; simpl; auto.
  - (* I H *)
    apply GT; simpl; auto.
  - (* O I *)
    apply LT; simpl; auto.
  - (* O O *)
    destruct (IHx y) as [l|e|g].
    apply LT; auto.
    apply EQ; rewrite e; red; auto.
    apply GT; auto.
  - (* O H *)
    apply LT; simpl; auto.
  - (* H I *)
    apply LT; simpl; auto.
  - (* H O *)
    apply GT; simpl; auto.
  - (* H H *)
    apply EQ; red; auto.
  Qed.

  Lemma eq_dec (x y: positive): {x = y} + {x <> y}.
  Proof.
  intros. case_eq (x ?= y); intros.
  - left. now apply Pos.compare_eq.
  - right. intro. subst y. now rewrite (Pos.compare_refl x) in *.
  - right. intro. subst y. now rewrite (Pos.compare_refl x) in *.
  Qed.

End PositiveOrderedTypeBits.

Module Ascii_as_OT <: UsualOrderedType.
  Definition t := ascii.

  Definition eq := @eq ascii.
  Definition eq_refl := @eq_refl t.
  Definition eq_sym := @eq_sym t.
  Definition eq_trans := @eq_trans t.

  Definition cmp : ascii -> ascii -> comparison := Ascii.compare.

  Lemma cmp_eq (a b : ascii):
    cmp a b = Eq  <->  a = b.
  Proof.
    unfold cmp, Ascii.compare.
    rewrite N.compare_eq_iff.
    split. 2:{ intro. now subst. }
    intro H.
    rewrite<- (ascii_N_embedding a).
    rewrite<- (ascii_N_embedding b).
    now rewrite H.
  Qed.

  Lemma cmp_lt_nat (a b : ascii):
    cmp a b = Lt  <->  (nat_of_ascii a < nat_of_ascii b)%nat.
  Proof.
    unfold cmp. unfold nat_of_ascii, Ascii.compare.
    rewrite N2Nat.inj_compare.
    rewrite Nat.compare_lt_iff.
    reflexivity.
  Qed.

  Lemma cmp_antisym (a b : ascii):
    cmp a b = CompOpp (cmp b a).
  Proof.
    unfold cmp.
    apply N.compare_antisym.
  Qed.

  Definition lt (x y : ascii) := (N_of_ascii x < N_of_ascii y)%N.

  Lemma lt_trans (x y z : ascii):
    lt x y -> lt y z -> lt x z.
  Proof.
    apply N.lt_trans.
  Qed.

  Lemma lt_not_eq (x y : ascii):
     lt x y -> x <> y.
  Proof.
    intros L H. subst.
    exact (N.lt_irrefl _ L).
  Qed.

  Local Lemma compare_helper_eq {a b : ascii} (E : cmp a b = Eq):
    a = b.
  Proof.
    now apply cmp_eq.
  Qed.

  Local Lemma compare_helper_gt {a b : ascii} (G : cmp a b = Gt):
    lt b a.
  Proof.
    now apply N.compare_gt_iff.
  Qed.

  Definition compare (a b : ascii) : Compare lt eq a b :=
    match cmp a b as z return _ = z -> _ with
    | Lt => fun E => LT E
    | Gt => fun E => GT (compare_helper_gt E)
    | Eq => fun E => EQ (compare_helper_eq E)
    end Logic.eq_refl.

  Definition eq_dec (x y : ascii): {x = y} + { ~ (x = y)} := ascii_dec x y.
End Ascii_as_OT.

(** [String] is an ordered type with respect to the usual lexical order. *)

Module String_as_OT <: UsualOrderedType.

  Definition t := string.

  Definition eq := @eq string.
  Definition eq_refl := @eq_refl t.
  Definition eq_sym := @eq_sym t.
  Definition eq_trans := @eq_trans t.

  Inductive lts : string -> string -> Prop :=
    | lts_empty : forall a s, lts EmptyString (String a s)
    | lts_tail : forall a s1 s2, lts s1 s2 -> lts (String a s1) (String a s2)
    | lts_head : forall (a b : ascii) s1 s2,
        lt (nat_of_ascii a) (nat_of_ascii b) ->
        lts (String a s1) (String b s2).

  Definition lt := lts.

  Lemma nat_of_ascii_inverse a b : nat_of_ascii a = nat_of_ascii b -> a = b.
  Proof.
    intro H.
    rewrite <- (ascii_nat_embedding a).
    rewrite <- (ascii_nat_embedding b).
    apply f_equal; auto.
  Qed.

  Lemma lts_tail_unique a s1 s2 : lt (String a s1) (String a s2) ->
    lt s1 s2.
  Proof.
    intro H; inversion H; subst; auto.
    remember (nat_of_ascii a) as x.
    apply lt_irrefl in H1; inversion H1.
  Qed.

  Lemma lt_trans : forall x y z : t, lt x y -> lt y z -> lt x z.
  Proof.
    induction x; intros y z H1 H2.
    - destruct y as [| b y']; inversion H1.
      destruct z as [| c z']; inversion H2; constructor.
    - destruct y as [| b y']; inversion H1; subst;
        destruct z as [| c z']; inversion H2; subst.
      + constructor. eapply IHx; eauto.
      + constructor; assumption.
      + constructor; assumption.
      + constructor. eapply lt_trans; eassumption.
  Qed.

  Lemma lt_not_eq : forall x y : t, lt x y -> ~ eq x y.
  Proof.
    induction x; intros y LT.
    - inversion LT. intro. inversion H.
    - inversion LT; subst; intros EQ.
      * specialize (IHx s2 H2).
        inversion EQ; subst; auto.
        apply IHx; unfold eq; auto.
      * inversion EQ; subst; auto.
        apply Nat.lt_irrefl in H2; auto.
  Qed.

  Definition cmp : string -> string -> comparison := String.compare.

  Lemma cmp_eq (a b : string):
    cmp a b = Eq  <->  a = b.
  Proof.
    revert b.
    induction a, b; try easy.
    cbn.
    remember (Ascii.compare _ _) as c eqn:Heqc. symmetry in Heqc.
    destruct c; split; try discriminate;
      try rewrite Ascii_as_OT.cmp_eq in Heqc; try subst;
      try rewrite IHa; intro H.
    { now subst. }
    { now inversion H. }
    { inversion H; subst. rewrite<- Heqc. now rewrite Ascii_as_OT.cmp_eq. }
    { inversion H; subst. rewrite<- Heqc. now rewrite Ascii_as_OT.cmp_eq. }
  Qed.

  Lemma cmp_antisym (a b : string):
    cmp a b = CompOpp (cmp b a).
  Proof.
    revert b.
    induction a, b; try easy.
    cbn. rewrite IHa. clear IHa.
    remember (Ascii.compare _ _) as c eqn:Heqc. symmetry in Heqc.
    destruct c; rewrite Ascii_as_OT.cmp_antisym in Heqc;
      destruct Ascii_as_OT.cmp; cbn in *; easy.
  Qed.

  Lemma cmp_lt (a b : string):
    cmp a b = Lt  <->  lt a b.
  Proof.
    revert b.
    induction a as [ | a_head a_tail ], b; try easy; cbn.
    { split; trivial. intro. apply lts_empty. }
    remember (Ascii.compare _ _) as c eqn:Heqc. symmetry in Heqc.
    destruct c; split; intro H; try discriminate; trivial.
    {
      rewrite Ascii_as_OT.cmp_eq in Heqc. subst.
      apply String_as_OT.lts_tail.
      apply IHa_tail.
      assumption.
    }
    {
      rewrite Ascii_as_OT.cmp_eq in Heqc. subst.
      inversion H; subst. { rewrite IHa_tail. assumption. }
      exfalso. apply (Nat.lt_irrefl (nat_of_ascii a)). assumption.
    }
    {
      apply String_as_OT.lts_head.
      rewrite<- Ascii_as_OT.cmp_lt_nat.
      assumption.
    }
    {
      exfalso. inversion H; subst.
      {
         assert(X: Ascii.compare a a = Eq). { apply Ascii_as_OT.cmp_eq. trivial. }
         rewrite Heqc in X. discriminate.
      }
      rewrite<- Ascii_as_OT.cmp_lt_nat in *.
      unfold Ascii_as_OT.cmp in *.
      rewrite Heqc in *. discriminate.
    }
  Qed.

  Local Lemma compare_helper_lt {a b : string} (L : cmp a b = Lt):
    lt a b.
  Proof.
    now apply cmp_lt.
  Qed.

  Local Lemma compare_helper_gt {a b : string} (G : cmp a b = Gt):
    lt b a.
  Proof.
    rewrite cmp_antisym in G.
    rewrite CompOpp_iff in G.
    now apply cmp_lt.
  Qed.

  Local Lemma compare_helper_eq {a b : string} (E : cmp a b = Eq):
    a = b.
  Proof.
    now apply cmp_eq.
  Qed.

  Definition compare (a b : string) : Compare lt eq a b :=
    match cmp a b as z return _ = z -> _ with
    | Lt => fun E => LT (compare_helper_lt E)
    | Gt => fun E => GT (compare_helper_gt E)
    | Eq => fun E => EQ (compare_helper_eq E)
    end Logic.eq_refl.

  Definition eq_dec (x y : string): {x = y} + { ~ (x = y)} := string_dec x y.
End String_as_OT.


Theorem In_app_iff : forall A l l' (a:A),
  In a (l++l') <-> In a l \/ In a l'.
Proof.
  intros.
  split.
  - induction l as [| h t IH].
    + simpl. intros. right. apply H.
    + simpl. intros.
      apply or_assoc.
      destruct H.
      * left. apply H.
      * right. apply IH. apply H.
  - induction l as [| h t IH].
    + simpl. intros. destruct H.
        destruct H.
        apply H.
    + simpl. intros. destruct H. destruct H.
        left. apply H.
        right. apply IH. left. apply H.
        right. apply IH. right. apply H.
Qed.