Require Import Arith Omega NArith Nomega Word.

Ltac set_evars :=
  repeat match goal with
              | [ |- context[?e] ] => is_evar e; let H := fresh in set (H := e)
            end.

Ltac subst_evars :=
  repeat match goal with
              | [ H := ?e |- _ ] => is_evar e; subst H
            end.

Ltac set_evars_in H :=
  repeat match type of H with
              | context[?e] => is_evar e; let E := fresh in set (E := e) in H
            end.

Theorem f_neq : forall {A B : Type} (f : A -> B) x y, f x <> f y -> x <> y.
Proof.
  intros. unfold not. intro He. rewrite He in H. auto.
Qed.

Create HintDb W2Nat discriminated. (* Straightforward simplifications *)

Hint Rewrite Npow2_nat : W2Nat.

Lemma N2Nat_word : forall sz n, (n < Npow2 sz)%N -> wordToNat (NToWord sz n) = N.to_nat n.
Proof.
  intros. rewrite NToWord_nat. apply wordToNat_natToWord_idempotent.
  rewrite N2Nat.id. assumption.
Qed.

Lemma N2Nat_word'
   : forall sz n, goodSize sz (N.to_nat n) -> wordToNat (NToWord sz n) = N.to_nat n.
Proof.
  intros. rewrite N2Nat_word. trivial. unfold goodSize in H. rewrite <- Npow2_nat in H. nomega.
Qed.
Hint Rewrite NToWord_nat : W2Nat.

Lemma wordToNat_N : forall sz (w:word sz), N.to_nat (wordToN w) = wordToNat w.
Proof.
  intros. rewrite wordToN_nat. autorewrite with N. trivial.
Qed.
Hint Rewrite wordToNat_N : W2Nat.

Hint Rewrite natToWord_wordToNat : W2Nat.

Theorem plus_ovf_l : forall sz x y, $ (wordToNat (natToWord sz x) + y) = natToWord sz (x + y).
Proof.
  intros.
  destruct (wordToNat_natToWord sz x) as [? [Heq ?]]; rewrite Heq.
  replace (x - x0 * pow2 sz + y) with (x + y - x0 * pow2 sz) by omega.
  apply drop_sub; omega.
Qed.

Theorem plus_ovf_r : forall sz x y, $ (x + wordToNat (natToWord sz y)) = natToWord sz (x + y).
Proof.
  intros.
  rewrite plus_comm.
  rewrite plus_ovf_l.
  rewrite plus_comm.
  auto.
Qed.

Theorem plus_ovf_lN : forall sz x y, NToWord sz (wordToN (NToWord sz x) + y) = NToWord sz (x + y).
Proof.
  intros.
  repeat rewrite NToWord_nat.
  repeat rewrite wordToN_nat.
  rewrite <- (N2Nat.id y) at 1.
  rewrite <- Nat2N.inj_add.
  rewrite Nat2N.id.
  rewrite N2Nat.inj_add.
  apply plus_ovf_l.
Qed.

Theorem plus_ovf_rN : forall sz x y, NToWord sz (x + wordToN (NToWord sz y)) = NToWord sz (x + y).
Proof.
  intros.
  rewrite N.add_comm.
  rewrite plus_ovf_lN.
  rewrite N.add_comm.
  auto.
Qed.

Hint Rewrite plus_ovf_l plus_ovf_r : W2Nat.

Theorem mul_ovf_l : forall sz x y, $ (wordToNat (natToWord sz x) * y) = natToWord sz (x * y).
Proof.
  intros.
  destruct (wordToNat_natToWord sz x) as [? [Heq ?]]; rewrite Heq.
  rewrite Nat.mul_sub_distr_r.
  replace (x0 * pow2 sz * y) with (x0 * y * pow2 sz) by ring.
  apply drop_sub.
  replace (x0 * y * pow2 sz) with (x0 * pow2 sz * y) by ring.
  apply mult_le_compat_r; auto.
Qed.

Theorem mul_ovf_r : forall sz x y, $ (x * wordToNat (natToWord sz y)) = natToWord sz (x * y).
Proof.
  intros.
  rewrite mult_comm.
  rewrite mul_ovf_l.
  rewrite mult_comm.
  auto.
Qed.

Theorem mul_ovf_lN : forall sz x y, NToWord sz (wordToN (NToWord sz x) * y) = NToWord sz (x * y).
Proof.
  intros.
  repeat rewrite NToWord_nat.
  repeat rewrite wordToN_nat.
  rewrite <- (N2Nat.id y) at 1.
  rewrite <- Nat2N.inj_mul.
  rewrite Nat2N.id.
  rewrite N2Nat.inj_mul.
  apply mul_ovf_l.
Qed.

Theorem mul_ovf_rN : forall sz x y, NToWord sz (x * wordToN (NToWord sz y)) = NToWord sz (x * y).
Proof.
  intros.
  rewrite N.mul_comm.
  rewrite mul_ovf_lN.
  rewrite N.mul_comm.
  auto.
Qed.

Hint Rewrite mul_ovf_l mul_ovf_r : W2Nat.

(* XXX subtraction *)

Theorem Wneq_out : forall sz (n m:word sz),
  n <> m -> wordToNat n <> wordToNat m.
Proof.
  intuition. apply wordToNat_inj in H0; tauto.
Qed.

Lemma divmod_Ndiv_eucl :
  forall a b Sb,
    Pos.to_nat Sb = S b ->
    N.to_nat (fst (N.pos_div_eucl a (N.pos Sb))) =
    fst (Nat.divmod (Pos.to_nat a) b 0 b) /\
    N.to_nat (snd (N.pos_div_eucl a (N.pos Sb))) =
    b - snd (Nat.divmod (Pos.to_nat a) b 0 b).
Proof.
  intros.
  (* Remember the specs of divmod and pow_div_eucl... *)
  generalize (N.pos_div_eucl_spec a (N.pos Sb)); intro HN.
  generalize (N.pos_div_eucl_remainder a (N.pos Sb)); intro HNR.
  remember (N.pos_div_eucl a (N.pos Sb)) as DN; destruct DN.
  generalize (Nat.divmod_spec (Pos.to_nat a) b 0 b); intro HNat.
  remember (Nat.divmod (Pos.to_nat a) b 0 b) as DNat; destruct DNat.
  simpl.
  destruct HNat; auto.
  (* ... and show that they are equivalent *)
  apply (f_equal nat_of_N) in HN.
  rewrite nat_of_Nplus in HN.
  rewrite nat_of_Nmult in HN.
  repeat rewrite positive_N_nat in HN.
  rewrite H in HN.
  rewrite Nat.mul_0_r in H0.
  rewrite Nat.sub_diag in H0.
  repeat rewrite Nat.add_0_r in H0.
  rewrite Nat.mul_comm in H0.
  clear HeqDN. clear HeqDNat.
  rewrite H0 in HN.
  clear H0.
  assert (N.pos Sb <> 0%N).
  apply Nneq_in. simpl.
  generalize (Pos2Nat.is_pos Sb).
  omega.
  apply Nlt_out in HNR; [|auto].
  rewrite positive_N_nat in HNR.
  simpl in HNR.
  assert (N.to_nat n = n1).
  destruct (lt_eq_lt_dec (N.to_nat n) n1); [destruct s; auto|]; [
    remember (n1 - N.to_nat n) as d;
    assert (n1 = d + N.to_nat n) as He by omega |
    remember (N.to_nat n - n1) as d;
    assert (N.to_nat n = d + n1) as He by omega
  ]; assert (d > 0) by omega;
     rewrite He in HN;
     rewrite Nat.mul_add_distr_r in HN;
     destruct (mult_O_le (S b) d); omega.
  intuition.
Qed.

(* The standard library should really define this... *)
Lemma Ninj_div : forall a a' : N, N.to_nat (a / a') = N.to_nat a / N.to_nat a'.
Proof.
  destruct a.
  destruct a'; [|rewrite Nat.div_0_l]; auto.
  replace 0 with (N.to_nat 0) by auto.
  apply Nneq_out; discriminate.
  unfold N.div, Nat.div.
  intro a'.
  case_eq (N.to_nat a').
  + intro He.
    destruct a'.
    reflexivity.
    inversion He.
    generalize (Pos2Nat.is_pos p0).
    omega.
  + intros.
    simpl.
    destruct a'; try discriminate.
    rewrite positive_N_nat in H.
    apply divmod_Ndiv_eucl; auto.
Qed.

Lemma Ninj_mod : forall a a' : N, N.to_nat a' <> 0 ->
  N.to_nat (a mod a') = (N.to_nat a) mod (N.to_nat a').
Proof.
  destruct a.
  destruct a'; [|rewrite Nat.mod_0_l]; auto.
  replace 0 with (N.to_nat 0) by auto.
  apply Nneq_out. discriminate.
  unfold Nmod, Nat.modulo.
  intros.
  case_eq (N.to_nat a').
  omega.
  simpl.
  destruct a'; try discriminate.
  intro n.
  apply divmod_Ndiv_eucl; auto.
Qed.

Hint Rewrite Ninj_div N2Nat.inj_mul N2Nat.inj_add N2Nat.inj_sub : W2Nat.

Lemma wordToNat_mult : forall sz (n m:word sz),
  NToWord sz (wordToN n * wordToN m)%N = $ (wordToNat n * wordToNat m).
Proof.
  intros.
  replace (NToWord sz (wordToN n * wordToN m)) with (n ^* m) by auto.
  replace n with (natToWord sz (wordToNat n)) at 1 by (apply natToWord_wordToNat).
  replace m with (natToWord sz (wordToNat m)) at 1 by (apply natToWord_wordToNat).
  rewrite <- natToWord_mult. auto.
Qed.

Hint Rewrite wordToNat_mult : W2Nat.

Lemma div_le : forall a b, b <> 0 -> a / b <= a.
Proof.
  intros.
  destruct (Nat.eq_dec a 0).
  rewrite e. rewrite Nat.div_0_l by assumption. omega.
  destruct (Nat.eq_dec b 1).
  rewrite e. rewrite Nat.div_1_r. omega.
  apply Nat.lt_le_incl.
  apply Nat.div_lt; omega.
Qed.

Theorem wordToNat_div : forall sz (a b : word sz), wordToNat b <> 0 ->
  wordToNat (NToWord sz (wordToN a / wordToN b)) = wordToNat a / wordToNat b.
Proof.
  intros.
  rewrite N2Nat_word.
  rewrite Ninj_div.
  repeat rewrite wordToNat_N. trivial.
  apply Nlt_in.
  autorewrite with W2Nat.
  apply le_lt_trans with (m := wordToNat a).
  apply div_le; assumption.
  apply wordToNat_bound.
Qed.

Lemma lt_ovf : forall sz x y, x < wordToNat (natToWord sz y) -> x < y /\ goodSize sz x.
Proof.
  intros.
  destruct (lt_dec y (pow2 sz)); [
    (* Either there's no overflow... *)
    rewrite wordToNat_natToWord_idempotent' in H |
    (* ... or it's true even without the hypothesis *)
    generalize (wordToNat_bound (natToWord sz y))];
  intuition; unfold goodSize in *; omega.
Qed.

Ltac autorewrite_fast_goal_w2nat :=
  set_evars; (rewrite_strat (topdown (hints W2Nat))); subst_evars;
  try autorewrite_fast_goal_w2nat.

Ltac autorewrite_fast_w2nat :=
  match goal with
  | [ H: _ |- _ ] =>
    set_evars_in H; (rewrite_strat (topdown (hints W2Nat)) in H); subst_evars;
    [ try autorewrite_fast_w2nat | try autorewrite_fast_goal_w2nat .. ]
  | [ |- _ ] => autorewrite_fast_goal_w2nat
  end.

(* Do some substitutions [subst] won't. XXX: this doesn't seem very principled; I should think it through *)
Ltac nat_subst :=
  repeat match goal with
  | [ H: # _ = # _ |- _ ] => idtac
  | [ H: # _ = _ |- _ ] => rewrite H
  | [ H: _ = # _ |- _ ] => rewrite <- H
  end.

Ltac goodsizes := idtac;
  repeat match goal with
  | [ w: word ?sz |- _ ] =>
    match goal with
    | [ H: goodSize sz (wordToNat w) |- _ ] => fail 1
    | _ => idtac
    end;
    assert (goodSize sz (wordToNat w)) by (apply wordToNat_bound)
  end.

Ltac word2nat_simpl :=
  try (apply nat_of_N_eq || apply Nneq_in || apply Nlt_in || apply Nge_in || apply N2Nat.inj || apply wordToNat_inj); (* XXX still causes hangs: simpl; *)
  unfold wplus, wminus, wmult, wdiv, wmod, wordBin in *;
  repeat match goal with
  | [ H : _ <> _ |- _ ] => (apply Nneq_out in H || apply Wneq_out in H); nsimp H
  | [ H : _ = _ -> False |- _ ] => (apply Nneq_out in H || apply Wneq_out in H); nsimp H
  | [ H : _ |- _ ] => (apply (f_equal nat_of_N) in H || apply (f_equal (@wordToNat _)) in H
             || apply Nlt_out in H || apply Nge_out in H); nsimp H
  end;
  try autorewrite_fast_w2nat;
  repeat match goal with
  | [ H : _ < _ |- _ ] => apply lt_ovf in H; destruct H
  end;
  nat_subst;
  goodsizes.

Ltac word2nat_solve := unfold goodSize in *; subst;
  (omega ||
   congruence ||
   (apply f_equal; word2nat_solve) ||
   ((apply div_le; [| word2nat_auto] ||
     apply zero_lt_pow2 ||
     apply wordToNat_bound || apply wordToNat_good ||
     apply Nat.mod_upper_bound ||
     idtac
    ); solve [auto]
   ) ||
   (apply Nat.div_lt_upper_bound; solve [word2nat_auto]) ||
   (eapply le_lt_trans; [(apply div_le || apply Nat.mod_le) |]; solve [word2nat_auto])
  )

(* XXX does this actually rewrite from the inside out? *)
with word2nat_rewrites :=
  repeat ((match goal with
  | H : context[wordToNat (natToWord ?sz ?n)] |- _ =>
    rewrite (@wordToNat_natToWord_idempotent' sz n) in H; [|clear H]
  | H : context[wordToNat (NToWord ?sz ?n)] |- _ =>
    rewrite (@N2Nat_word' sz n) in H; [|clear H]
  | H : context[wordToNat (NToWord ?sz (wordToN ?a / wordToN ?b))] |- _ =>
    rewrite (@wordToNat_div sz a b); [|clear H]
  | H : context[N.to_nat (?a mod ?b)] |- _ =>
    rewrite (Ninj_mod a b); [|clear H]
  end
  || rewrite wordToNat_natToWord_idempotent'
  || rewrite N2Nat_word'
  || rewrite wordToNat_div
  || rewrite Ninj_mod); word2nat_simpl)

with word2nat_auto :=
  intros; word2nat_simpl; word2nat_rewrites; try word2nat_solve;
  repeat match goal with
  | [ H : _ |- _ ] => apply wordToNat_inj in H
  end.

Lemma wdiv_lt_upper_bound :
  forall sz (a b c:word sz), b <> $0 -> (a < b ^* c)%word -> (a ^/ b < c)%word.
Proof.
  word2nat_auto.
Qed.

Lemma wmod_upper_bound :
  forall sz (a b:word sz), b <> $0 -> (a ^% b < b)%word.
Proof.
  word2nat_auto.
Qed.

Lemma wlt_mult_inj : forall sz (a b c:word sz),
  (a < b ^* c)%word -> wordToNat a < wordToNat b * wordToNat c.
Proof.
  word2nat_auto.
Qed.

Lemma test_1: forall sz (a: word sz), a = a ^+ $ 0.
Proof.
  word2nat_auto.
Qed.


(** * Syntax of First Order Linear Logic (LL)
This file defines the syntax of formulas in first-order linear logic
(type [oo]). Predicate [isFormula] determines when a term is a valid
LL formula (ruling out exotic terms). Proofs usually proceed by
induction on the fact that a term satisfies this property.
 *)

Require Export FLL.Misc.Utils.
Require Export FLL.Misc.Hybrid.
Require Export Lia.
Require Import Coq.Logic.FunctionalExtensionality.

Export ListNotations.
Set Implicit Arguments.

(** ** External definitions for the Object Logic (OL)
The class [OLSig] specifies the external definitions for terms and
atomic propositions of the object logic. The syntax is parametric on:

 - [atm] : type for atomic propositions (judgments at the Object Logic level)
 - [con] : type for syntactic constructors at the OL level
 - [uniform_atm] : predicate ruling out exotic terms at the OL level
 *)

Class OLSig :=
  {
    (* Signature for atoms (judgments at the OL level) *)
    atm:Set;
    (* Type for constants (constructors for OL syntax) *)
    con:Set;
    (* predicate ruling out exotic terms for atoms *)
    uniform_atm : (expr con -> atm) -> Prop
  }.

Section LLSyntax.
  Context `{OLS: OLSig}.

  (** Connectives of the logic *)
  Inductive oo : Set :=
  | atom : atm -> oo
  | perp : atm -> oo
  | Top : oo
  | One : oo
  | Zero : oo
  | Bot : oo
  | AAnd : oo -> oo -> oo
  | MAnd : oo -> oo -> oo
  | AOr : oo -> oo -> oo
  | MOr : oo -> oo -> oo
  | Bang : oo -> oo
  | Quest : oo -> oo
  | All : (expr con -> oo) -> oo
  | Some : (expr con -> oo) -> oo.

  (** Complexity of formulas *)
  Fixpoint complexity (X:oo) :=
    match X with
    | atom A   => 1
    | perp A   => 1
    | One => 1
    | Bot => 1
    | Zero => 1
    | Top => 1
    | MAnd F G => 1+ complexity F + complexity G
    | AAnd F G => 1+ complexity F + complexity G
    | MOr F G => 1+ complexity F + complexity G
    | AOr F G => 1+ complexity F + complexity G
    | Bang F   => 1+ complexity F
    | Quest F  => 1+ complexity F
    | Some FX => 1+ complexity (FX (VAR con 0))
    | All FX => 1+ complexity (FX (VAR con 0))
    end.

  (** Complexity on list of formulas *)
  Fixpoint complexityL (L: list oo) :=
    match L with
    | nil => 0
    | a :: L' => complexity a + complexityL L'
    end.

  Lemma Complexity0 : forall F, complexity F > 0.
    induction F;simpl;lia.
  Qed.

  Lemma ComplexityL0 : forall L, complexityL L =0 -> L = [].
    intros;destruct L;simpl;auto.
    simpl in H.
    generalize (Complexity0 o);intros.
    lia.
  Qed.

  (** Classical linear logic dualities *)
  Fixpoint dual (X: oo) :=
    match X with
    | atom A   => perp A
    | perp A   => atom A
    | One => Bot
    | Bot => One
    | Zero => Top
    | Top => Zero
    | MAnd F G => MOr (dual  F) (dual G)
    | AAnd F G => AOr (dual  F) (dual G)
    | MOr F G => MAnd (dual  F) (dual G)
    | AOr F G => AAnd (dual  F) (dual G)
    | Bang F   => Quest (dual F)
    | Quest F  => Bang (dual   F)
    | Some X => All (fun x => dual  (X x))
    | All X => Some (fun x => dual (X x))
    end.

  (** Negation is involutive *)
  Theorem ng_involutive: forall F: oo, F = dual (dual F).
  Proof.
    intro.
    induction F; simpl; auto;
      try( try(rewrite <- IHF1); try(rewrite <- IHF2); try(rewrite <- IHF);auto);
      try(assert (o = fun x =>  dual (dual (o x))) by
             (extensionality e; apply H); rewrite <- H0; auto).
  Qed.

  Lemma DualComplexity : forall F, complexity F = complexity (dual F) .
    intros.
    induction F;intros;auto;
      try solve
          [simpl; try rewrite IHF; try rewrite IHF1; try rewrite IHF2;auto].
  Qed.

  (**  Linear Implication *)
  Definition Limp (F G : oo) : oo := MOr (dual F) G .

  (** Uniform Predicate (ruling out exotic terms) *)
  Inductive uniform_oo: (expr con -> oo) -> Prop :=
  | uniform_atom: forall (a: expr con -> atm),
      uniform_atm a -> uniform_oo (fun x => (atom (a x)))
  | uniform_perp: forall (a: expr con -> atm),
      uniform_atm a -> uniform_oo (fun x => (perp (a x)))
  | uniform_Top: uniform_oo (fun x => Top)
  | uniform_One: uniform_oo (fun x => One)
  | uniform_Bot: uniform_oo (fun x => Bot)
  | uniform_Zero: uniform_oo (fun x => Zero)
  | uniform_AAnd: forall (A B: expr con -> oo),
      uniform_oo A -> uniform_oo B -> uniform_oo (fun x => (AAnd (A x) (B x)))
  | uniform_MAnd: forall (A B: expr con -> oo),
      uniform_oo A -> uniform_oo B -> uniform_oo (fun x => (MAnd (A x) (B x)))
  | uniform_AOr: forall (A B: expr con -> oo),
      uniform_oo A -> uniform_oo B -> uniform_oo (fun x => (AOr (A x) (B x)))
  | uniform_MOr: forall (A B: expr con -> oo),
      uniform_oo A -> uniform_oo B -> uniform_oo (fun x => (MOr (A x) (B x)))
  | uniform_Bang: forall (A: expr con -> oo),
      uniform_oo A -> uniform_oo (fun x => (Bang (A x)))
  | uniform_Quest: forall (A: expr con -> oo),
      uniform_oo A -> uniform_oo (fun x => (Quest (A x)))
  | uniform_All: forall (A: expr con -> expr con -> oo),
      (forall y:expr con, uniform_oo (fun x => (A y x))) ->
      uniform_oo (fun x => (All (fun y => (A y x))))
  | uniform_Some: forall (A: expr con -> expr con -> oo),
      (forall y:expr con, uniform_oo (fun x => (A y x))) ->
      uniform_oo (fun x => (Some (fun y => (A y x)))).

  (** Well formedness condition  *)
  Inductive isFormula: oo -> Prop  :=
  | wf_atm : forall (P1:atm), isFormula (atom P1)
  | wf_perp : forall (P1:atm), isFormula (perp P1)
  | wf_Top : isFormula Top
  | wf_One : isFormula One
  | wf_Zero : isFormula Zero
  | wf_Bot : isFormula Bot
  | wf_AAnd : forall (A1 A2 :oo), isFormula A1  -> isFormula A2  -> isFormula (AAnd A1 A2)
  | wf_MAnd : forall (A1 A2 :oo), isFormula A1  -> isFormula A2  -> isFormula (MAnd A1 A2)
  | wf_AOr : forall (A1 A2 :oo), isFormula A1  -> isFormula A2  -> isFormula (AOr A1 A2)
  | wf_MOr : forall (A1 A2 :oo), isFormula A1  -> isFormula A2  -> isFormula (MOr A1 A2)
  | wf_Bang : forall (A1 :oo), isFormula A1 -> isFormula (Bang A1)
  | wf_Quest : forall (A1 :oo), isFormula A1 -> isFormula (Quest A1)
  | wf_All : forall (A : expr con -> oo), uniform_oo A -> (forall t: expr con, isFormula (A t)) -> isFormula (All A)
  | wf_Some : forall (A : expr con -> oo), uniform_oo A -> (forall t: expr con, isFormula (A t)) -> isFormula (Some A).

  Hint Constructors isFormula : core.

  Lemma ComplexityUniformEq : forall FX x y , uniform_oo FX ->
                                            proper x -> proper y ->
                                            complexity (FX x) =  complexity (FX y).
    intros.
    induction H;subst;simpl;firstorder.
  Qed.

  (** Well formendness conditions for lists and arrows *)
  Definition isFormulaL  (L:list oo)  := Forall isFormula L.
  Definition multiset := list.
  Hint Constructors Remove : core.

  Lemma isFormulaIn : forall F L,
      isFormulaL L -> In F L -> isFormula F.
  Proof.
    intros.
    unfold isFormulaL in H.
    generalize (Forall_forall isFormula L );intro.
    destruct H1.
    apply H1 with (x:= F) in H ;auto.
  Qed.

  Generalizable All Variables.
  Global Instance isFormulaL_morph :
    Proper ((@Permutation oo) ==> Basics.impl) (Forall isFormula).
  Proof.
    unfold Proper; unfold respectful; unfold Basics.impl.
    intros.
    eapply Forall_Permute;eauto.
  Qed.

  (** Arrows for the focused system
      - [UP] : negative phase
      - [DW] : positive phase
   *)
  Inductive Arrow  :=
  | UP (l : list oo) (* negative phase *)
  | DW (F : oo). (* positive phase *)

  (** Transforming arrows into lists of formulas *)
  Definition Arrow2LL (A: Arrow) : list oo :=
    match A  with
    | UP l => l
    | DW F => [F]
    end.

  (** Checking when a formulas has to lose focusing *)
  Inductive release : oo -> Prop :=
  | RelNA1 : forall A,  release (atom A)
  | RelTop : release Top
  | RelBot : release Bot
  | RelPar : forall F G, release (MOr F G)
  | RelWith : forall F G, release (AAnd F G)
  | RelQuest : forall F, release (Quest F)
  | RelForall : forall FX, release (All FX).

  (** Positive formulas (focusing persists *)
  Inductive positiveFormula : oo -> Prop :=
  | PosAt : forall A,  positiveFormula (perp A)
  | PosOne : positiveFormula One
  | PosZero : positiveFormula Zero
  | PosTensor : forall F G, positiveFormula (MAnd F G)
  | PosPlus : forall F G, positiveFormula (AOr F G)
  | PosBang : forall F, positiveFormula (Bang F)
  | PosEx : forall FX, positiveFormula (Some FX).

  (** Every formula is either  a positive formula, or it must be released *)
  Theorem PositiveOrRelease : forall F,
      positiveFormula F \/ release F.
    intros.
    destruct F;try (left;constructor);try(right;constructor).
  Qed.

  (** Positive formulas cannot be released *)
  Theorem PositiveNotRelease: forall F,
      positiveFormula F -> ~ release F.
    intros F H Hneg.
    inversion H;subst;inversion Hneg.
  Qed.

  Theorem ReleaseNotPositive : forall F,
      release F -> ~ positiveFormula F.
    intros F H Hneg.
    inversion H;subst;inversion Hneg.
  Qed.

  (** The dual of a positive formula is a release formula *)
  Theorem PositiveDualRelease : forall F,
      positiveFormula F -> release (dual F).
    intros F Hpos.
    inversion Hpos;subst;constructor.
  Qed.

  Theorem ReleaseDualPositive : forall F, release F -> positiveFormula (dual F).
    intros F Hrel.
    inversion Hrel;subst;constructor.
  Qed.

  (** Assynchronous connectives *)
  Inductive asynchronous : oo -> Prop :=
  | aTop :   asynchronous Top
  | aBot :   asynchronous Bot
  | aPar :   forall F G, asynchronous (MOr F G)
  | aWith :  forall F G, asynchronous (AAnd F G)
  | aQuest : forall F  , asynchronous (Quest F)
  | aForall : forall FX  , asynchronous (All FX).

  Definition Notasynchronous F := ~ (asynchronous F).
  Definition isNotAsyncL (L : list oo) := Forall Notasynchronous L.

  (** Postive atoms *)
  Inductive IsPositiveAtom : oo -> Prop :=
  | IsPAP : forall A, IsPositiveAtom (atom A).

  (** Negative atoms *)
  Inductive IsNegativeAtom : oo -> Prop :=
  | IsNAP : forall A, IsNegativeAtom (perp A).

  Theorem NegativeAtomDec : forall F,
      IsNegativeAtom F \/ ~ IsNegativeAtom F.
    induction F;auto; try solve[right;intro H'; inversion H'].
    left;constructor.
  Qed.

  Hint Constructors IsPositiveAtom : core.
  Theorem PositiveAtomDec : forall F,
      IsPositiveAtom F \/ ~ IsPositiveAtom F.
    destruct F;auto;right;intro H';inversion H'.
  Qed.

  (** List of positive atoms *)
  Definition IsPositiveAtomL  L : Prop := Forall IsPositiveAtom L.

  Lemma NotAsynchronousPosAtoms :
    forall F, ~ asynchronous  F -> positiveFormula F \/ IsPositiveAtom F.
    intros.
    destruct F;intuition;  first
                             [left;constructor
                             | match goal with [_:  asynchronous ?F -> False |- _] =>
                                               assert(asynchronous F) by constructor;contradiction end
                             ].
  Qed.

  Lemma AsyncRelease: forall F, asynchronous F -> release F.
  Proof.
    intros.
    inversion H; constructor.
  Qed.

  Lemma AsIsPosRelease: forall F,
      (asynchronous F \/ IsPositiveAtom F ) -> release F.
  Proof.
    intros.
    destruct H;auto using AsyncRelease.
    inversion H;constructor;auto.
  Qed.

  Lemma NotAsynchronousPosAtoms' :
    forall G, ~ asynchronous G ->
              IsPositiveAtom G \/ (positiveFormula G).
    intros G HG.
    apply NotAsynchronousPosAtoms in HG;tauto.
  Qed.

  Lemma  IsPositiveAtomNotAssync :
    forall F,  IsPositiveAtom F -> ~ asynchronous F.
  Proof.
    intros.
    inversion H;auto.
    intro.
    inversion H1.
  Qed.

  Lemma LexpPosConc : forall M F, isNotAsyncL M ->
                                  ~ asynchronous F ->
                                  isNotAsyncL (M ++ [F]).
    intros.
    apply ForallAppComm.
    apply ForallApp;auto.
  Qed.

  Lemma PosAtomConc : forall M F,  isNotAsyncL M ->
                                   IsPositiveAtom F ->
                                   isNotAsyncL (M ++ [F]).
    intros.
    apply ForallAppComm.
    apply ForallApp;auto.
    inversion H0;subst;auto.
    constructor;auto.
    intro Hn;inversion Hn.
  Qed.

  Lemma NegAtomConc : forall M F,  isNotAsyncL M ->
                                   IsNegativeAtom F ->
                                   isNotAsyncL (M ++ [F]).
    intros.
    apply ForallAppComm.
    apply ForallApp;auto.
    inversion H0;subst;auto.
    constructor;auto.
    intro Hn;inversion Hn.
  Qed.

  Lemma PosConc : forall M F,  isNotAsyncL M ->
                               positiveFormula F ->
                               isNotAsyncL (M ++ [F]).
    intros.
    apply ForallAppComm.
    apply ForallApp;auto.
    constructor;auto.
    intro Hn;inversion Hn;subst;inversion H0.
  Qed.
End LLSyntax.


(* -*- coding: utf-8 -*- *)
(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \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)         *)
(************************************************************************)

(** Binary Integers (Pierre Crégut, CNET, Lannion, France) *)

Require Export Arith_base.
Require Import BinInt.
Require Import Zorder.
Require Import Decidable.
Require Import Peano_dec.
Require Export Compare_dec.

Local Open Scope Z_scope.

(***************************************************************)
(** * Moving terms from one side to the other of an inequality *)

Theorem Zne_left n m : Zne n m -> Zne (n + - m) 0.
Proof.
 unfold Zne. now rewrite <- Z.sub_move_0_r.
Qed.

Theorem Zegal_left n m : n = m -> n + - m = 0.
Proof.
 apply Z.sub_move_0_r.
Qed.

Theorem Zle_left n m : n <= m -> 0 <= m + - n.
Proof.
 apply Z.le_0_sub.
Qed.

Theorem Zle_left_rev n m : 0 <= m + - n -> n <= m.
Proof.
 apply Z.le_0_sub.
Qed.

Theorem Zlt_left_rev n m : 0 < m + - n -> n < m.
Proof.
 apply Z.lt_0_sub.
Qed.

Theorem Zlt_left_lt n m : n < m -> 0 < m + - n.
Proof.
 apply Z.lt_0_sub.
Qed.

Theorem Zlt_left n m : n < m -> 0 <= m + -1 + - n.
Proof.
 intros. rewrite Z.add_shuffle0. change (-1) with (- Z.succ 0).
 now apply Z.le_0_sub, Z.le_succ_l, Z.lt_0_sub.
Qed.

Theorem Zge_left n m : n >= m -> 0 <= n + - m.
Proof.
 Z.swap_greater. apply Z.le_0_sub.
Qed.

Theorem Zgt_left n m : n > m -> 0 <= n + -1 + - m.
Proof.
 Z.swap_greater. apply Zlt_left.
Qed.

Theorem Zgt_left_gt n m : n > m -> n + - m > 0.
Proof.
 Z.swap_greater. apply Z.lt_0_sub.
Qed.

Theorem Zgt_left_rev n m : n + - m > 0 -> n > m.
Proof.
 Z.swap_greater. apply Z.lt_0_sub.
Qed.

Theorem Zle_mult_approx n m p :
  n > 0 -> p > 0 -> 0 <= m -> 0 <= m * n + p.
Proof.
 Z.swap_greater. intros. Z.order_pos.
Qed.

Theorem Zmult_le_approx n m p :
  n > 0 -> n > p -> 0 <= m * n + p -> 0 <= m.
Proof.
 Z.swap_greater. intros. apply Z.lt_succ_r.
 apply Z.mul_pos_cancel_r with n; trivial. Z.nzsimpl.
 apply Z.le_lt_trans with (m*n+p); trivial.
 now apply Z.add_lt_mono_l.
Qed.


From Undecidability Require Import TM.Util.Prelim.
Require Import Coq.Lists.List.

Set Default Goal Selector "!".

Ltac build_eq_dec :=
  let x := fresh "x" in
  let y := fresh "y" in
  intros x y; hnf; decide equality;
  apply Dec; auto.

Lemma countMap_injective (X Y : eqType) (x : X) (A : list X) (f : X -> Y) :
  (forall x y, f x = f y -> x = y) ->
  FinTypesDef.count (map f A) (f x) = FinTypesDef.count A x.
Proof.
  intros HInj. revert x. induction A as [ | a A IH]; intros; cbn in *; auto.
  decide (f x = f a) as [ -> % HInj | He].
  - decide (a = a) as [_ | Ha]; auto. congruence.
  - decide (x = a) as [-> | Hx]; auto. congruence.
Qed.

Lemma countMap_zero (X Y : eqType) (A : list X) (y : Y) (f : X -> Y) :
  (forall x, f x <> y) ->
  FinTypesDef.count (map f A) y = 0.
Proof.
  revert y. induction A as [ | a A IH]; intros; cbn in *; auto.
  decide (y = f a) as [-> | ?]; auto. now contradiction (H a).
Qed.

Section Encode_list.

  Inductive sigList (sigX : Type) : Type :=
  | sigList_X (s : sigX)
  | sigList_nil
  | sigList_cons
  .

  Arguments sigList_nil {sigX}. Arguments sigList_cons {sigX}. Arguments sigList_X {sigX}.

  #[export] Instance sigList_dec sigX (decX : eq_dec sigX) :
    eq_dec (sigList sigX) := ltac:(build_eq_dec).

  #[export] Instance sigList_fin (sigX : finType) : finTypeC (EqType (sigList sigX)).
  Proof.
    split with (enum := sigList_nil :: sigList_cons :: map sigList_X enum).
    intros [x| | ]; cbn; f_equal.
    - rewrite countMap_injective. { apply enum_ok. }
      now intros ?? [= ?].
    - now apply countMap_zero.
    - now apply countMap_zero.
  Qed.

  Variable sigX: Type.
  Variable (X : Type) (encode : X -> list sigX).

  Fixpoint encode_list (xs : list X) : list (sigList sigX) :=
    match xs with
    | nil => [sigList_nil]
    | x :: xs' => sigList_cons :: (map sigList_X (encode x)) ++ encode_list xs'
    end.

  Lemma encode_list_app (xs ys : list X) :
    encode_list (xs ++ ys) = removelast (encode_list xs) ++ encode_list ys.
  Proof.
    revert ys. induction xs; intros; cbn in *; f_equal.
    rewrite IHxs. rewrite app_assoc, app_comm_cons; f_equal.
    destruct (map (fun x : sigX => sigList_X x) (encode a)) eqn:E; cbn.
    - destruct xs; cbn; auto.
    - f_equal. destruct (encode a) eqn:E2; cbn in E. { congruence. }
      rewrite removelast_app.
      + destruct (l ++ encode_list xs) eqn:E3; cbn; auto.
        apply app_eq_nil in E3 as (E3&E3'). destruct xs; inv E3'.
      + destruct xs; cbn; congruence.
  Qed.

  Lemma encode_list_neq_nil (xs : list X) :
    encode_list xs <> nil.
  Proof. destruct xs; cbn; congruence. Qed.

  Lemma encode_list_remove (xs : list X) :
    removelast (encode_list xs) ++ [sigList_nil] = encode_list xs.
  Proof.
    induction xs.
    - reflexivity.
    - cbn [encode_list].
      change (sigList_cons :: map sigList_X (encode a) ++ encode_list xs) with
        ((sigList_cons :: map sigList_X (encode a)) ++ encode_list xs).
      rewrite removelast_app by apply encode_list_neq_nil.
      rewrite <- app_assoc. f_equal. auto.
  Qed.

End Encode_list.

Arguments sigList_nil {sigX}. Arguments sigList_cons {sigX}. Arguments sigList_X {sigX}.

#[export] Hint Extern 4 (finTypeC (EqType (sigList _))) => eapply sigList_fin : typeclass_instances.


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

Require Export CoRN.algebra.CSetoidInc.
Require Export CoRN.reals.RealLists.
Set Automatic Introduction.

Section Intervals.

(**
* Intervals
In this section we define (compact) intervals of the real line and
some useful functions to work with them.

** Definitions

We start by defining the compact interval [[a,b]] as being the set of
points less or equal than [b] and greater or equal than [a].  We
require [a [<=] b], as we want to work only in nonempty intervals.
*)

Definition compact (a b : IR) (Hab : a [<=] b) (x : IR) := a [<=] x and x [<=] b.

(**
%\begin{convention}% Let [a,b : IR] and [Hab : a [<=] b].
%\end{convention}%

As expected, both [a] and [b] are members of [[a,b]].  Also they are
members of the interval [[Min(a,b),Max(a,b)]].
*)

Variables a b : IR.
Hypothesis Hab : a [<=] b.

Lemma compact_inc_lft : compact a b Hab a.
Proof.
 intros; split; [ apply leEq_reflexive | auto ].
Qed.

Lemma compact_inc_rht : compact a b Hab b.
Proof.
 intros; split; [ auto | apply leEq_reflexive ].
Qed.

Lemma compact_Min_lft : forall Hab', compact (Min a b) (Max a b) Hab' a.
Proof.
 split; [ apply Min_leEq_lft | apply lft_leEq_Max ].
Qed.

Lemma compact_Min_rht : forall Hab', compact (Min a b) (Max a b) Hab' b.
Proof.
 split; [ apply Min_leEq_rht | apply rht_leEq_Max ].
Qed.

(**
As we will be interested in taking functions with domain in a compact
interval, we want this predicate to be well defined.
*)

Lemma compact_wd : pred_wd IR (compact a b Hab).
Proof.
 intros; red in |- *; intros x y H H0.
 inversion_clear H; split.
  apply leEq_wdr with x; assumption.
 apply leEq_wdl with x; assumption.
Qed.

(**
Also, it will sometimes be necessary to rewrite the endpoints of an interval.
*)

Lemma compact_wd' : forall (a' b' : IR) Hab' (x : IR),
 a [=] a' -> b [=] b' -> compact a b Hab x -> compact a' b' Hab' x.
Proof.
 intros a' b' Hab' x H H0 H1.
 inversion_clear H1; split.
  apply leEq_wdl with a; auto.
 apply leEq_wdr with b; auto.
Qed.

(**
As we identify subsets with predicates, inclusion is simply implication.
*)

(**
Finally, we define a restriction operator that takes a function [F]
and a well defined predicate [P] included in the domain of [F] and
returns the restriction $F|_P$# of F to P#.
*)

Definition Frestr F P (HP : pred_wd IR P) (H : included P (Dom F)) : PartIR.
Proof.
 intros.
 apply Build_PartFunct with P (fun (x : IR) (Hx : P x) => Part F x (H x Hx)).
  assumption.
 intros. exact (pfstrx _ _ _ _ _ _ X).
Defined.

End Intervals.

Notation Compact := (compact _ _).
Arguments Frestr [F P].
Notation FRestr := (Frestr (compact_wd _ _ _)).

Section More_Intervals.

Lemma included_refl' : forall a b Hab Hab', included (compact a b Hab) (compact a b Hab').
Proof.
 intros.
 red in |- *; intros x H.
 inversion_clear H; split; auto.
Qed.

(** We prove some inclusions of compact intervals.  *)

Definition compact_map1 : forall a b Hab Hab',
 included (compact (Min a b) (Max a b) Hab') (compact a b Hab).
Proof.
 intros.
 red in |- *; intros x H.
 red in |- *; red in H.
 inversion_clear H.
 split.
  eapply leEq_wdl; [ apply H0 | apply leEq_imp_Min_is_lft; auto ].
 eapply leEq_wdr; [ apply H1 | apply leEq_imp_Max_is_rht; auto ].
Defined.

Definition compact_map2 : forall a b Hab Hab',
 included (compact a b Hab) (compact (Min a b) (Max a b) Hab').
Proof.
 intros.
 red in |- *; intros x H.
 red in |- *; red in H.
 inversion_clear H.
 split.
  eapply leEq_transitive; [ apply Min_leEq_lft | apply H0 ].
 eapply leEq_transitive; [ apply H1 | apply rht_leEq_Max ].
Defined.

Definition compact_map3 : forall a b e Hab Hab', [0] [<] e ->
 included (compact a (b[-]e) Hab') (compact a b Hab).
Proof.
 intros; red in |- *. try rename X into H.
 intros x H0. inversion_clear H0; split.
 auto.
 eapply leEq_transitive.
  apply H2.
 apply shift_minus_leEq.
 apply shift_leEq_plus'.
 astepl ZeroR; apply less_leEq; assumption.
Qed.

End More_Intervals.

#[global]
Hint Resolve included_refl' compact_map1 compact_map2 compact_map3 : included.

Section Totally_Bounded.

(**
** Totally Bounded

Totally bounded sets will play an important role in what is
to come.  The definition (equivalent to the classical one) states that
[P] is totally bounded iff
%\[\forall_{\varepsilon>0}\exists_{x_1,\ldots,x_n}\forall_{y\in P}
\exists_{1\leq i\leq n}|y-x_i|<\varepsilon\]%#∀e>0
∃x1,...,xn∀y∈P∃
1≤i≤n.|y-xi|<e#.

Notice the use of lists for quantification.
*)

Definition totally_bounded (P : IR -> CProp) : CProp := {x : IR | P x} and (forall e,
 [0] [<] e -> {l : list IR | forall x, member x l -> P x |
 forall x, P x -> {y : IR | member y l | AbsSmall e (x[-]y)}}).

(**
This definition is classically, but not constructively, equivalent to
the definition of compact (if completeness is assumed); the next
result, classically equivalent to the Heine-Borel theorem, justifies
that we take the definition of totally bounded to be the relevant one
and that we defined compacts as we did.
*)

Lemma compact_is_totally_bounded : forall a b Hab, totally_bounded (compact a b Hab).
Proof.
 intros; split.
  exists a.
  apply compact_inc_lft.
 cut (forall (n : nat) (a b e : IR) (Hab : a [<=] b) (He : [0] [<] e),
   (b[-]a[/] e[//]pos_ap_zero _ _ He) [<=] nring n ->
     (2 <= n -> nring n[-]Two [<=] (b[-]a[/] e[//]pos_ap_zero _ _ He)) ->
       {l : list IR | forall x : IR, member x l -> compact a b Hab x | forall x : IR,
         compact a b Hab x -> {y : IR | member y l | AbsIR (x[-]y) [<=] e}}).
  intros H e He.
  elim (str_Archimedes (b[-]a[/] _[//]pos_ap_zero _ _ (pos_div_two _ _ He))).
   intros n Hn.
   inversion_clear Hn.
   elim (H n a b _ Hab (pos_div_two _ _ He)).
     intros l Hl' Hl.
     2: assumption.
    2: assumption.
   exists l.
    assumption.
   intros x Hx; elim (Hl x Hx).
   intros y Hy Hy'.
   exists y.
    assumption.
   apply AbsIR_imp_AbsSmall.
   apply leEq_transitive with (e [/]TwoNZ).
    assumption.
   apply less_leEq; apply pos_div_two'; assumption.
  apply shift_leEq_div; [ apply pos_div_two; assumption | apply shift_leEq_minus ].
  rstepl a; assumption.
 clear Hab a b; intro n; induction  n as [| n Hrecn].
  intros.
  exists (a::nil).
   intros x H1.
   inversion H1 as [H2 | H2]. elim H2.
   apply compact_wd with a; algebra.
   apply compact_inc_lft.
  intros.
  exists a.
   right; algebra.
  apply leEq_wdl with ZeroR.
   apply less_leEq; auto.
  astepl (AbsIR [0]).
  apply AbsIR_wd.
  apply leEq_imp_eq. try rename X into H1.
   apply shift_leEq_minus; astepl a; elim H1; auto.
  apply shift_minus_leEq.
  apply leEq_transitive with b. try rename X into H1.
   elim H1; auto.
  apply shift_leEq_plus.
  apply mult_cancel_leEq with ([1][/] _[//]pos_ap_zero _ _ He).
   apply recip_resp_pos; auto.
  astepr ZeroR.
  rstepl (b[-]a[/] _[//]pos_ap_zero _ _ He); auto.
 clear Hrecn; induction  n as [| n Hrecn].
  intros.
  exists (a::nil).
   intros x H1.
   inversion_clear H1 as [H2|].
    elim H2.
   apply compact_wd with a; [ apply compact_inc_lft | algebra ].
  intros x Hx; inversion_clear Hx.
  exists a.
   simpl in |- *; right; algebra.
  eapply leEq_wdl.
   2: apply eq_symmetric_unfolded; apply AbsIR_eq_x.
   apply leEq_transitive with (b[-]a).
    apply minus_resp_leEq; assumption.
   rstepr (e[*]nring 1); eapply shift_leEq_mult'; [ assumption | apply H ].
  apply shift_leEq_minus; astepl a.
  assumption.
 clear Hrecn; induction  n as [| n Hrecn].
  intros.
  set (enz := pos_ap_zero _ _ He) in *.
  exists (cons ((a[+]b) [/]TwoNZ) (@nil IR)).
   intros x H1.
   inversion_clear H1 as [H2|].
    inversion_clear H2.
   apply compact_wd with ((a[+]b) [/]TwoNZ); [ split | algebra ].
    astepl (a[+][0]); apply shift_plus_leEq'.
    apply mult_cancel_leEq with (Two:IR).
     apply pos_two.
    astepl ZeroR.
    rstepr (b[-]a).
    apply shift_leEq_minus; astepl a; auto.
   astepr (b[+][0]); apply shift_leEq_plus'.
   apply mult_cancel_leEq with (Two:IR).
    apply pos_two.
   astepr ZeroR.
   rstepl (a[-]b).
   apply shift_minus_leEq; astepr b; auto.
  intros.
  exists ((a[+]b) [/]TwoNZ).
   right; algebra.
  eapply leEq_wdl.
   2: apply eq_symmetric_unfolded; apply Abs_Max.
  apply shift_minus_leEq; apply Max_leEq; apply shift_leEq_plus'; apply leEq_Min.
     apply shift_minus_leEq; apply shift_leEq_plus'.
     astepl ZeroR; apply less_leEq; auto.
    apply shift_minus_leEq.
    apply leEq_transitive with b. try rename X into H1.
     elim H1; auto.
    apply shift_leEq_plus'.
    apply mult_cancel_leEq with (Two:IR).
     apply pos_two.
    apply shift_leEq_mult' with enz.
     auto.
    rstepl (b[-]a[/] e[//]enz); auto.
   apply leEq_transitive with a.
    2: try rename X into H1; elim H1; auto.
   apply shift_minus_leEq; apply shift_leEq_plus'.
   apply mult_cancel_leEq with (Two:IR).
    apply pos_two.
   apply shift_leEq_mult' with enz.
    auto.
   rstepl (b[-]a[/] e[//]enz); auto.
  apply shift_minus_leEq; apply shift_leEq_plus'.
  astepl ZeroR; apply less_leEq; auto.
 intros.
 set (b' := b[-]e) in *.
 cut (a [<=] b'); intros.
  elim (Hrecn a b' e H1 He).
    intros l Hl' Hl.
    exists (cons b' l).
     intros.
     unfold b' in H1; apply compact_map3 with (e := e) (Hab' := H1) (b := b).
      assumption. try rename X into H2.
     simpl in H2; inversion_clear H2.
      apply Hl'; assumption.
     apply compact_wd with b'; [ apply compact_inc_rht | algebra ].
    intros.
    cut (x [<] b' or b'[-]e [<] x). intros H3.
     inversion_clear H3.
      cut (compact a b' H1 x). intros H3.
       elim (Hl x H3).
       intros y Hy Hy'.
       exists y.
        left; assumption.
       auto. try rename X into H2.
      inversion_clear H2; split.
       assumption.
      apply less_leEq; auto.
     exists b'.
      right; algebra.
     simpl in |- *; unfold ABSIR in |- *.
     apply Max_leEq.
      apply shift_minus_leEq; unfold b' in |- *.
      rstepr b. try rename X into H2.
      elim H2; auto.
     rstepl (b'[-]x); apply shift_minus_leEq; apply shift_leEq_plus'; apply less_leEq; assumption.
    cut (b'[-]e [<] x or x [<] b'); [ tauto | apply less_cotransitive_unfolded ].
    apply shift_minus_less; apply shift_less_plus'; astepl ZeroR; assumption.
   unfold b' in |- *.
   rstepl ((b[-]a[/] e[//]pos_ap_zero _ _ He) [-][1]).
   apply shift_minus_leEq.
   astepr (nring (R:=IR) (S (S (S n)))); auto.
  intro.
  unfold b' in |- *.
  rstepr ((b[-]a[/] e[//]pos_ap_zero _ _ He) [-][1]).
  apply shift_leEq_minus.
  rstepl (nring (R:=IR) (S (S n)) [+][1][-]Two).
  auto with arith.
 unfold b' in |- *.
 apply shift_leEq_minus; apply shift_plus_leEq'.
 astepl ([1][*]e); apply shift_mult_leEq with (pos_ap_zero _ _ He).
  auto.
 apply leEq_transitive with (nring (R:=IR) (S (S (S n))) [-]Two).
  apply shift_leEq_minus; rstepl (Three:IR); apply nring_leEq; auto with arith.
 auto with arith.
Qed.

(**
Suprema and infima will be needed throughout; we define them here both
for arbitrary subsets of [IR] and for images of functions.
*)

Definition set_glb_IR (P : IR -> CProp) a : CProp := (forall x, P x -> a [<=] x) and
 (forall e, [0] [<] e -> {x : IR | P x | x[-]a [<] e}).

Definition set_lub_IR (P : IR -> CProp) a : CProp := (forall x, P x -> x [<=] a) and
 (forall e, [0] [<] e -> {x : IR | P x | a[-]x [<] e}).

Definition fun_image F (P : IR -> CProp) x : CProp := {y : IR |
 P y and Dom F y and (forall Hy, F y Hy [=] x)}.

Definition fun_glb_IR F (P : IR -> CProp) a : CProp :=
 set_glb_IR (fun_image F P) a.

Definition fun_lub_IR F (P : IR -> CProp) a : CProp :=
 set_lub_IR (fun_image F P) a.

(* begin hide *)
Let aux_seq_lub (P : IR -> CProp) (H : totally_bounded P) :
  forall k : nat,
  Build_SubCSetoid IR
    (fun x : IR =>
     P x and (forall y : IR, P y -> y[-]x [<=] Two[*]one_div_succ k)).
Proof.
 elim H; clear H; intros non_empty H k.
 elim (H (one_div_succ k) (one_div_succ_pos IR k)).
 intros l Hl' Hl; clear H.
 cut {y : IR | member y l | maxlist l[-]one_div_succ k [<=] y}.
  intro H; inversion_clear H.
  2: apply maxlist_leEq_eps.
   2: inversion_clear non_empty.
   2: elim (Hl x).
    2: intros.
    2: exists x0.
    2: tauto.
   2: assumption.
  2: apply one_div_succ_pos.
 exists x; split.
  apply Hl'; assumption.
 intros y Hy.
 elim (Hl y Hy).
 intros z Hz Hz'.
 rstepl (y[-]z[+] (z[-]x)).
 rstepr (one_div_succ (R:=IR) k[+]one_div_succ k).
 apply plus_resp_leEq_both.
  apply leEq_transitive with (AbsIR (y[-]z)).
   apply leEq_AbsIR.
  apply AbsSmall_imp_AbsIR; assumption.
 apply shift_minus_leEq.
 apply leEq_transitive with (maxlist l).
  apply maxlist_greater; assumption.
 apply shift_leEq_plus'.
 assumption.
Qed.

Let aux_seq_lub_prop :
  forall (P : IR -> CProp) (H : totally_bounded P),
  (forall k : nat, P (scs_elem _ _ (aux_seq_lub P H k)))
  and (forall (k : nat) (y : IR),
       P y -> y[-]scs_elem _ _ (aux_seq_lub P H k) [<=] Two[*]one_div_succ k).
Proof.
 intros; cut (forall k : nat, P (scs_elem _ _ (aux_seq_lub P H k)) and (forall y : IR,
   P y -> y[-]scs_elem _ _ (aux_seq_lub P H k) [<=] Two[*]one_div_succ k)).
  intro H0.
  split; intro; elim (H0 k); intros.
   assumption.
  apply b; assumption.
 intro; apply scs_prf.
Qed.
(* end hide *)

(**
The following are probably the most important results in this section.
*)

Lemma totally_bounded_has_lub : forall P,
 totally_bounded P -> {z : IR | set_lub_IR P z}.
Proof.
 intros P tot_bnd.
 red in tot_bnd.
 elim tot_bnd; intros non_empty H.
 cut {sequence : nat -> IR | forall k : nat, P (sequence k) |
   forall (k : nat) (x : IR), P x -> x[-]sequence k [<=] Two[*]one_div_succ k}.
  intros H0.
  elim H0.
  intros seq Hseq Hseq'.
  cut (Cauchy_prop seq).
   intro H1.
   set (seq1 := Build_CauchySeq IR seq H1) in *.
   exists (Lim seq1).
   split; intros.
    apply shift_leEq_rht.
    astepl ( [--]ZeroR); rstepr ( [--] (x[-]Lim seq1)).
    apply inv_resp_leEq.
    set (seq2 := Cauchy_const x) in *.
    apply leEq_wdl with (Lim seq2[-]Lim seq1).
     2: apply cg_minus_wd; [ unfold seq2 in |- *; apply eq_symmetric_unfolded; apply Lim_const
       | algebra ].
    apply leEq_wdl with (Lim (Build_CauchySeq IR (fun n : nat => seq2 n[-]seq1 n)
      (Cauchy_minus seq2 seq1))).
     apply leEq_transitive with (Lim twice_inv_seq).
      apply Lim_leEq_Lim; intro; simpl in |- *.
      apply Hseq'; assumption.
     apply eq_imp_leEq.
     apply eq_symmetric_unfolded; apply Limits_unique.
     red in |- *; fold (SeqLimit twice_inv_seq [0]) in |- *.
     apply twice_inv_seq_Lim.
    apply Lim_minus.
   cut (Cauchy_Lim_prop2 seq (Lim seq1)).
    intro H4; red in H4. try rename X into H2.
    elim (H4 (e [/]TwoNZ) (pos_div_two _ _ H2)); clear H4.
    intros n Hn.
    exists (seq n).
     apply Hseq.
    apply leEq_less_trans with (AbsIR (Lim seq1[-]seq n)).
     apply leEq_AbsIR.
    apply leEq_less_trans with (e [/]TwoNZ).
     apply AbsSmall_imp_AbsIR.
     apply AbsSmall_minus; simpl in |- *; apply Hn.
     apply le_n.
    apply pos_div_two'; auto.
   cut (Cauchy_Lim_prop2 seq1 (Lim seq1)); intros.
    try rename X0 into H3.
    red in |- *; red in H3.
    intros eps Heps; elim (H3 eps Heps); clear H3; intros.
    exists x.
    intros m Hm; elim (p m Hm); clear p.
    intros.
    astepr (seq1 m[-]Lim seq1).
    apply AbsIR_eq_AbsSmall; assumption.
   red in |- *; fold (SeqLimit seq1 (Lim seq1)) in |- *.
   apply ax_Lim.
   apply crl_proof.
  red in |- *; intros. try rename X into H1.
  elim (Archimedes ([1][/] e[//]pos_ap_zero _ _ H1)).
  intros n Hn.
  exists (S (2 * n)); intros.
  cut ([0] [<] nring (R:=IR) n); intros.
   apply AbsIR_eq_AbsSmall. try rename X into H3.
    apply leEq_transitive with ( [--] ([1][/] nring n[//]pos_ap_zero _ _ H3)).
     apply inv_resp_leEq.
     apply shift_div_leEq.
      assumption.
     eapply shift_leEq_mult'; [ assumption | apply Hn ].
    rstepr ( [--] (seq (S (2 * n)) [-]seq m)); apply inv_resp_leEq.
    apply leEq_transitive with (Two[*]one_div_succ (R:=IR) m).
     auto.
    apply leEq_transitive with (one_div_succ (R:=IR) n).
     unfold one_div_succ in |- *.
     unfold Snring in |- *.
     rstepl ([1][/] nring (S m) [/]TwoNZ[//]
       div_resp_ap_zero_rev _ _ _ _ (nring_ap_zero IR (S m) (sym_not_eq (O_S m)))).
     apply recip_resp_leEq.
      apply pos_nring_S.
     apply shift_leEq_div.
      apply pos_two.
     simpl in |- *; fold (Two:IR) in |- *.
     rstepl (Two[*]nring (R:=IR) n[+][1][+][1]).
     apply plus_resp_leEq.
     apply leEq_wdl with (nring (R:=IR) (S (2 * n))).
      apply nring_leEq; assumption.
     Step_final (nring (R:=IR) (2 * n) [+][1]).
    unfold one_div_succ in |- *; unfold Snring in |- *; apply recip_resp_leEq.
     assumption.
    simpl in |- *; apply less_leEq; apply less_plusOne.
   apply leEq_transitive with (Two[*]one_div_succ (R:=IR) (S (2 * n))).
    auto.
   apply less_leEq. try rename X into H3.
   apply less_leEq_trans with ([1][/] nring n[//]pos_ap_zero _ _ H3).
    astepl (one_div_succ (R:=IR) (S (2 * n)) [*]Two).
    unfold one_div_succ in |- *; unfold Snring in |- *.
    apply shift_mult_less with (two_ap_zero IR).
     apply pos_two.
    rstepr ([1][/] Two[*]nring n[//] mult_resp_ap_zero _ _ _ (two_ap_zero IR) (pos_ap_zero _ _ H3)).
    apply recip_resp_less.
     astepl (ZeroR[*][0]); apply mult_resp_less_both; try apply leEq_reflexive;
       [ apply pos_two | assumption ].
    apply less_wdr with (Two[*]nring (R:=IR) n[+][1][+][1]).
     apply less_transitive_unfolded with (Two[*]nring (R:=IR) n[+][1]); apply less_plusOne.
    astepr (nring (R:=IR) (S (2 * n)) [+][1]).
    Step_final (nring (R:=IR) (2 * n) [+][1][+][1]).
   rstepr ([1][/] [1][/] e[//]pos_ap_zero _ _ H1[//] div_resp_ap_zero_rev _ _ _ _ (one_ap_zero IR)).
   apply recip_resp_leEq; [ apply recip_resp_pos; assumption | assumption ].
  eapply less_leEq_trans.
   2: apply Hn.
  apply recip_resp_pos; assumption.
 elim (aux_seq_lub_prop P tot_bnd).
 exists (fun k : nat => scs_elem _ _ (aux_seq_lub P tot_bnd k)); auto.
Qed.

(* begin hide *)
Let aux_seq_glb (P : IR -> CProp) (H : totally_bounded P) :
  forall k : nat,
  Build_SubCSetoid IR
    (fun x : IR =>
     P x and (forall y : IR, P y -> x[-]y [<=] Two[*]one_div_succ k)).
Proof.
 elim H; clear H; intros non_empty H k.
 elim (H (one_div_succ k) (one_div_succ_pos IR k)).
 intros l Hl' Hl; clear H.
 cut {y : IR | member y l | y [<=] minlist l[+]one_div_succ k}.
  intro H; inversion_clear H.
  2: apply minlist_leEq_eps.
   2: inversion_clear non_empty.
   2: elim (Hl x).
    2: intros.
    2: exists x0.
    2: tauto.
   2: assumption.
  2: apply one_div_succ_pos.
 exists x; split.
  apply Hl'; assumption.
 intros y Hy.
 elim (Hl y Hy).
 intros z Hz Hz'.
 rstepl (x[-]z[+] (z[-]y)).
 rstepr (one_div_succ (R:=IR) k[+]one_div_succ k).
 apply plus_resp_leEq_both.
  apply shift_minus_leEq.
  apply shift_leEq_plus'.
  apply leEq_transitive with (minlist l).
   apply shift_minus_leEq.
   assumption.
  apply minlist_smaller; assumption.
 apply leEq_transitive with (AbsIR (y[-]z)).
  rstepl ( [--] (y[-]z)); apply inv_leEq_AbsIR.
 apply AbsSmall_imp_AbsIR; assumption.
Qed.

Let aux_seq_glb_prop :
  forall (P : IR -> CProp) (H : totally_bounded P),
  (forall k : nat, P (scs_elem _ _ (aux_seq_glb P H k)))
  and (forall (k : nat) (y : IR),
       P y -> scs_elem _ _ (aux_seq_glb P H k) [-]y [<=] Two[*]one_div_succ k).
Proof.
 intros; cut (forall k : nat, P (scs_elem _ _ (aux_seq_glb P H k)) and (forall y : IR,
   P y -> scs_elem _ _ (aux_seq_glb P H k) [-]y [<=] Two[*]one_div_succ k)).
  intro H0.
  split; intro k; elim (H0 k); intros.
   assumption.
  apply b; assumption.
 intro; apply scs_prf.
Qed.
(* end hide *)

Lemma totally_bounded_has_glb : forall P : IR -> CProp,
 totally_bounded P -> {z : IR | set_glb_IR P z}.
Proof.
 intros P tot_bnd.
 red in tot_bnd.
 elim tot_bnd; intros non_empty H.
 cut {sequence : nat -> IR | forall k : nat, P (sequence k) |
   forall (k : nat) (x : IR), P x -> sequence k[-]x [<=] Two[*]one_div_succ k}.
  intros H0.
  elim H0.
  clear H0; intros seq H0 H1.
  cut (Cauchy_prop seq).
   intro H2.
   set (seq1 := Build_CauchySeq IR seq H2) in *.
   exists (Lim seq1).
   split; intros.
    apply shift_leEq_rht.
    astepl ( [--]ZeroR); rstepr ( [--] (Lim seq1[-]x)).
    apply inv_resp_leEq.
    set (seq2 := Cauchy_const x) in *.
    apply leEq_wdl with (Lim seq1[-]Lim seq2).
     2: apply cg_minus_wd; [ algebra
       | unfold seq2 in |- *; apply eq_symmetric_unfolded; apply Lim_const ].
    apply leEq_wdl with (Lim (Build_CauchySeq IR (fun n : nat => seq1 n[-]seq2 n)
      (Cauchy_minus seq1 seq2))).
     apply leEq_transitive with (Lim twice_inv_seq).
      apply Lim_leEq_Lim; intro.
      simpl in |- *.
      apply H1; assumption.
     apply eq_imp_leEq.
     apply eq_symmetric_unfolded; apply Limits_unique.
     red in |- *; fold (SeqLimit twice_inv_seq [0]) in |- *.
     apply twice_inv_seq_Lim.
    apply Lim_minus.
   cut (Cauchy_Lim_prop2 seq (Lim seq1)).
    intro H4; red in H4. try rename X into H3.
    elim (H4 (e [/]TwoNZ) (pos_div_two _ _ H3)); clear H4.
    intros n Hn.
    exists (seq n).
     apply H0.
    apply leEq_less_trans with (AbsIR (Lim seq1[-]seq n)).
     rstepl ( [--] (Lim seq1[-]seq n)).
     apply inv_leEq_AbsIR.
    apply leEq_less_trans with (e [/]TwoNZ).
     apply AbsSmall_imp_AbsIR.
     apply AbsSmall_minus; simpl in |- *; apply Hn.
     apply le_n.
    apply pos_div_two'; auto.
   cut (Cauchy_Lim_prop2 seq1 (Lim seq1)); intros.
    try rename X0 into H4.
    red in |- *; red in H4.
    intros eps Heps; elim (H4 eps Heps); clear H4; intros.
    exists x.
    intros m Hm; elim (p m Hm); clear p.
    intros.
    astepr (seq1 m[-]Lim seq1).
    apply AbsIR_eq_AbsSmall; assumption.
   red in |- *; fold (SeqLimit seq1 (Lim seq1)) in |- *.
   apply ax_Lim.
   apply crl_proof.
  red in |- *; intros e H2.
  elim (Archimedes ([1][/] e[//]pos_ap_zero _ _ H2)).
  intros n Hn.
  exists (S (2 * n)); intros.
  cut ([0] [<] nring (R:=IR) n); intros.
   apply AbsIR_eq_AbsSmall.
    try rename X into H4.
    apply leEq_transitive with ( [--] ([1][/] nring n[//]pos_ap_zero _ _ H4)).
     apply inv_resp_leEq.
     apply shift_div_leEq.
      assumption.
     eapply shift_leEq_mult'; [ assumption | apply Hn ].
    apply less_leEq.
    rstepr ( [--] (seq (S (2 * n)) [-]seq m)); apply inv_resp_less.
    apply leEq_less_trans with (Two[*]one_div_succ (R:=IR) (S (2 * n))).
     apply H1; apply H0.
    astepl (one_div_succ (R:=IR) (S (2 * n)) [*]Two).
    unfold one_div_succ in |- *; unfold Snring in |- *.
    apply shift_mult_less with (two_ap_zero IR).
     apply pos_two.
    rstepr ([1][/] Two[*]nring n[//] mult_resp_ap_zero _ _ _ (two_ap_zero IR) (pos_ap_zero _ _ H4)).
    apply recip_resp_less.
     astepl (ZeroR[*][0]); apply mult_resp_less_both; try apply leEq_reflexive;
       [ apply pos_two | assumption ].
    apply less_wdr with (Two[*]nring (R:=IR) n[+][1][+][1]).
     apply less_transitive_unfolded with (Two[*]nring (R:=IR) n[+][1]); apply less_plusOne.
    astepr (nring (R:=IR) (S (2 * n)) [+][1]).
    Step_final (nring (R:=IR) (2 * n) [+][1][+][1]).
   apply leEq_transitive with (Two[*]one_div_succ (R:=IR) m).
    apply H1; apply H0.
   apply leEq_transitive with (one_div_succ (R:=IR) n).
    unfold one_div_succ in |- *.
    unfold Snring in |- *.
    rstepl ([1][/] nring (R:=IR) (S m) [/]TwoNZ[//]
      div_resp_ap_zero_rev _ _ _ _ (nring_ap_zero IR (S m) (sym_not_eq (O_S m)))).
    apply recip_resp_leEq.
     apply pos_nring_S.
    apply shift_leEq_div.
     apply pos_two.
    simpl in |- *; fold (Two:IR) in |- *.
    rstepl (Two[*]nring (R:=IR) n[+][1][+][1]).
    apply plus_resp_leEq.
    apply leEq_wdl with (nring (R:=IR) (S (2 * n))).
     apply nring_leEq; assumption.
    Step_final (nring (R:=IR) (2 * n) [+][1]).
   unfold one_div_succ in |- *; unfold Snring in |- *.
   rstepr ([1][/] [1][/] e[//]pos_ap_zero _ _ H2[//] div_resp_ap_zero_rev _ _ _ _ (one_ap_zero IR)).
   apply recip_resp_leEq.
    apply recip_resp_pos; assumption.
   apply leEq_transitive with (nring (R:=IR) n);
     [ assumption | simpl in |- *; apply less_leEq; apply less_plusOne ].
  eapply less_leEq_trans.
   2: apply Hn.
  apply recip_resp_pos; assumption.
 elim (aux_seq_glb_prop P tot_bnd).
 exists (fun k : nat => scs_elem _ _ (aux_seq_glb P tot_bnd k)); auto.
Qed.

End Totally_Bounded.

Section Compact.

(**
** Compact sets

In this section we dwell a bit farther into the definition of compactness
and explore some of its properties.

The following characterization of inclusion can be very useful:
*)

Lemma included_compact : forall (a b c d : IR) Hab Hcd, compact a b Hab c ->
 compact a b Hab d -> included (compact c d Hcd) (compact a b Hab).
Proof.
 intros a b c d Hab Hcd H H0 x H1.
 inversion_clear H.
 inversion_clear H0.
 inversion_clear H1.
 split.
  apply leEq_transitive with c; auto.
 apply leEq_transitive with d; auto.
Qed.

(**
At several points in our future development of a theory we will need
to partition a compact interval in subintervals of length smaller than
some predefined value [eps]. Although this seems a
consequence of every compact interval being totally bounded, it is in
fact a stronger property.  In this section we perform that
construction (requiring the endpoints of the interval to be distinct)
and prove some of its good properties.

%\begin{convention}% Let [a,b : IR], [Hab : (a [<=] b)] and denote by [I]
the compact interval [[a,b]].  Also assume that [a [<] b], and let [e] be
a positive real number.
%\end{convention}%
*)

Variables a b : IR.
Hypothesis Hab : a [<=] b.
(* begin hide *)
Let I := compact a b Hab.
(* end hide *)

Hypothesis Hab' : a [<] b.

Variable e : IR.
Hypothesis He : [0] [<] e.

(**
We start by finding a natural number [n] such that [(b[-]a) [/] n [<] e].
*)

Definition compact_nat := ProjT1 (Archimedes (b[-]a[/] e[//]pos_ap_zero _ _ He)).

(** Obviously such an [n] must be greater than zero.*)

Lemma pos_compact_nat : [0] [<] nring (R:=IR) compact_nat.
Proof.
 apply less_leEq_trans with (b[-]a[/] e[//]pos_ap_zero _ _ He).
  rstepr ((b[-]a) [*] ([1][/] e[//]pos_ap_zero _ _ He)).
  apply mult_resp_pos.
   apply shift_less_minus; astepl a; assumption.
  apply recip_resp_pos; assumption.
 unfold compact_nat in |- *; apply proj2_sigT.
Qed.

(**
We now define a sequence on [n] points in [[a,b]] by
[x_i [=] Min(a,b) [+]i[*] (b[-]a) [/]n] and
prove that all of its points are really in that interval.
*)

Definition compact_part (i : nat) : i <= compact_nat -> IR.
Proof.
 intros.
 apply (a[+]nring i[*] (b[-]a[/] _[//]pos_ap_zero _ _ pos_compact_nat)).
Defined.

Lemma compact_part_hyp : forall i Hi, compact a b Hab (compact_part i Hi).
Proof.
 intros; unfold compact_part in |- *.
 split.
  astepl (a[+][0]); apply plus_resp_leEq_lft.
  astepl (ZeroR[*][0]); apply mult_resp_leEq_both; try apply leEq_reflexive.
   apply nring_nonneg.
  apply shift_leEq_div.
   apply pos_compact_nat.
  apply shift_leEq_minus; rstepl a; apply less_leEq; assumption.
 rstepr (a[+]nring compact_nat[*] (b[-]a[/] _[//]pos_ap_zero _ _ pos_compact_nat)).
 apply plus_resp_leEq_lft.
 apply mult_resp_leEq_rht; try apply nring_nonneg.
  apply nring_leEq; assumption.
 apply shift_leEq_div.
  apply pos_compact_nat.
 apply shift_leEq_minus; rstepl a; apply less_leEq; assumption.
Qed.

(**
This sequence is strictly increasing and each two consecutive points
are apart by less than [e].*)

Lemma compact_less : forall i Hi HSi, [0] [<] compact_part (S i) HSi[-]compact_part i Hi.
Proof.
 intros i H1 H2.
 apply shift_less_minus; astepl (compact_part _ H1).
 unfold compact_part in |- *.
 apply plus_resp_less_lft.
 apply mult_resp_less.
  simpl in |- *; apply less_plusOne.
 apply div_resp_pos.
  apply pos_compact_nat.
 apply shift_less_minus; astepl a; assumption.
Qed.

Lemma compact_leEq : forall i Hi HSi, compact_part (S i) HSi[-]compact_part i Hi [<=] e.
Proof.
 intros i H1 H2.
 unfold compact_part in |- *; simpl in |- *.
 rstepl (b[-]a[/] _[//]pos_ap_zero _ _ pos_compact_nat).
 apply shift_div_leEq.
  apply pos_compact_nat.
 apply shift_leEq_mult' with (pos_ap_zero _ _ He).
  assumption.
 exact (ProjT2 (Archimedes _)).
Qed.

(** When we proceed to integration, this lemma will also be useful: *)

Lemma compact_partition_lemma : forall n Hn i, i <= n ->
 Compact Hab (a[+]nring i[*] (b[-]a[/] _[//]nring_ap_zero' _ n Hn)).
Proof.
 intros n Hn i H; split.
  apply shift_leEq_plus'.
  astepl ZeroR.
  apply mult_resp_nonneg.
   apply nring_nonneg.
  apply shift_leEq_div.
   apply nring_pos; apply neq_O_lt; auto.
  apply shift_leEq_minus.
  rstepl a; assumption.
 apply shift_plus_leEq'.
 rstepr (nring n[*] (b[-]a[/] _[//]nring_ap_zero' _ _ Hn)).
 astepl ([0][+]nring i[*] (b[-]a[/] _[//]nring_ap_zero' _ _ Hn)).
 apply shift_plus_leEq.
 rstepr ((nring n[-]nring i) [*] (b[-]a[/] _[//]nring_ap_zero' _ _ Hn)).
 apply mult_resp_nonneg.
  apply shift_leEq_minus.
  astepl (nring (R:=IR) i).
  apply nring_leEq; assumption.
 apply shift_leEq_div.
  apply nring_pos; apply neq_O_lt; auto.
 apply shift_leEq_minus.
 rstepl a; assumption.
Qed.

(** The next lemma provides an upper bound for the distance between two points in an interval: *)

Lemma compact_elements : forall x y : IR,
 Compact Hab x -> Compact Hab y -> AbsIR (x[-]y) [<=] AbsIR (b[-]a).
Proof.
 clear Hab' He e.
 do 2 intro; intros Hx Hy.
 apply leEq_wdr with (b[-]a).
  2: apply eq_symmetric_unfolded; apply AbsIR_eq_x.
  2: apply shift_leEq_minus; astepl a; auto.
 eapply leEq_wdl.
  2: apply eq_symmetric_unfolded; apply Abs_Max.
 inversion_clear Hx.
 inversion_clear Hy.
 unfold cg_minus in |- *; apply plus_resp_leEq_both.
  apply Max_leEq; auto.
 apply inv_resp_leEq.
 apply leEq_Min; auto.
Qed.

Opaque Min Max.

(** The following is a variation on the previous lemma: *)

Lemma compact_elements' : forall c d Hcd x y, Compact Hab x ->
 compact c d Hcd y -> AbsIR (x[-]y) [<=] AbsIR (Max b d[-]Min a c).
Proof.
 do 5 intro; intros Hx Hy.
 eapply leEq_transitive.
  2: apply leEq_AbsIR.
 inversion_clear Hx.
 inversion_clear Hy.
 simpl in |- *; unfold ABSIR in |- *; apply Max_leEq.
  unfold cg_minus in |- *; apply plus_resp_leEq_both.
   apply leEq_transitive with b; auto; apply lft_leEq_Max.
  apply inv_resp_leEq; apply leEq_transitive with c; auto; apply Min_leEq_rht.
 rstepl (y[-]x).
 unfold cg_minus in |- *; apply plus_resp_leEq_both.
  apply leEq_transitive with d; auto; apply rht_leEq_Max.
 apply inv_resp_leEq; apply leEq_transitive with a; auto; apply Min_leEq_lft.
Qed.

(** The following lemma is a bit more specific: it shows that we can
also estimate the distance from the center of a compact interval to
any of its points. *)

Lemma compact_bnd_AbsIR : forall x y d H,
 compact (x[-]d) (x[+]d) H y -> AbsIR (x[-]y) [<=] d.
Proof.
 intros x y d H H0.
 inversion_clear H0.
 simpl in |- *; unfold ABSIR in |- *.
 apply Max_leEq.
  apply shift_minus_leEq; apply shift_leEq_plus'; auto.
 rstepl (y[-]x).
 apply shift_minus_leEq.
 astepr (x[+]d); auto.
Qed.

(** Finally, two more useful lemmas to prove inclusion of compact
intervals.  They will be necessary for the definition and proof of the
elementary properties of the integral.  *)

Lemma included2_compact : forall x y Hxy, Compact Hab x -> Compact Hab y ->
 included (compact (Min x y) (Max x y) Hxy) (Compact Hab).
Proof.
 do 3 intro. intros H H0.
 inversion_clear H.
 inversion_clear H0.
 apply included_compact; split.
    apply leEq_Min; auto.
   apply leEq_transitive with y.
    apply Min_leEq_rht.
   auto.
  apply leEq_transitive with y.
   auto.
  apply rht_leEq_Max.
 apply Max_leEq; auto.
Qed.

Lemma included3_compact : forall x y z Hxyz,
 Compact Hab x -> Compact Hab y -> Compact Hab z ->
 included (compact (Min (Min x y) z) (Max (Max x y) z) Hxyz) (Compact Hab).
Proof.
 do 4 intro. intros H H0 H1.
 inversion_clear H.
 inversion_clear H0.
 inversion_clear H1.
 apply included_compact; split.
    repeat apply leEq_Min; auto.
   apply leEq_transitive with z.
    apply Min_leEq_rht.
   auto.
  apply leEq_transitive with z.
   auto.
  apply rht_leEq_Max.
 repeat apply Max_leEq; auto.
Qed.

End Compact.

#[global]
Hint Resolve included_compact included2_compact included3_compact : included.


Require Import Logic.lib.Coqlib.
Require Import Logic.GeneralLogic.Base.
Require Import Logic.GeneralLogic.KripkeModel.
Require Import Logic.GeneralLogic.Semantics.Kripke.
Require Import Logic.MinimumLogic.Syntax.
Require Import Logic.MinimumLogic.Semantics.Kripke.
Require Import Logic.PropositionalLogic.Syntax.
Require Import Logic.PropositionalLogic.Semantics.Kripke.
Require Import Logic.SeparationLogic.Syntax.
Require Import Logic.SeparationLogic.Model.SeparationAlgebra.
Require Import Logic.SeparationLogic.Model.OrderedSA.
Require Import Logic.SeparationLogic.Semantics.FlatSemantics.

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

Section Sound_Flat.

Context {L: Language}
        {minL: MinimumLanguage L}
        {pL: PropositionalLanguage L}
        {sepconL: SepconLanguage L}
        {wandL: WandLanguage L}
        {MD: Model}
        {kMD: KripkeModel MD}
        (M: Kmodel)
        {R: Relation (Kworlds M)}
        {po_R: PreOrder Krelation}
        {J: Join (Kworlds M)}
        {SA: SeparationAlgebra (Kworlds M)}
        {dSA: DownwardsClosedSeparationAlgebra (Kworlds M)}
        {SM: Semantics L MD}
        {kiSM: KripkeIntuitionisticSemantics L MD M SM}
        {kminSM: KripkeMinimumSemantics L MD M SM}
        {kpSM: KripkePropositionalSemantics L MD M SM}
        {fsepconSM: FlatSemantics.SepconSemantics L MD M SM}
        {fwandSM: FlatSemantics.WandSemantics L MD M SM}.

Lemma sound_sepcon_comm:
  forall x y: expr,
    forall m,
      KRIPKE: M, m |= x * y --> y * x.
Proof.
  intros.
  rewrite sat_impp; intros.
  rewrite sat_sepcon in H0 |- *; intros.
  destruct H0 as [m1 [m2 [? [? ?]]]].
  exists m2, m1.
  split; [| split]; auto.
  apply join_comm; auto.
Qed.

Lemma sound_sepcon_assoc1:
  forall x y z: expr,
    forall m,
      KRIPKE: M, m |= x * (y * z) --> (x * y) * z.
Proof.
  intros.
  rewrite sat_impp; intros.
  rewrite sat_sepcon in H0.
  destruct H0 as [mx [myz [? [? ?]]]].
  rewrite sat_sepcon in H2.
  destruct H2 as [my [mz [? [? ?]]]].
  apply join_comm in H0.
  apply join_comm in H2.
  destruct (join_assoc mz my mx myz n H2 H0) as [mxy [? ?]].
  apply join_comm in H5.
  apply join_comm in H6.
  rewrite sat_sepcon.
  exists mxy, mz.
  split; [| split]; auto.
  rewrite sat_sepcon.
  exists mx, my.
  split; [| split]; auto.
Qed.

Lemma sound_wand_sepcon_adjoint:
  forall x y z: expr,
    (forall m, KRIPKE: M, m |= x * y --> z) <-> (forall m, KRIPKE: M, m |= x --> (y -* z)).
Proof.
  intros.
  split; intro.
  + assert (ASSU: forall m1 m2 m, join m1 m2 m -> KRIPKE: M, m1 |= x -> KRIPKE: M, m2 |= y -> KRIPKE: M, m |= z).
    {
      intros.
      specialize (H m).
      rewrite sat_impp in H.
      apply (H m); [reflexivity |].
      rewrite sat_sepcon.
      exists m1, m2; auto.
    }
    clear H.
    intros.
    rewrite sat_impp; intros.
    rewrite sat_wand; intros.
    apply (ASSU n m1 m2); auto.
  + assert (ASSU: forall m1 m2 m, join m m1 m2 -> KRIPKE: M, m |= x -> KRIPKE: M, m1 |= y -> KRIPKE: M, m2 |= z).
    {
      intros.
      specialize (H m).
      rewrite sat_impp in H.
      revert m1 m2 H0 H2.
      rewrite <- sat_wand.
      apply (H m); [reflexivity | auto].
    }
    intros.
    rewrite sat_impp; intros.
    rewrite sat_sepcon in H1.
    destruct H1 as [m1 [m2 [? [? ?]]]].
    apply (ASSU m2 n m1); auto.
Qed.

Lemma sound_sepcon_mono:
  forall x1 x2 y1 y2: expr,
   (forall m, KRIPKE: M, m |= x1 --> x2) ->
   (forall m, KRIPKE: M, m |= y1 --> y2) ->
   (forall m, KRIPKE: M, m |= x1 * y1 --> x2 * y2).
Proof.
  intros.
  assert (ASSUx: forall m, KRIPKE: M, m |= x1 -> KRIPKE: M, m |= x2).
  {
    intros.
    specialize (H m0).
    rewrite sat_impp in H.
    apply (H m0); [reflexivity | auto].
  }
  assert (ASSUy: forall m, KRIPKE: M, m |= y1 -> KRIPKE: M, m |= y2).
  {
    intros.
    specialize (H0 m0).
    rewrite sat_impp in H0.
    apply (H0 m0); [reflexivity | auto].
  }
  rewrite sat_impp; intros.
  rewrite sat_sepcon in H2 |- *.
  destruct H2 as [m1 [m2 [? [? ?]]]].
  exists m1, m2; auto.
Qed.

Lemma sound_sepcon_elim1 {incrSA: IncreasingSeparationAlgebra (Kworlds M)}:
  forall x y: expr,
    forall m, KRIPKE: M, m |= x * y --> x.
Proof.
  intros.
  rewrite sat_impp; intros.
  rewrite sat_sepcon in H0.
  destruct H0 as [m1 [m2 [? [? ?]]]].
  apply join_comm in H0.
  apply all_increasing in H0.
  eapply sat_mono; eauto.
Qed.

Context {empL: EmpLanguage L}
        {feSM: EmpSemantics L MD M SM}.

Lemma sound_sepcon_emp1 {USA: UnitalSeparationAlgebra (Kworlds M)}:
  forall x: expr,
    forall m, KRIPKE: M, m |= x * emp --> x.
Proof.
  intros.
  rewrite sat_impp; intros.
  rewrite sat_sepcon in H0.
  destruct H0 as [n' [u [? [? ?]]]].
  rewrite sat_emp in H2.
  apply join_comm in H0.
  unfold increasing in H2.
  specialize (H2 _ _ H0).
  eapply sat_mono; eauto.
Qed.

Lemma sound_sepcon_emp2 {USA: UnitalSeparationAlgebra (Kworlds M)}:
  forall x: expr,
    forall m, KRIPKE: M, m |= x --> x * emp.
Proof.
  intros.
  rewrite sat_impp; intros.
  rewrite sat_sepcon.
  destruct (incr_exists n) as [u [? ?]].
  destruct H1 as [n' [H1 H1']].
  exists n', u.
  split; [| split]; auto.
  + apply join_comm; auto.
  + eapply sat_mono; eauto.
  + rewrite sat_emp; auto.
Qed.

Lemma sound_emp_sepcon_elim1 {ISSSA: IncreasingSplitSmallerSeparationAlgebra (Kworlds M)}:
  forall x y: expr,
    forall m, KRIPKE: M, m |= x * y && emp --> x.
Proof.
  intros.
  rewrite sat_impp; intros.
  rewrite sat_andp, sat_sepcon, sat_emp in H0.
  clear m H.
  destruct H0 as [[n1 [n2 [? [? ?]]]] ?].
  eapply incr_split_smaller in H2; [| exact H].
  eapply sat_mono; eauto.
Qed.

Lemma sound_emp_dup {IJSSA: IncreasingJoinSelfSeparationAlgebra (Kworlds M)}:
  forall x y: expr,
    forall m, KRIPKE: M, m |= x && emp --> x * x.
Proof.
  intros.
  rewrite sat_impp; intros.
  rewrite sat_andp, sat_emp in H0.
  rewrite sat_sepcon.
  clear m H.
  destruct H0.
  pose proof incr_join_self n H0.
  exists n, n; auto.
Qed.

End Sound_Flat.


Load classifying_space.
Open Scope monoid_scope.

(*Defining the classifying space of a monoid quick and dirty*)
Definition B (M : Monoid) := B2 M.
Definition B_loop {M : Monoid} := @B2_loop M.
Definition B_resp_mul {M : Monoid} (m n : M) := @B2_resp_mul M m n.
Definition B_resp_id {M : Monoid} := @B2_resp_id M.

Section trystuff.
  Variable M : Monoid.
  Variable C : Type. Variable Cp : M -> C.
  Variables l m n : M.
End trystuff.

Definition C_id {M : Monoid}
           {C : Type} {c0 : C}
           {Cp : M -> c0 = c0}
           (Cmul : forall m n : M, Cp (m + n) = Cp m @ Cp n) :
  Cp (mon_id M) = idpath.
Proof.
  apply (cancelR _ _ (Cp (mon_id M))).
  refine (_ @ (concat_1p _)^).
  refine (_ @ (ap Cp (mon_lid (mon_id M)))).
  apply (Cmul (mon_id M) (mon_id M))^.
Defined.

(*Now comes the cheating*)
Definition B_rec {M : Monoid}
           (C : Type) (c0 : C)
           (Cp : M -> c0 = c0)
           (Cmul : forall m n : M, Cp (m + n) = Cp m @ Cp n)
           (C_assoc : forall l m n : M,
                       ap Cp (@mon_assoc M l m n) @ Cmul (l + m) n @ whiskerR (Cmul l m) (Cp n) =
                       Cmul l (m + n) @ whiskerL (Cp l) (Cmul m n) @ concat_p_pp (Cp l) (Cp m) (Cp n))
           (C_lid : forall m : M,
                      ap Cp (mon_lid m) =
                      Cmul (mon_id M) m @ whiskerR (C_id Cmul) (Cp m) @ (concat_1p (Cp m)))
           (C_rid : forall m : M,
                      ap Cp (mon_rid m) =
                      Cmul m (mon_id M) @ whiskerL (Cp m) (C_id Cmul) @ (concat_p1 (Cp m)))

           : B M -> C
  := B2_rec C c0 Cp Cmul. (*Cheating cheating cheating*)

Definition B_rec_beta_Cp {M : Monoid}
           (C : Type) (c0 : C) (Cp : forall m : M, c0 = c0)
           (Cmul : forall m n : M, Cp (m + n) = Cp m @ Cp n)
           (C_assoc : forall l m n : M,
                       ap Cp (@mon_assoc M l m n) @ Cmul (l + m) n @ whiskerR (Cmul l m) (Cp n) =
                       Cmul l (m + n) @ whiskerL (Cp l) (Cmul m n) @ concat_p_pp (Cp l) (Cp m) (Cp n))
           (C_lid : forall m : M,
                      ap Cp (mon_lid m) =
                      Cmul (mon_id M) m @ whiskerR (C_id Cmul) (Cp m) @ (concat_1p (Cp m)))
           (C_rid : forall m : M,
                      ap Cp (mon_rid m) =
                      Cmul m (mon_id M) @ whiskerL (Cp m) (C_id Cmul) @ (concat_p1 (Cp m)))
           (m : M) :
  ap (B_rec C c0 Cp Cmul C_assoc C_lid C_rid) (B_loop m) = Cp m.
  apply B2_rec_beta_l.
Defined.

(*Inconsistent:*)
Definition B_rec_beta_Cmul {M : Monoid}
           (C : Type) (c0 : C) (Cp : forall m : M, c0 = c0)
           (Cmul : forall m n : M, Cp (m + n) = Cp m @ Cp n)
           (C_assoc : forall l m n : M,
                       ap Cp (@mon_assoc M l m n) @ Cmul (l + m) n @ whiskerR (Cmul l m) (Cp n) =
                       Cmul l (m + n) @ whiskerL (Cp l) (Cmul m n) @ concat_p_pp (Cp l) (Cp m) (Cp n))
           (C_lid : forall m : M,
                      ap Cp (mon_lid m) =
                      Cmul (mon_id M) m @ whiskerR (C_id Cmul) (Cp m) @ (concat_1p (Cp m)))
           (C_rid : forall m : M,
                      ap Cp (mon_rid m) =
                      Cmul m (mon_id M) @ whiskerL (Cp m) (C_id Cmul) @ (concat_p1 (Cp m)))
           (m n : M) :
  ap02 (B_rec C c0 Cp Cmul C_assoc C_lid C_rid) (B_resp_mul m n) =
  (B_rec_beta_Cp C c0 Cp Cmul C_assoc C_lid C_rid (m + n))
    @ Cmul m n @
    ((B_rec_beta_Cp C c0 Cp Cmul C_assoc C_lid C_rid m)^ @@
     (B_rec_beta_Cp C c0 Cp Cmul C_assoc C_lid C_rid n)^) @ (ap_pp _ _ _)^.
Admitted.

           ap02
    section_to_depfun


Require Export ZArith.
Require Export List.
Require Export Arith.
Require Export Omega.
Require Export Zwf.
Require Export Inverse_Image Extraction.

Open Scope nat_scope.

Extraction "pplus" Pplus.

Fixpoint Psucc (x:positive) : positive :=
  match x with
    xI x' => xO (Psucc x') | xO x' => xI x' | xH => xO xH
  end.

Fixpoint nth' (A:Set)(l:list A)(n:nat){struct n} : option A :=
  match l, n with
  |  nil, _ => None
  | cons a tl, O => Some a
  | cons a tl, S p => nth' A tl p
  end.

Parameters
 (xH_xI : forall p:positive, xH<>xI p)
 (xH_xO : forall p:positive, xH<>xO p)
 (eq_xI : forall p q:positive, p=q-> xI p = xI q)
 (eq_xO : forall p q:positive, p=q-> xO p = xO q)
 (not_eq_xI : forall p q:positive, p<>q-> xI p <> xI q)
 (not_eq_xO : forall p q:positive, p<>q-> xO p <> xO q)
 (xI_xO : forall p q:positive, xI p<>xO q).

Fixpoint eq_positive_dec (n m:positive){struct m} :
   {n = m}+{n <> m} :=
  match n return {n = m}+{n <> m} with
  | xI p =>
    match m return {xI p = m}+{xI p <> m} with
    | xI q =>
      match eq_positive_dec p q with
      | left heq => left _ (eq_xI p q heq)
      | right hneq => right _ (not_eq_xI p q hneq)
      end
    | xO q => right _ (xI_xO p q)
    | xH => right _ (sym_not_equal (xH_xI p))
    end
  | xO p =>
    match m return {xO p = m}+{xO p <> m} with
    | xI q => right _ (sym_not_equal (xI_xO q p))
    | xO q =>
      match eq_positive_dec p q with
      | left heq => left _ (eq_xO p q heq)
      | right hneq => right _ (not_eq_xO p q hneq)
      end
    | xH => right _ (sym_not_equal (xH_xO p))
    end
  | xH => match m return {xH = m}+{xH <> m} with
                   | xI q => right _ (xH_xI q)
                   | xO q => right _ (xH_xO q)
                   | xH => left _ (refl_equal xH)
                   end
  end.

Definition pred' (n:nat) : n <> 0 -> nat :=
  match n return n <> 0 -> nat with
  | O => fun h:0 <> 0 => False_rec nat (h (refl_equal 0))
  | S p => fun h:S p <> 0 => p
  end.

Definition pred2 (n:nat) : nat :=
  match eq_nat_dec n 0 with
  | left h => 0
  | right h' => pred' n h'
  end.

Definition pred'_on_O := pred' O.

(* the following module is just here for understanding
   what is already built in Coq's libraries *)

Module redefine_acc.

Inductive Acc {A:Type}(R:A->A->Prop) : A->Prop :=
    Acc_intro : forall x:A, (forall y:A, R y x -> Acc  R y) ->
                             Acc  R x.

Arguments Acc_intro {A R} x f.

Definition Acc_inv {A:Type}(R:A->A->Prop)(x:A)(Hacc:Acc  R x) :
  forall y:A, R y x -> Acc  R y :=
  match Hacc as H in (Acc  _ x)
        return (forall y:A, R y x -> Acc  R y) with
  | Acc_intro  x f => f
  end.

Fixpoint Acc_iter {A:Type}(R:A->A->Prop)(P:A->Type)
 (f:forall x:A, (forall y:A, R y x -> P y)-> P x)(x:A)
 (hacc:Acc  R x){struct hacc} : P x :=
  f x (fun (y:A)(hy:R y x) =>
       Acc_iter  R P f y (Acc_inv  R x hacc y hy)).

Definition well_founded_induction {A:Type}(R:A->A->Prop)
  (Rwf:forall x:A, Acc  R x)(P:A->Type)
  (F:forall x:A, (forall y:A, R y x -> P y)-> P x)(x:A) : P x :=
  Acc_iter  R P F x (Rwf x).

End redefine_acc.

Fixpoint div2 (n:nat) : nat :=
  match n with S (S p) => S (div2 p) | _ => 0 end.

Hypotheses
  (div2_lt : forall x:nat, div2 (S x) < S x)
  (lt_wf : forall x:nat, Acc lt x).

Definition log2_aux_F (x:nat) : (forall y:nat, y < x -> nat)->nat :=
  match x return (forall y:nat, y < x -> nat)-> nat with
  | O => fun _ => 0
  | S p => fun f => S (f (div2 (S p))(div2_lt p))
  end.

Definition log2_aux :=
  well_founded_induction lt_wf (fun _:nat => nat) log2_aux_F.

Definition log2 (x:nat)(h:x <> 0) : nat := log2_aux (pred x).

Definition sumbool_to_or (A B:Prop)(v:{A}+{B}) : A\/B :=
  match v with
  | left Ha => or_introl B Ha
  | right Hb => or_intror A Hb
  end.

Open Scope Z_scope.

Record tuple : Set := mk_tuple {b:bool; x:Z}.

Definition Zgt_bool' :
  forall x y:Z, {Zgt_bool x y = true}+{Zgt_bool x y = false}.
 intros x0 y0; case (Zgt_bool x0 y0); auto.
Defined.

Definition loop1' :
  forall t:tuple, (forall t1:tuple, Zwf 0 (x t1)(x t) -> tuple)->tuple.
 refine
  (fun (t:tuple)
     (loop_again:forall t':tuple, Zwf 0 (x t')(x t) -> tuple) =>
     match Zgt_bool' (x t) 0 with
     | left h => loop_again (mk_tuple (b t)((x t)-1)) _
     | right h => t
     end).
 generalize (Zgt_cases (x t) 0); rewrite h; intros; cbn.
 unfold Zwf; omega.
Defined.

Definition loop1 : tuple->tuple :=
  well_founded_induction
    (wf_inverse_image tuple Z (Zwf 0) x (Zwf_well_founded 0))
    (fun _:tuple => tuple) loop1'.

Set Implicit Arguments.

Parameter array : Z->Set->Set.
Parameter new : forall (n:Z)(T:Set), T->array n T.
Parameter access : forall (n:Z)(T:Set), array n T -> Z->T.
Parameter
  store : forall (n:Z)(T:Set), array n T -> Z -> T -> array n T.

Axiom new_def :
    forall (n:Z)(T:Set)(v0:T)(i:Z),
      0 <= i < n -> access (new n v0) i = v0.

Axiom store_def_1 :
    forall (n:Z)(T:Set)(t:array n T)(v:T)(i:Z),
      0 <= i < n -> access (store t i v) i = v.

Axiom store_def_2 :
    forall (n:Z)(T:Set)(t:array n T)(v:T)(i j:Z),
    0 <= i < n -> 0 <= j < n -> i <> j ->
    access (store t i v) j = access t j.
Unset Implicit Arguments.

Parameter l : Z.

Record tuple':Set := mk_tuple' {a:array l Z; y:Z; z:Z}.

Definition insert_loop : tuple'->tuple'.
refine
 (well_founded_induction
    (wf_inverse_image _ _ _ (fun t:tuple' => l-(z t))
       (Zwf_well_founded 0))
    (fun _:tuple' => tuple')
    (fun (t:tuple')
       (loop_again:forall t':tuple',
                     Zwf 0 (l-(z t'))(l-(z t))->tuple') =>
       match Z_gt_le_dec l (z t) with
       | left h0 =>
         match Z_gt_le_dec (y t)(z t) with
         | left _ =>
             (fun (h1:0 <= (z t)-1 < l)
                (h2:0 <= (z t) < l) =>
                loop_again
                  (mk_tuple'
                     (store (a t)((z t)-1)
                            (access (a t)(z t)))
                     (y t)((z t)+1)) _) _ _
         | right _ =>
             (fun h1:0 <= (z t) < l =>
                loop_again
                  (mk_tuple' (store (a t)((z t)-1)(y t))
                      (y t) l)
                  _) _
         end
       | right h3 => t
       end)).
 Abort.

 Check (forall t:tuple', 0 < (z t) -> tuple').
 Definition insert_loop' : forall t:tuple', 0 < (z t) -> tuple'.
  refine
  (well_founded_induction
    (wf_inverse_image _ _ _
       (fun t:tuple' => l-(z t))(Zwf_well_founded 0))
    (fun t:tuple' => 0 < (z t) -> tuple')
    (fun (t:tuple')
       (loop_again:forall t':tuple',
                     Zwf 0 (l-(z t'))(l-(z t)) ->
                     0 < (z t') -> tuple')(h4:0 < (z t)) =>
       match Z_gt_le_dec l (z t) with
       | left h0 =>
         match Z_gt_le_dec (y t)(z t) with
         | left _ =>
             (fun (h1:0 <= (z t)-1 < l)
                (h2:0 <= (z t) < l) =>
                loop_again
                  (mk_tuple'
                     (store (a t)((z t)-1)(access (a t)(z t)))
                     (y t)((z t)+1)) _ _) _ _
         | right _ =>
             (fun h1:0 <= (z t) < l =>
                loop_again
                  (mk_tuple' (store (a t)((z t)-1)(y t))(y t) l)
                  _ _) _
         end
       | right _ => t
       end)); cbn; try (unfold Zwf); omega.
Defined.


Require Import String.
Require Import List.
Require Import Nat.

Open Scope string_scope.
Open Scope list_scope.
Open Scope core_scope.

Import ListNotations.

Require Import AST.
Require Import Maps.

Inductive typecheck : t_env -> t_expr -> t_type -> Prop :=
  (* ENum *)
  (* EBool *)
  (* EVar *)
  | TC_Num: forall env n,
    typecheck env (ENum n) TNum
  | TC_Bool: forall env b,
    typecheck env (EBool b) TBool
  | TC_Var: forall env x T,
    env x = Some T ->
    typecheck env (EVar x) T

  (* EIf *)
  | TC_If: forall env c e1 e2 T,
    typecheck env c TBool ->
    typecheck env e1 T ->
    typecheck env e2 T ->
    typecheck env (EIf c e1 e2) T

  (* EFun *)
  | TC_Fun: forall env x x_T e e_T,
    typecheck (update env x x_T) e e_T ->
    typecheck env (EFun x x_T e) (TFun x_T e_T)

  (* ECall *)
  | TC_Call: forall env f e e_T T,
    typecheck env f (TFun e_T T) ->
    typecheck env e e_T ->
    typecheck env (ECall f e) T

  (* ECons *)
  | TC_Cons: forall env hd tl T,
    typecheck env hd T ->
    typecheck env tl (TList T) ->
    typecheck env (ECons hd tl) (TList T)

  (* ENil *)
  | TC_Nil: forall env T,
    typecheck env (ENil T) (TList T)

  (* EBinop *)
  | TC_Binop_nnn: forall env op e1 e2,
    op = OpPlus \/
    op = OpMinus ->
    typecheck env e1 TNum ->
    typecheck env e2 TNum ->
    typecheck env (EBinop op e1 e2) TNum

  | TC_Binop_nnb: forall env op e1 e2,
    op = OpEq \/
    op = OpNeq ->
    typecheck env e1 TNum ->
    typecheck env e2 TNum ->
    typecheck env (EBinop op e1 e2) TBool

  | TC_Binop_bbb: forall env op e1 e2,
    op = OpAnd \/
    op = OpOr ->
    typecheck env e1 TBool ->
    typecheck env e2 TBool ->
    typecheck env (EBinop op e1 e2) TBool.