(* Source language (currently missing: T ::=  T1 /\ T2 | { z => T^z }):

  DSubSup (D<:>)
  T ::= Top | Bot | t.Type | { Type: S..U } | (z: T) -> T^z
  t ::= x | { Type = T } | lambda x:T.t | t t *)
Require Export Arith.EqNat.
Require Export Arith.Le.
Require Import Coq.Program.Equality.
Require Import Omega.
Require Import Coq.Lists.List.
Import ListNotations.

(* ### Syntax ### *)

Definition id := nat.

(* term variables occurring in types, both languages share the same variables definition *)
Inductive var : Type :=
| varF : id -> var (* free, in concrete environment *)
| varB : id -> var (* locally-bound variable *)
.

(* An environment is a list of values, indexed by decrementing ids. *)

Fixpoint indexr {X : Type} (n : id) (l : list X) : option X :=
  match l with
    | [] => None
    | a :: l' =>
      if (beq_nat n (length l')) then Some a else indexr n l'
  end.

Module D.

Inductive ty : Type :=
| TTop : ty
| TBot : ty
(* Type var X *)
| TVarF : id -> ty (* free type variable, in concrete environment *)
(* (z: T) -> T^z *)
| TAll : ty -> ty -> ty
(* We generalize x.Type to tm.type for arbitrary terms tm.  *)
| TSel : tm -> ty
(* { Type: S..U } *)
| TMem : ty(*S*) -> ty(*U*) -> ty
| TBind  : ty -> ty (* Recursive binder: { z => T^z },
                         where z is locally bound in T *)
| TAnd : ty -> ty -> ty (* Intersection Type: T1 /\ T2 *)

with tm : Type :=
(* x -- free variable, matching concrete environment *)
| tvar : var -> tm
(* { Type = T } *)
| ttyp : ty -> tm
(* lambda x:T.t *)
| tabs : ty -> tm -> tm
(* t t *)
| tapp : tm -> tm -> tm
(* unpack(e) { x => ... } *)
| tunpack : tm -> tm -> tm
.

Inductive vl : Type :=
(* a closure for a lambda abstraction *)
| vabs : list vl (*H*) -> ty -> tm -> vl
(* a closure for a first-class type *)
| vty : list vl (*H*) -> ty -> vl
.

Definition tenv := list ty. (* Gamma environment: static *)
Definition venv := list vl. (* H environment: run-time *)

(* ### Representation of Bindings ### *)

Inductive closed: nat(*B*) -> nat(*F*) -> ty -> Prop :=
| cl_top: forall i j,
    closed i j TTop
| cl_bot: forall i j,
    closed i j TBot
| cl_all: forall i j T1 T2,
    closed i j T1 ->
    closed (S i) j T2 ->
    closed i j (TAll T1 T2)
(* Now we have mutually recursive definitions for closedness on types and terms! *)
| cl_sel_tm: forall i j t,
    closed_tm i j t ->
    closed i j (TSel t)
| cl_mem: forall i j T1 T2,
    closed i j T1 ->
    closed i j T2 ->
    closed i j (TMem T1 T2)
| cl_bind: forall i j T,
    closed (S i) j T ->
    closed i j (TBind T)
| cl_and: forall i j T1 T2,
    closed i j T1 ->
    closed i j T2 ->
    closed i j (TAnd T1 T2)

with closed_tm: nat(*B*) -> nat(*F*) -> tm -> Prop :=
| cl_tvarb: forall i j x,
    i > x ->
    closed_tm i j (tvar (varB x))
| cl_tvarf: forall i j x,
    j > x ->
    closed_tm i j (tvar (varF x))
| cl_ttyp:  forall i j ty,
    closed i j ty ->
    closed_tm i j (ttyp ty)
| cl_tabs:  forall i j ty tm,
    closed i j ty ->
    closed_tm (S i) j tm ->
    closed_tm i j (tabs ty tm)
| cl_tapp:  forall i j tm1 tm2,
    closed_tm i j tm1 ->
    closed_tm i j tm2 ->
    closed_tm i j (tapp tm1 tm2)
| cl_tunpack: forall i j tm1 tm2,
    closed_tm i j tm1 ->
    closed_tm (S i) j tm2 ->
    closed_tm i j (tunpack tm1 tm2)
.

(* open define a locally-nameless encoding wrt to TVarB type variables. *)
(* substitute term u for all occurrences of (varB k) *)
Fixpoint open_rec (k: nat) (u: tm) (T: ty) { struct T }: ty :=
  match T with
    | TTop        => TTop
    | TBot        => TBot
    | TAll T1 T2  => TAll (open_rec k u T1) (open_rec (S k) u T2)
    | TSel tm => TSel (open_rec_tm k u tm)
    | TMem T1 T2  => TMem (open_rec k u T1) (open_rec k u T2)
    | TBind T => TBind (open_rec (S k) u T)
    | TAnd T1 T2 => TAnd (open_rec k u T1) (open_rec k u T2)
  end

with open_rec_tm (k: nat) (u: tm) (t: tm) { struct t }: tm :=
       match t with
       | tvar (varF x) => tvar (varF x)
       | tvar (varB x) =>
         if beq_nat k x then u else (tvar (varB x))
       | ttyp ty => ttyp (open_rec k u ty)
       | tabs ty tm => tabs (open_rec k u ty) (open_rec_tm (S k) u tm)
       | tapp tm1 tm2 => tapp (open_rec_tm k u tm1) (open_rec_tm k u tm2)
       | tunpack tm1 tm2 => tunpack (open_rec_tm k u tm1) (open_rec_tm (S k) u tm2)
       end.

(* for backwards compatibility  *)
Definition open u T := open_rec 0 (tvar u) T.
Definition open_tm u t := open_rec_tm 0 (tvar u) t.

Definition open' u T := open_rec 0 u T.
Definition open_tm' u t := open_rec_tm 0 u t.

(* ### Type Formation & Assignment ### *)
Inductive ctx_wf: tenv -> Set :=
| wf_empty:
    ctx_wf []
| wf_cons: forall Gamma T,
    ty_wf Gamma T ->
    ctx_wf Gamma ->
    ctx_wf (T :: Gamma)

with ty_wf: tenv -> ty -> Set :=
| wf_top: forall Gamma,
    ty_wf Gamma TTop
| wf_bot: forall Gamma,
    ty_wf Gamma TBot
| wf_mem: forall Gamma T1 T2,
    ty_wf Gamma T1 ->
    ty_wf Gamma T2 ->
    ty_wf Gamma (TMem T1 T2)
| wf_all: forall Gamma T1 T2,
    ty_wf Gamma T1 ->
    ty_wf (T1::Gamma) (open (varF (length Gamma)) T2) ->
    ty_wf Gamma (TAll T1 T2)
| wf_sel: forall Gamma e T1 T2,
    ty_wf Gamma T1 -> (* redundant, but needed for induction(?) *)
    ty_wf Gamma T2 ->
    has_type Gamma e (TMem T1 T2) ->
    ty_wf Gamma (TSel e)

with has_type : tenv -> tm -> ty -> Set :=
| t_var: forall x Gamma T1,
    ctx_wf Gamma ->
    indexr x Gamma = Some T1 ->
    (* ty_wf Gamma T1 -> *)
    has_type Gamma (tvar (varF x)) T1

(*
(* pack a recursive type  *)
| t_var_pack : forall G1 x T1 T1',
           (* has_type G1 (tvar x) T1' -> *)
           indexr x G1 = Some (open (varF x) T1) ->
           T1' = (open (varF x) T1) ->
           closed 1 0 (length G1) T1 ->
           has_type G1 (tvar (varF x)) (TBind T1)
(* unpack a recursive type: unpack(x:{z=>T^z}) { x:T^x => ... }  *)
| t_unpack: forall Gamma x y T1 T1' T2,
           has_type Gamma x (TBind T1) ->
           T1' = (open (varF (length Gamma)) T1) ->
           has_type (T1'::Gamma) y T2 ->
           closed 0 0 (length Gamma) T2 ->
           has_type Gamma (tunpack x y) T2
 *)

(* type selection intro and elim forms *)
| t_seli: forall Gamma e a T1,
          has_type Gamma a T1 ->
          has_type Gamma e (TMem T1 TTop) ->
          has_type Gamma a (TSel e)

| t_sele: forall Gamma e a T1,
          has_type Gamma a (TSel e) ->
          has_type Gamma e (TMem TBot T1) ->
          has_type Gamma a T1

(* intersection typing *)
(*
| t_and : forall Gamma x T1 T2,
           has_type Gamma (tvar x) T1 ->
           has_type Gamma (tvar x) T2 ->
           has_type Gamma (tvar x) (TAnd T1 T2)
*)

| t_typ: forall Gamma T1,
           ty_wf Gamma T1 ->
           has_type Gamma (ttyp T1) (TMem T1 T1)

| t_app: forall Gamma f x T1 T2,
    has_type Gamma f (TAll T1 T2) ->
    has_type Gamma x T1 ->
    has_type Gamma (tapp f x) (open' x T2)

(*
| t_dapp:forall Gamma f x T1 T2 T,
           has_type Gamma f (TAll T1 T2) ->
           has_type Gamma (tvar (varF x)) T1 ->
           T = open (varF x) T2 ->
           closed 0 0 (length Gamma) T ->
           has_type Gamma (tapp f (tvar (varF x))) T
*)
| t_abs: forall Gamma y T1 T2,
           ty_wf Gamma T1 ->
           has_type (T1::Gamma) y (open (varF (length Gamma)) T2) ->
           has_type Gamma (tabs T1 y) (TAll T1 T2)
(*
| t_sub: forall Gamma e T1 T2,
           has_type Gamma e T1 ->
            stp Gamma [] T1 T2 ->
           has_type Gamma e T2
*)
.

Fixpoint teval(n: nat)(env: venv)(t: tm){struct n}: option (option vl) :=
  match n with
    | 0 => None
    | S n =>
      match t with
      | tvar (varF x) => Some (indexr x env)
      (* remove varH *)
        (* | tvar (varH x) => Some None *)
        | tvar (varB x) => Some None
        | ttyp T       => Some (Some (vty env T))
        | tabs T y     => Some (Some (vabs env T y))
        | tapp ef ex   =>
          match teval n env ex with
            | None => None
            | Some None => Some None
            | Some (Some vx) =>
              match teval n env ef with
                | None => None
                | Some None => Some None
                | Some (Some (vty _ _)) => Some None
                | Some (Some (vabs env2 _ ey)) =>
                  teval n (vx::env2) ey
              end
          end
        | tunpack ex ey =>
          match teval n env ex with
            | None => None
            | Some None => Some None
            | Some (Some vx) =>
              teval n (vx::env) ey
          end
      end
  end.

Definition tevaln env e v := exists nm, forall n, n > nm -> teval n env e = Some (Some v).

End D.

(* Target language (inspired by https://docs.racket-lang.org/pie/index.html):

 t ::= x | Unit | Type
     | (z: T) -> T^z  | lambda x:T.t | t t
     | Sigma z:T. T^z | (t, t)  | fst t | snd t *)

(* Declare Scope cc_scope. *)

Require Import FunInd.
Require Import Recdef.

(* Calculus of Construction as a PTS *)
Module CC.

Inductive sort : Type :=
| Star : sort (* Universe of CC types *)
| Box :  sort (* Universe of CC kinds  *)
.

Definition sort_max (s s' : sort): sort :=
  match s, s' with
  | Box, _ | _, Box => Box
  | _, _ => Star
  end.

(* Pseudoterms T or typed terms  in [Geuvers '94] *)
Inductive tm : Type := (* TODO what about equality types? *)
(* Kind Constants *)
| CSort : sort -> tm

(* Types *)
(* | TTop : tm (* TODO really needed? *) *)
(* | TBot : tm (* TODO really needed? *) *)
(* Dependent and Non-dependet Function Types *)
| TAll : tm -> tm -> tm
(* TODO: Add weak sigma type back afterwards *)
(* | TSig : tm -> tm -> tm *)

(* Terms *)
(* variables *)
| tvar : var -> tm
(* λ-terms*)
| tabs : tm -> tm -> tm
(* application *)
| tapp : tm -> tm -> tm
(* | tsig : tm -> tm -> tm *)
(* | tfst : tm -> tm *)
(* | tsnd : tm -> tm *)
.

Inductive vl : Type :=
(* Simple types *)
| vty : list vl (*H*) -> tm -> vl
(* a closure for a lambda abstraction *)
| vabs : list vl (*H*) -> tm -> tm -> vl
(* Weak sigma type*)
(* | vsig : vl -> vl -> vl *)
.

Definition tenv := list tm.
Definition venv := list vl.

Module Notations.

(* \square *)
Notation "◻" := (CSort Box) : cc_scope.
(* \star *)
Notation "⋆" := (CSort Star) : cc_scope.

End Notations.

Import Notations.
Open Scope cc_scope.

Fixpoint open_rec (k: nat) (u: tm) (T: tm) { struct T }: tm :=
  match T with
  | ⋆           => ⋆
  | ◻           => ◻
  | TTop        => TTop
  | TBot        => TBot
  | TAll T1 T2  => TAll (open_rec k u T1) (open_rec (S k) u T2)
  (* | TSig T1 T2  => TSig (open_rec k u T1) (open_rec (S k) u T2) *)
  | tvar (varF x) => tvar (varF x)
  | tvar (varB x) =>
    if beq_nat k x then u else (tvar (varB x))
  | tabs ty tm => tabs (open_rec k u ty) (open_rec (S k) u tm)
  | tapp tm1 tm2 => tapp (open_rec k u tm1) (open_rec k u tm2)
  (* | tsig tm1 tm2 => tsig (open_rec k u tm1) (open_rec (S k) u tm2) *)
  (* | tfst tm => tfst (open_rec k u tm) *)
  (* | tsnd tm => tsnd (open_rec k u tm) *)
  end.

Definition open u T := open_rec 0 (tvar u) T.
Definition open' t T := open_rec 0 t T.

Fixpoint subst (x: nat) (u: tm) (t: tm) : tm :=
  match t with
  | CSort s => CSort s
  | TTop => TTop
  | TBot => TBot
  | TAll t1 t2 => TAll (subst x u t1) (subst x u t2)
  (* | TSig t1 t2 => TSig (subst x u t1) (subst x u t2) *)
  | tvar (varF y) =>
    if beq_nat x y then u else (tvar (varF y))
  | tvar (varB y) => tvar (varB y)
  | tabs t1 t2 => tabs (subst x u t1) (subst x u t2)
  | tapp t1 t2 => tapp (subst x u t1) (subst x u t2)
  (* | tsig t1 t2 => tsig (subst x u t1) (subst x u t2) *)
  (* | tfst t => tfst (subst x u t) *)
  (* | tsnd t => tsnd (subst x u t) *)
  end.

(* TODO: state and prove that (T^e) = (T^x){e/x} *)

Inductive closed: nat(*B*) -> nat(*F*) -> tm -> Prop :=
| cl_sort: forall i j U,
    closed i j (CSort U)
| cl_top: forall i j,
    closed i j TTop
| cl_bot: forall i j,
    closed i j TBot
| cl_all: forall i j T1 T2,
    closed i j T1 ->
    closed (S i) j T2 ->
    closed i j (TAll T1 T2)
(* | cl_sig: forall i j T1 T2, *)
(*     closed i j T1 -> *)
(*     closed (S i) j T2 -> *)
(*     closed i j (TSig T1 T2) *)
| cl_tvarb: forall i j x,
    i > x ->
    closed i j (tvar (varB x))
| cl_tvarf: forall i j x,
    j > x ->
    closed i j (tvar (varF x))
| cl_tabs:  forall i j ty tm,
    closed i j ty ->
    closed (S i) j tm ->
    closed i j (tabs ty tm)
| cl_tapp:  forall i j tm1 tm2,
    closed i j tm1 ->
    closed i j tm2 ->
    closed i j (tapp tm1 tm2)
(* | cl_tsig:  forall i j tm1 tm2, *)
(*     closed i j tm1 -> *)
(*     closed i j tm2 -> *)
(*     closed i j (tsig tm1 tm2) *)
(* | cl_tfst:  forall i j tm, *)
(*     closed i j tm -> *)
(*     closed i j (tfst tm) *)
(* | cl_tsnd:  forall i j tm, *)
(*     closed i j tm -> *)
(*     closed i j (tsnd tm) *)
.

Inductive ctx_wf: tenv -> Type :=
(* CNil *)
| wf_empty:
    ctx_wf []
(* CCons *)
| wf_sort: forall Gamma T s,
    (* also T is not in Γ *)
    has_type Gamma T (CSort s) ->
    ctx_wf Gamma ->
    ctx_wf (T :: Gamma)
with has_type : tenv -> tm -> tm -> Type :=
(* TSort; ⋆ : ◻ *)
| t_box: forall Gamma,
    has_type Gamma ⋆ ◻
(* TVar; x : T : s *)
| t_var: forall x Gamma T s,
    ctx_wf Gamma ->
    indexr x Gamma = Some T ->
    has_type Gamma T (CSort s) -> (* redundant, but makes kind_set definition easier *)
    has_type Gamma (tvar (varF x)) T

(* TPi; (x: T1) -> T2 : s *)
| t_allt: forall Gamma T1 T2 s s',
    has_type Gamma T1 (CSort s) ->
    has_type (T1 :: Gamma) (open (varF (length Gamma)) T2) (CSort s') ->
    has_type Gamma (TAll T1 T2) (CSort s')
(* TODO: Shouldn't the above be: *)
| t_allt2: forall Gamma T1 T2 s1 s2 s3,
    has_type Gamma T1 (CSort s1) ->
    has_type (T1 :: Gamma) (open (varF (length Gamma)) T2) (CSort s2) ->
    has_type Gamma (TAll T1 T2) (CSort s3)

(* Enable consistent strong Sigma-types, (cf. Definition 5.1 in [Geuvers '94]),
   forbidding (◻, ⋆, ⋆), (⋆, ◻, ⋆), (◻, ◻, ⋆), (⋆, ⋆, ◻) in the formation rule.*)
(* | t_sigt: forall Gamma T1 T2 s1 s2 s3, *)
(*     s3 = sort_max s1 s2 -> *)
(*     has_type Gamma T1 (CSort s1) -> *)
(*     has_type (T1 :: Gamma) (open (varF (length Gamma)) T2) (CSort s2) -> *)
(*     has_type Gamma (TSig T1 T2) (CSort s3) *)

(* | t_topt: forall Gamma, *)
(*     has_type Gamma TTop ⋆ *)

(* | t_bott: forall Gamma, *)
(*     has_type Gamma TBot ⋆ *)

(* TLambda; λx:A.b : (x:A) -> B *)
| t_abs: forall Gamma t T1 T2 s s',
    has_type Gamma T1 (CSort s) -> (* this premise may be redundant *)
    has_type Gamma (TAll T1 T2) (CSort s') ->
    has_type (T1 :: Gamma) t (open (varF (length Gamma)) T2) ->
    has_type Gamma (tabs T1 t) (TAll T1 T2)
(* TApp; f e : [e/x]B *)
| t_app: forall Gamma f e T1 T2 T,
    has_type Gamma f (TAll T1 T2) ->
    has_type Gamma e T1 ->
    T = (open' e T2) ->
    has_type Gamma (tapp f e) T

(* | t_sig: forall Gamma e1 e2 T1 T2, *)
(*     has_type Gamma e1 T1 -> *)
(*     has_type Gamma e2 (open' e1 T2) -> *)
(*     has_type Gamma (tsig e1 e2) (TSig T1 T2) *)

(* | t_fst: forall Gamma e T1 T2, *)
(*     has_type Gamma e (TSig T1 T2) -> *)
(*     has_type Gamma (tfst e) T1 *)

(* | t_snd: forall Gamma e T1 T2 T, *)
(*     has_type Gamma e (TSig T1 T2) -> *)
(*     T = (open' (tfst e) T2) -> *)
(*     has_type Gamma (tsnd e) T *)

(* TODO equality/tconv? *)
.

Fixpoint teval(n: nat)(env: venv)(t: tm){struct n}: option (option vl) :=
  match n with
  | 0 => None
  | S n =>
    match t with
    | tvar (varF x) => Some (indexr x env)
    | tvar (varB x) => Some None
    | tabs T y     =>  Some (Some (vabs env T y))
    | tapp ef ex   =>
      match teval n env ex with
      | None => None
      | Some None => Some None
      | Some (Some vx) =>
        match teval n env ef with
        | Some None => Some None
        | Some (Some (vabs env2 _ ey)) => teval n (vx::env2) ey
        | _ => None
        end
      end
    (* | tsig t1 t2 => *)
    (*   match teval n env t1 with *)
    (*   | None => None *)
    (*   | Some None => Some None *)
    (*   | Some (Some v1) => *)
    (*     match teval n env t2 with *)
    (*     | None => None *)
    (*     | Some None => Some None *)
    (*     | Some (Some v2) => Some (Some (vsig v1 v2)) *)
    (*     end *)
    (*   end *)
    | _ => None
    end
  end.

Definition tevaln env e v := exists nm, forall n, n > nm -> teval n env e = Some (Some v).

Fixpoint tsize_flat(T: tm) :=
  match T with
  (* | TTop => 1 *)
  (* | TBot => 1 *)
  | TAll T1 T2 => S (tsize_flat T1 + tsize_flat T2)
  (* | TSig T1 T2 => S (tsize_flat T1 + tsize_flat T2) *)
  | _ => 0
  end.
Lemma open_preserves_size: forall T x j,
    tsize_flat T = tsize_flat (open_rec j (tvar (varF x)) T).
Proof.
  intros T. induction T; intros; simpl; eauto. simpl.
  - destruct s; auto.
  - destruct v; eauto.  simpl; destruct (beq_nat j i); eauto.
Qed.

(* *********************** *)
(* Semantic Interpretation *)
(* *********************** *)

(* The definition of value sets *)
Definition vset := vl -> Prop.

(*
  This computes the *types* of the sets that kinds represent (cf. V(_) interp in Geuvers '94),
  i.e., this is a dependent type indexed by the kinds in the system . Since we lump
  everything into one syntactic category, we define it inductively over typing derivations yielding ◻. *)
Fixpoint kind_set Gamma K (proof: has_type Gamma K ◻): Type :=
  match proof with
  | t_box _ => (* ⋆ *)
    vset
  | t_var x Gamma T Box _ _ T_is_kind =>
    (kind_set Gamma T T_is_kind)
  | t_allt Gamma T1 T2 Box Box T1_is_kind T2_is_kind =>  (* Πα:T1.T2, T1:◻ *)
    let V1 := (kind_set Gamma T1 T1_is_kind) in
    let V2 := (kind_set (T1 :: Gamma) (open (varF (length Gamma)) T2) T2_is_kind) in
    V1 -> V2
  | t_allt Gamma T1 T2 Star Box p1 p2 => (* Πα:T1.T2, T1:⋆ *)
    (kind_set (T1 :: Gamma) (open (varF (length Gamma)) T2) p2)
  | t_sigt Gamma T1 T2 Box Box Box _ T1_is_kind T2_is_kind => (* Σα:T1.T2, T1:◻, T2:◻  *)
    let V1 := (kind_set Gamma T1 T1_is_kind) in
    let V2 := (kind_set (T1 :: Gamma) (open (varF (length Gamma)) T2) T2_is_kind) in
    V1 -> V2 -> Prop (* V1 × V2 *)
  | t_sigt Gamma T1 T2 Star Box Box _ _ T2_is_kind => (* Σα:T1.T2, T1:⋆, T2:◻ *)
    (kind_set (T1 :: Gamma) (open (varF (length Gamma)) T2) T2_is_kind)
  | t_sigt Gamma T1 T2 Box Star Box _ T1_is_kind _ => (* Σα:T1.T2, T1:◻, T2:⋆ *)
    (kind_set Gamma T1 T1_is_kind)
  | _ => False
  end.

(* Design idea:
   terms and types are separate GADTs indexed by their sort, classifying their universe.
   Might yield more concise and readable definitions (such as kind_set).
Inductive ty: sort -> Type :=
| TAll : forall s s',
    ty s -> ty s' -> ty s'
| TSig : forall s s',
    ty s -> ty s' -> ty s'
| TTm: forall s,
    tm s -> ty s
with tm: sort -> Type :=
| tvar : forall s,
    var -> tm s (* TODO: might make sense to index variables with their sort *)
| tabs : forall s s',
    ty s -> tm s' -> tm s'
| tapp : forall s s',
    tm s -> tm s' -> tm s (* TODO: correct? *)
| tsig : forall s s',
    ty s -> tm s' -> tm s'
| tfst : forall s, tm s -> tm s
| tsnd : forall s, tm s -> tm s
| tty: forall s, ty s -> tm s
.

Potentially interesting, since we could define
a sort-indexed evaluator, that describes evaluation/normalization
at runtime and at type level.
*)

Definition renv := list vset.

(* Also, need to take kinds into consideration. With kind_set?  *)
(* TODO adapt the definitions in Geuvers '94, starting at p. 20 to sets of values *)
Function val_type (ρ: renv) (T: tm) (v: vl) (D: vset) {measure tsize_flat T} : Prop :=
  match T, v with
  (* ρ(⊤) = {v} for all value *)
  | TTop, _ => True
  (* [[ T1->T2 ]] *)
  | TAll T1 T2, vabs env1 T0 y =>
    closed 0 (length env) T1 /\ closed 1 (length env) T2 /\
    forall vx D1, val_type ρ T1 vx D1 ->
          exists D2 v, teval (vx::env1) y v /\ val_type (D1::ρ) (open (varF (length ρ)) T2) v D2
  (* [[ T ]] *)
  | TVarF (tvar (varF x)), v =>
    match indexr x env with
    | Some => D v
    | _ => False
  (* TODO: add more interpretations *)
  | _, _ => False
  end.

(* TODO val_type_unfold *)

Definition R_env gamma rho Gamma :=
  length gamma = length Gamma /\
  length rho = length Gamma /\
  forall x TX, indexr x Gamma = Some TX ->
          (exists (vsx:vset) vx,
              indexr x gamma = Some vx /\
              indexr x rho = Some vsx /\
              val_type rho TX vx).

Definition strong_normalization := forall e Gamma T,
      has_type Gamma e T ->
      has_type Gamma T ⋆ ->
      forall gamma rho, R_env gamma rho Gamma ->
              exists v, tevaln gamma e v /\ val_type rho .

(* TODO: prove strong normalization *)
Theorem full_total_saftty : strong_normalization.
Proof.

End CC.


Require Export Program.Basics. Open Scope program_scope.
From Paco Require Import paco0 pacotac.
Set Implicit Arguments.

Section GeneralizedPaco0.

Local Notation rel := (rel0).

Section RClo.

Inductive rclo0 (clo: rel->rel) (r: rel): rel :=
| rclo0_base

    (IN: r):
    @rclo0 clo r
| rclo0_clo'
    r'
    (LE: r' <0= rclo0 clo r)
    (IN: clo r'):
    @rclo0 clo r
.

Lemma rclo0_mon_gen clo clo' r r'
      (IN: @rclo0 clo r)
      (LEclo: clo <1= clo')
      (LEr: r <0= r') :
  @rclo0 clo' r'.
Proof.
  induction IN; intros.
  - econstructor 1. apply LEr, IN.
  - econstructor 2; [intros; eapply H, PR|apply LEclo, IN].
Qed.

Lemma rclo0_mon clo:
  monotone0 (rclo0 clo).
Proof.
  repeat intro. eapply rclo0_mon_gen; [apply IN|intros; apply PR|apply LE].
Qed.

Lemma rclo0_clo clo r:
  clo (rclo0 clo r) <0= rclo0 clo r.
Proof.
  intros. econstructor 2; [|apply PR].
  intros. apply PR0.
Qed.

Lemma rclo0_rclo clo r:
  rclo0 clo (rclo0 clo r) <0= rclo0 clo r.
Proof.
  intros. induction PR.
  - eapply IN.
  - econstructor 2; [eapply H | eapply IN].
Qed.

Lemma rclo0_compose clo r:
  rclo0 (rclo0 clo) r <0= rclo0 clo r.
Proof.
  intros. induction PR.
  - apply rclo0_base, IN.
  - apply rclo0_rclo.
    eapply rclo0_mon; [apply IN|apply H].
Qed.

End RClo.

Section Main.

Variable gf: rel -> rel.
Hypothesis gf_mon: monotone0 gf.

Variant gpaco0 clo r rg : Prop :=
| gpaco0_intro (IN: @rclo0 clo (paco0 (compose gf (rclo0 clo)) (rg \0/ r) \0/ r))
.

Definition gupaco0 clo r := gpaco0 clo r r.

Lemma gpaco0_def_mon clo : monotone0 (compose gf (rclo0 clo)).
Proof.
  eapply monotone0_compose. apply gf_mon. apply rclo0_mon.
Qed.

Hint Resolve gpaco0_def_mon : paco.

Lemma gpaco0_mon clo r r' rg rg'
      (IN: @gpaco0 clo r rg)
      (LEr: r <0= r')
      (LErg: rg <0= rg'):
  @gpaco0 clo r' rg'.
Proof.
  destruct IN. econstructor.
  eapply rclo0_mon. apply IN.
  intros. destruct PR; [|right; apply LEr, H].
  left. eapply paco0_mon. apply H.
  intros. destruct PR.
  - left. apply LErg, H0.
  - right. apply LEr, H0.
Qed.

Lemma gupaco0_mon clo r r'
      (IN: @gupaco0 clo r)
      (LEr: r <0= r'):
  @gupaco0 clo r'.
Proof.
  eapply gpaco0_mon. apply IN. apply LEr. apply LEr.
Qed.

Lemma gpaco0_base clo r rg: r <0= gpaco0 clo r rg.
Proof.
  econstructor. apply rclo0_base. right. apply PR.
Qed.

Lemma gpaco0_gen_guard  clo r rg:
  gpaco0 clo r (rg \0/ r) <0= gpaco0 clo r rg.
Proof.
  intros. destruct PR. econstructor.
  eapply rclo0_mon. apply IN. intros.
  destruct PR; [|right; apply H].
  left. eapply paco0_mon_gen; intros. apply H. apply PR.
  destruct PR. apply H0. right. apply H0.
Qed.

Lemma gpaco0_rclo clo r rg:
  rclo0 clo r <0= gpaco0 clo r rg.
Proof.
  intros. econstructor.
  eapply rclo0_mon. apply PR.
  intros. right. apply PR0.
Qed.

Lemma gpaco0_clo clo r rg:
  clo r <0= gpaco0 clo r rg.
Proof.
  intros. apply gpaco0_rclo. eapply rclo0_clo', PR.
  apply rclo0_base.
Qed.

Lemma gpaco0_gen_rclo clo r rg:
  gpaco0 (rclo0 clo) r rg <0= gpaco0 clo r rg.
Proof.
  intros. destruct PR. econstructor.
  apply rclo0_compose.
  eapply rclo0_mon. apply IN. intros.
  destruct PR; [|right; apply H].
  left. eapply paco0_mon_gen; intros; [apply H| |apply PR].
  eapply gf_mon, rclo0_compose. apply PR.
Qed.

Lemma gpaco0_step_gen clo r rg:
  gf (gpaco0 clo (rg \0/ r) (rg \0/ r)) <0= gpaco0 clo r rg.
Proof.
  intros. econstructor. apply rclo0_base. left.
  pstep. eapply gf_mon. apply PR.
  intros. destruct PR0. eapply rclo0_mon. apply IN.
  intros. destruct PR0.
  - left. eapply paco0_mon. apply H. intros. destruct PR0; apply H0.
  - right. apply H.
Qed.

Lemma gpaco0_step clo r rg:
  gf (gpaco0 clo rg rg) <0= gpaco0 clo r rg.
Proof.
  intros. apply gpaco0_step_gen.
  eapply gf_mon. apply PR. intros.
  eapply gpaco0_mon. apply PR0. left; apply PR1. left; apply PR1.
Qed.

Lemma gpaco0_final clo r rg:
  (r \0/ paco0 gf rg) <0= gpaco0 clo r rg.
Proof.
  intros. destruct PR. apply gpaco0_base, H.
  econstructor. apply rclo0_base.
  left. eapply paco0_mon_gen. apply H.
  - intros. eapply gf_mon. apply PR.
    intros. apply rclo0_base. apply PR0.
  - intros. left. apply PR.
Qed.

Lemma gpaco0_unfold clo r rg:
  gpaco0 clo r rg <0= rclo0 clo (gf (gupaco0 clo (rg \0/ r)) \0/ r).
Proof.
  intros. destruct PR.
  eapply rclo0_mon. apply IN.
  intros. destruct PR; cycle 1. right; apply H.
  left. _punfold H; [|apply gpaco0_def_mon].
  eapply gf_mon. apply H.
  intros. econstructor.
  eapply rclo0_mon. apply PR.
  intros. destruct PR0; cycle 1. right. apply H0.
  left. eapply paco0_mon. apply H0.
  intros. left. apply PR0.
Qed.

Lemma gpaco0_cofix clo r rg
      l (OBG: forall rr (INC: rg <0= rr) (CIH: l <0= rr), l <0= gpaco0 clo r rr):
  l <0= gpaco0 clo r rg.
Proof.
  assert (IN: l <0= gpaco0 clo r (rg \0/ l)).
  { intros. apply OBG; [left; apply PR0 | right; apply PR0 | apply PR]. }
  clear OBG. intros. apply IN in PR.
  destruct PR. econstructor.
  eapply rclo0_mon. apply IN0.
  clear IN0.
  intros. destruct PR; [|right; apply H].
  left. revert H.
  pcofix CIH. intros.
  _punfold H0; [..|apply gpaco0_def_mon]. pstep.
  eapply gf_mon. apply H0. intros.
  apply rclo0_rclo. eapply rclo0_mon. apply PR.
  intros. destruct PR0.
  - apply rclo0_base. right. apply CIH. apply H.
  - destruct H; [destruct H|].
    + apply rclo0_base. right. apply CIH0. left. apply H.
    + apply IN in H. destruct H.
      eapply rclo0_mon. apply IN0.
      intros. destruct PR0.
      * right. apply CIH. apply H.
      * right. apply CIH0. right. apply H.
    + apply rclo0_base. right. apply CIH0. right. apply H.
Qed.

Lemma gpaco0_gupaco clo r rg:
  gupaco0 clo (gpaco0 clo r rg) <0= gpaco0 clo r rg.
Proof.
  eapply gpaco0_cofix.
  intros. destruct PR. econstructor.
  apply rclo0_rclo. eapply rclo0_mon. apply IN.
  intros. destruct PR.
  - apply rclo0_base. left.
    eapply paco0_mon. apply H.
    intros. left; apply CIH.
    econstructor. apply rclo0_base. right.
    destruct PR; apply H0.
  - destruct H. eapply rclo0_mon. apply IN0.
    intros. destruct PR; [| right; apply H].
    left. eapply paco0_mon. apply H.
    intros. destruct PR.
    + left. apply INC. apply H0.
    + right. apply H0.
Qed.

Lemma gpaco0_gpaco clo r rg:
  gpaco0 clo (gpaco0 clo r rg) (gupaco0 clo (rg \0/ r)) <0= gpaco0 clo r rg.
Proof.
  intros. apply gpaco0_unfold in PR.
  econstructor. apply rclo0_rclo. eapply rclo0_mon. apply PR. clear PR. intros.
  destruct PR; [|destruct H; apply IN].
  apply rclo0_base. left. pstep.
  eapply gf_mon. apply H. clear H. intros.
  cut (@gupaco0 clo (rg \0/ r)).
  { intros. destruct H. eapply rclo0_mon. apply IN. intros.
    destruct PR0; [|right; apply H].
    left. eapply paco0_mon. apply H. intros. destruct PR0; apply H0.
  }
  apply gpaco0_gupaco. eapply gupaco0_mon. apply PR. intros.
  destruct PR0; [apply H|].
  eapply gpaco0_mon; [apply H|right|left]; intros; apply PR0.
Qed.

Lemma gpaco0_uclo uclo clo r rg
      (LEclo: uclo <1= gupaco0 clo) :
  uclo (gpaco0 clo r rg) <0= gpaco0 clo r rg.
Proof.
  intros. apply gpaco0_gupaco. apply LEclo, PR.
Qed.

Lemma gpaco0_weaken  clo r rg:
  gpaco0 (gupaco0 clo) r rg <0= gpaco0 clo r rg.
Proof.
  intros. apply gpaco0_unfold in PR.
  induction PR.
  - destruct IN; cycle 1. apply gpaco0_base, H.
    apply gpaco0_step_gen. eapply gf_mon. apply H.
    clear H.
    eapply gpaco0_cofix. intros.
    apply gpaco0_unfold in PR.
    induction PR.
    + destruct IN; cycle 1. apply gpaco0_base, H.
      apply gpaco0_step. eapply gf_mon. apply H.
      intros. apply gpaco0_base. apply CIH.
      eapply gupaco0_mon. apply PR.
      intros. destruct PR0; apply H0.
    + apply gpaco0_gupaco.
      eapply gupaco0_mon. apply IN. apply H.
  - apply gpaco0_gupaco.
    eapply gupaco0_mon. apply IN. apply H.
Qed.

End Main.

Hint Resolve gpaco0_def_mon : paco.

Section GeneralMonotonicity.

Variable gf: rel -> rel.

Lemma gpaco0_mon_gen (gf' clo clo': rel -> rel) r r' rg rg'
      (IN: @gpaco0 gf clo r rg)
      (gf_mon: monotone0 gf)
      (LEgf: gf <1= gf')
      (LEclo: clo <1= clo')
      (LEr: r <0= r')
      (LErg: rg <0= rg') :
  @gpaco0 gf' clo' r' rg'.
Proof.
  eapply gpaco0_mon; [|apply LEr|apply LErg].
  destruct IN. econstructor.
  eapply rclo0_mon_gen. apply IN. apply LEclo.
  intros. destruct PR; [| right; apply H].
  left. eapply paco0_mon_gen. apply H.
  - intros. eapply LEgf.
    eapply gf_mon. apply PR.
    intros. eapply rclo0_mon_gen. apply PR0. apply LEclo. intros; apply PR1.
  - intros. apply PR.
Qed.

Lemma gpaco0_mon_bot (gf' clo clo': rel -> rel) r' rg'
      (IN: @gpaco0 gf clo bot0 bot0)
      (gf_mon: monotone0 gf)
      (LEgf: gf <1= gf')
      (LEclo: clo <1= clo'):
  @gpaco0 gf' clo' r' rg'.
Proof.
  eapply gpaco0_mon_gen. apply IN. apply gf_mon. apply LEgf. apply LEclo. contradiction. contradiction.
Qed.

Lemma gupaco0_mon_gen (gf' clo clo': rel -> rel) r r'
      (IN: @gupaco0 gf clo r)
      (gf_mon: monotone0 gf)
      (LEgf: gf <1= gf')
      (LEclo: clo <1= clo')
      (LEr: r <0= r'):
  @gupaco0 gf' clo' r'.
Proof.
  eapply gpaco0_mon_gen. apply IN. apply gf_mon. apply LEgf. apply LEclo. apply LEr. apply LEr.
Qed.

End GeneralMonotonicity.

Section Compatibility.

Variable gf: rel -> rel.
Hypothesis gf_mon: monotone0 gf.

Structure compatible0 (clo: rel -> rel) : Prop :=
  compat0_intro {
      compat0_mon: monotone0 clo;
      compat0_compat : forall r,
          clo (gf r) <0= gf (clo r);
    }.

Structure wcompatible0 clo : Prop :=
  wcompat0_intro {
      wcompat0_mon: monotone0 clo;
      wcompat0_wcompat : forall r,
          clo (gf r) <0= gf (gupaco0 gf clo r);
    }.

Lemma rclo0_dist clo
      (MON: monotone0 clo)
      (DIST: forall r1 r2, clo (r1 \0/ r2) <0= (clo r1 \0/ clo r2)):
  forall r1 r2, rclo0 clo (r1 \0/ r2) <0= (rclo0 clo r1 \0/ rclo0 clo r2).
Proof.
  intros. induction PR.
  + destruct IN; [left|right]; apply rclo0_base, H.
  + assert (REL: clo (rclo0 clo r1 \0/ rclo0 clo r2)).
    { eapply MON. apply IN. apply H. }
    apply DIST in REL. destruct REL; [left|right]; apply rclo0_clo, H0.
Qed.

Lemma rclo0_compat clo
      (COM: compatible0 clo):
  compatible0 (rclo0 clo).
Proof.
  econstructor.
  - apply rclo0_mon.
  - intros. induction PR.
    + eapply gf_mon. apply IN.
      intros. eapply rclo0_base. apply PR.
    + eapply gf_mon.
      * eapply COM. eapply COM. apply IN. apply H.
      * intros. eapply rclo0_clo. apply PR.
Qed.

Lemma rclo0_wcompat clo
      (COM: wcompatible0 clo):
  wcompatible0 (rclo0 clo).
Proof.
  econstructor.
  - apply rclo0_mon.
  - intros. induction PR.
    + eapply gf_mon. apply IN.
      intros. apply gpaco0_base. apply PR.
    + eapply gf_mon.
      * eapply COM. eapply COM. apply IN. apply H.
      * intros. eapply gpaco0_gupaco. apply gf_mon.
        eapply gupaco0_mon_gen; intros; [apply PR|apply gf_mon|apply PR0| |apply PR0].
        eapply rclo0_clo'. apply rclo0_base. apply PR0.
Qed.

Lemma compat0_wcompat clo
      (CMP: compatible0 clo):
  wcompatible0 clo.
Proof.
  econstructor. apply CMP.
  intros. apply CMP in PR.
  eapply gf_mon. apply PR.
  intros. apply gpaco0_clo, PR0.
Qed.

Lemma wcompat0_compat clo
      (WCMP: wcompatible0 clo) :
  compatible0 (gupaco0 gf clo).
Proof.
  econstructor.
  { red; intros. eapply gpaco0_mon. apply IN. apply LE. apply LE. }

  intros. apply gpaco0_unfold in PR; [|apply gf_mon].
  induction PR.
  - destruct IN; cycle 1.
    + eapply gf_mon. apply H.
      intros. apply gpaco0_base, PR.
    + eapply gf_mon. apply H.
      intros. apply gpaco0_gupaco. apply gf_mon.
      eapply gupaco0_mon. apply PR.
      intros. apply gpaco0_step. apply gf_mon.
      eapply gf_mon. destruct PR0 as [X|X]; apply X.
      intros. apply gpaco0_base, PR1.
  - eapply gf_mon, gpaco0_gupaco, gf_mon.
    apply WCMP. eapply WCMP. apply IN.
    intros. apply H, PR.
Qed.

Lemma wcompat0_union clo1 clo2
      (WCMP1: wcompatible0 clo1)
      (WCMP2: wcompatible0 clo2):
  wcompatible0 (clo1 \1/ clo2).
Proof.
  econstructor.
  - apply monotone0_union. apply WCMP1. apply WCMP2.
  - intros. destruct PR.
    + apply WCMP1 in H. eapply gf_mon. apply H.
      intros. eapply gupaco0_mon_gen. apply PR. apply gf_mon.
      intros; apply PR0. left; apply PR0. intros; apply PR0.
    + apply WCMP2 in H. eapply gf_mon. apply H.
      intros. eapply gupaco0_mon_gen. apply PR. apply gf_mon.
      intros; apply PR0. right; apply PR0. intros; apply PR0.
Qed.

End Compatibility.

Section Soundness.

Variable gf: rel -> rel.
Hypothesis gf_mon: monotone0 gf.

Lemma gpaco0_compat_init clo
      (CMP: compatible0 gf clo):
  gpaco0 gf clo bot0 bot0 <0= paco0 gf bot0.
Proof.
  intros. destruct PR. revert IN.
  pcofix CIH. intros.
  pstep. eapply gf_mon; [| right; apply CIH, rclo0_rclo, PR].
  apply compat0_compat with (gf:=gf). apply rclo0_compat. apply gf_mon. apply CMP.
  eapply rclo0_mon. apply IN.
  intros. destruct PR; [|contradiction]. _punfold H; [..|apply gpaco0_def_mon, gf_mon].
  eapply gpaco0_def_mon. apply gf_mon. apply H.
  intros. destruct PR; [|destruct H0; contradiction]. left. apply H0.
Qed.

Lemma gpaco0_init clo
      (WCMP: wcompatible0 gf clo):
  gpaco0 gf clo bot0 bot0 <0= paco0 gf bot0.
Proof.
  intros. eapply gpaco0_compat_init.
  - apply wcompat0_compat, WCMP. apply gf_mon.
  - eapply gpaco0_mon_bot. apply PR. apply gf_mon. intros; apply PR0.
    intros. apply gpaco0_clo, PR0.
Qed.

Lemma gpaco0_unfold_bot clo
      (WCMP: wcompatible0 gf clo):
  gpaco0 gf clo bot0 bot0 <0= gf (gpaco0 gf clo bot0 bot0).
Proof.
  intros. apply gpaco0_init in PR; [|apply WCMP].
  _punfold PR; [..|apply gf_mon].
  eapply gf_mon. apply PR.
  intros. destruct PR0; [|contradiction]. apply gpaco0_final. apply gf_mon. right. apply H.
Qed.

End Soundness.

Section Distributivity.

Variable gf: rel -> rel.
Hypothesis gf_mon: monotone0 gf.

Lemma gpaco0_dist clo r rg
      (CMP: wcompatible0 gf clo)
      (DIST: forall r1 r2, clo (r1 \0/ r2) <0= (clo r1 \0/ clo r2)):
  gpaco0 gf clo r rg <0= (paco0 gf (rclo0 clo (rg \0/ r)) \0/ rclo0 clo r).
Proof.
  intros. apply gpaco0_unfold in PR; [|apply gf_mon].
  apply rclo0_dist in PR; [|apply CMP|apply DIST].
  destruct PR; [|right; apply H].
  left. revert H.
  pcofix CIH; intros.
  apply rclo0_wcompat in H0; [|apply gf_mon|apply CMP].
  pstep. eapply gf_mon. apply H0. intros.
  apply gpaco0_unfold in PR; [|apply gf_mon].
  apply rclo0_compose in PR.
  apply rclo0_dist in PR; [|apply CMP|apply DIST].
  destruct PR.
  - right. apply CIH.
    eapply rclo0_mon. apply H. intros.
    eapply gf_mon. apply PR. intros.
    apply gpaco0_gupaco. apply gf_mon.
    apply gpaco0_gen_rclo. apply gf_mon.
    eapply gupaco0_mon. apply PR0. intros.
    destruct PR1; apply H1.
  - assert (REL: @rclo0 clo (rclo0 clo (gf (gupaco0 gf clo ((rg \0/ r) \0/ (rg \0/ r))) \0/ (rg \0/ r)))).
    { eapply rclo0_mon. apply H. intros. apply gpaco0_unfold in PR. apply PR. apply gf_mon. }
    apply rclo0_rclo in REL.
    apply rclo0_dist in REL; [|apply CMP|apply DIST].
    right. destruct REL; cycle 1.
    + apply CIH0, H1.
    + apply CIH.
      eapply rclo0_mon. apply H1. intros.
      eapply gf_mon. apply PR. intros.
      eapply gupaco0_mon. apply PR0. intros.
      destruct PR1; apply H2.
Qed.

Lemma gpaco0_dist_reverse clo r rg:
  (paco0 gf (rclo0 clo (rg \0/ r)) \0/ rclo0 clo r) <0= gpaco0 gf clo r rg.
Proof.
  intros. destruct PR; cycle 1.
  - eapply gpaco0_rclo. apply H.
  - econstructor. apply rclo0_base. left.
    revert H. pcofix CIH; intros.
    _punfold H0; [|apply gf_mon]. pstep.
    eapply gf_mon. apply H0. intros.
    destruct PR.
    + apply rclo0_base. right. apply CIH, H.
    + eapply rclo0_mon. apply H. intros.
      right. apply CIH0. apply PR.
Qed.

End Distributivity.

Section Companion.

Variable gf: rel -> rel.
Hypothesis gf_mon: monotone0 gf.

Inductive cpn0 (r: rel) : Prop :=
| cpn0_intro
    clo
    (COM: compatible0 gf clo)
    (CLO: clo r)
.

Lemma cpn0_mon: monotone0 cpn0.
Proof.
  red. intros.
  destruct IN. exists clo.
  - apply COM.
  - eapply compat0_mon; [apply COM|apply CLO|apply LE].
Qed.

Lemma cpn0_greatest: forall clo (COM: compatible0 gf clo), clo <1= cpn0.
Proof. intros. econstructor;[apply COM|apply PR]. Qed.

Lemma cpn0_compat: compatible0 gf cpn0.
Proof.
  econstructor; [apply cpn0_mon|intros].
  destruct PR; eapply gf_mon with (r:=clo r).
  - eapply (compat0_compat COM); apply CLO.
  - intros. econstructor; [apply COM|apply PR].
Qed.

Lemma cpn0_wcompat: wcompatible0 gf cpn0.
Proof. apply compat0_wcompat, cpn0_compat. apply gf_mon. Qed.

Lemma cpn0_gupaco:
  gupaco0 gf cpn0 <1= cpn0.
Proof.
  intros. eapply cpn0_greatest, PR. apply wcompat0_compat. apply gf_mon. apply cpn0_wcompat.
Qed.

Lemma cpn0_cpn r:
  cpn0 (cpn0 r) <0= cpn0 r.
Proof.
  intros. apply cpn0_gupaco, gpaco0_gupaco, gpaco0_clo. apply gf_mon.
  eapply cpn0_mon, gpaco0_clo. apply PR.
Qed.

Lemma cpn0_base r:
  r <0= cpn0 r.
Proof.
  intros. apply cpn0_gupaco. apply gpaco0_base, PR.
Qed.

Lemma cpn0_clo
      r clo (LE: clo <1= cpn0):
  clo (cpn0 r) <0= cpn0 r.
Proof.
  intros. apply cpn0_cpn, LE, PR.
Qed.

Lemma cpn0_step r:
  gf (cpn0 r) <0= cpn0 r.
Proof.
  intros. apply cpn0_gupaco. apply gpaco0_step. apply gf_mon.
  eapply gf_mon, gpaco0_clo. apply PR.
Qed.

Lemma cpn0_uclo uclo
      (MON: monotone0 uclo)
      (WCOM: forall r, uclo (gf r) <0= gf (gupaco0 gf (uclo \1/ cpn0) r)):
  uclo <1= gupaco0 gf cpn0.
Proof.
  intros. apply gpaco0_clo.
  exists (gupaco0 gf (uclo \1/ cpn0)).
  - apply wcompat0_compat. apply gf_mon.
    econstructor.
    + apply monotone0_union. apply MON. apply cpn0_mon.
    + intros. destruct PR0.
      * apply WCOM, H.
      * apply compat0_compat with (gf:=gf) in H; [| apply cpn0_compat].
        eapply gf_mon. apply H. intros.
        apply gpaco0_clo. right. apply PR0.
  - apply gpaco0_clo. left. apply PR.
Qed.

End Companion.

End GeneralizedPaco0.

Hint Resolve gpaco0_def_mon : paco.
Hint Unfold gupaco0 : paco.
Hint Resolve gpaco0_base : paco.
Hint Resolve gpaco0_step : paco.
Hint Resolve gpaco0_final : paco.
Hint Resolve rclo0_base : paco.
Hint Constructors gpaco0 : paco.


Require Import Lang.Syntax.
Require Import Lang.Bindings.
Require Import Lang.Entropy.
Require Import Coq.Reals.Reals.
Require Import Lebesgue.
Require Import Coq.Reals.ROrderedType.
Require Import Lra.
Require Import FunctionalExtensionality.

Set Implicit Arguments.

(** Semantics of built-in operations *)
Definition binop_interp (op : binop) (v1 v2 : val0) : option val0 :=
match v1, v2 with
| val_real r1, val_real r2 =>
  Some (
    match op with
    | binop_plus => val_real (r1 + r2)
    | binop_mult => val_real (r1 * r2)
    | binop_lt => val_bool (if Rlt_dec r1 r2 then true else false)
    | binop_le => val_bool (if Rle_dec r1 r2 then true else false)
    | binop_eq_real => val_bool (if Req_dec r1 r2 then true else false)
    end
  )
| _, _ => None
end.

Section section_sss.
Context (eval : entropy → exp0 → option (entropy * exp0 * R⁺)).

(** The unnormalized density of not getting stuck within [N] steps *)
Definition ρNS_aux (t : entropy) (e : exp0) : R⁺ :=
match eval t e with
| Some (_, _, w) => w
| None => 0
end.

(** The measure induced by [ρNS_aux] *)
Definition μNS_aux (e : exp0) : R⁺ :=
∫ (λ t, ρNS_aux t e) μentropy.

Reserved Notation "⟨ t | e ⟩ ⤳ ⟨ t' | e' ⟩ • w"
  (at level 70, t, e, t', e', w at level 65).
Inductive sss : entropy → exp0 → entropy → exp0 → R⁺ → Prop :=
(* reduction rules *)
| sss_app :
  ∀ t e (v : val0),
  ⟨t|exp_app (val_fun e) v⟩ ⤳ ⟨t|V_subst_exp v e⟩ • 1
| sss_fix :
  ∀ t e,
  ⟨t|exp_app (val_fix e) val_unit⟩ ⤳ ⟨t|V_subst_exp (val_fix e) e⟩ • 1
| sss_let :
  ∀ t (v : val0) e,
  ⟨t|exp_let v e⟩ ⤳ ⟨t|V_subst_exp v e⟩ • 1
| sss_binop :
  ∀ t op (v1 v2 v : val0),
  binop_interp op v1 v2 = Some v →
  ⟨t|exp_binop op v1 v2⟩ ⤳ ⟨t|v⟩ • 1
| sss_proj :
  ∀ t (vL vR : val0) b,
  ⟨ t | exp_proj (val_pair vL vR) b ⟩ ⤳ ⟨t|if b then vL else vR⟩ • 1
| sss_then :
  ∀ t e1 e2,
  ⟨t|exp_if (val_bool true) e1 e2⟩ ⤳ ⟨t|e1⟩ • 1
| sss_else :
  ∀ t e1 e2,
  ⟨t|exp_if (val_bool false) e1 e2⟩ ⤳ ⟨t|e2⟩ • 1
| sss_sample_unif :
  ∀ t,
  let r := proj1_sig (πL t 0%nat) in
  ⟨t|exp_sample val_unif⟩ ⤳ ⟨(πR t)|val_real r⟩ • 1
| sss_sample_query :
  ∀ t e,
  0 < μNS_aux e →
  ⟨t|exp_sample (val_query e)⟩ ⤳ ⟨t|e⟩ • (/ μNS_aux e)
| sss_sample_query_exn :
  ∀ t e,
  0 = μNS_aux e →
  ⟨t|exp_sample (val_query e)⟩ ⤳ ⟨t|exp_exn⟩ • 1
| sss_score :
  ∀ t (r : R) (r_pos : (0 < r)%R),
  (r ≤ 1)%R →
  ⟨t|exp_score (val_real r)⟩ ⤳ ⟨t|val_unit⟩ • (finite r (Rlt_le _ _ r_pos))

(* structural rules *)
| sss_ktx_app1 :
  ∀ t e1 e2 t' e1' w,
  ⟨t|e1⟩ ⤳ ⟨t'|e1'⟩ • w →
  ⟨t|exp_app e1 e2⟩ ⤳ ⟨t'|exp_app e1' e2⟩ • w
| sss_ktx_app2 :
  ∀ t (v : val0) e2 t' e2' w,
  ⟨t|e2⟩ ⤳ ⟨t'|e2'⟩ • w →
  ⟨t|exp_app v e2⟩ ⤳ ⟨t'|exp_app v e2'⟩ • w
| sss_ktx_let :
  ∀ t e1 e2 t' e1' w,
  ⟨t|e1⟩ ⤳ ⟨t'|e1'⟩ • w →
  ⟨t|exp_let e1 e2⟩ ⤳ ⟨t'|exp_let e1' e2⟩ • w
| sss_ktx_binop1 :
  ∀ t op e1 e2 t' e1' w,
  ⟨t|e1⟩ ⤳ ⟨t'|e1'⟩ • w →
  ⟨t|exp_binop op e1 e2⟩ ⤳ ⟨t'|exp_binop op e1' e2⟩ • w
| sss_ktx_binop2 :
  ∀ t op (v : val0) e2 t' e2' w,
  ⟨t|e2⟩ ⤳ ⟨t'|e2'⟩ • w →
  ⟨t|exp_binop op v e2⟩ ⤳ ⟨t'|exp_binop op v e2'⟩ • w
| sss_ktx_proj :
  ∀ t e1 b t' e1' w,
  ⟨t|e1⟩ ⤳ ⟨t'|e1'⟩ • w →
  ⟨t|exp_proj e1 b⟩ ⤳ ⟨t'|exp_proj e1' b⟩ • w
| sss_ktx_if :
  ∀ t e1 e2 e3 t' e1' w,
  ⟨t|e1⟩ ⤳ ⟨t'|e1'⟩ • w →
  ⟨t|exp_if e1 e2 e3⟩ ⤳ ⟨t'|exp_if e1' e2 e3⟩ • w
| sss_ktx_sample :
  ∀ t e t' e' w,
  ⟨t|e⟩ ⤳ ⟨t'|e'⟩ • w →
  ⟨t|exp_sample e⟩ ⤳ ⟨t'|exp_sample e'⟩ • w
| sss_ktx_score :
  ∀ t e t' e' w,
  ⟨t|e⟩ ⤳ ⟨t'|e'⟩ • w →
  ⟨t|exp_score e⟩ ⤳ ⟨t'|exp_score e'⟩ • w
where "⟨ t | e ⟩ ⤳ ⟨ t' | e' ⟩ • w" := (sss t e t' e' w)
.

Hint Constructors sss : core.

Lemma ktx_congruence t e t' e' w :
⟨t | e⟩ ⤳ ⟨t' | e'⟩ • w → ∀ K, ⟨t | K[/e]⟩ ⤳ ⟨t' | K[/e']⟩ • w.
Proof.
induction K ; crush.
Qed.

Lemma sss_bifurcate t e t' e' w :
⟨t | e⟩ ⤳ ⟨t' | e'⟩ • w →
(∀ t'', ⟨t'' | e⟩ ⤳ ⟨t'' | e'⟩ • w) ∨ (
  ∃ K,
  e = K[/exp_sample val_unif] ∧
  e' = K[/val_real (proj1_sig (πL t 0%nat))] ∧
  t' = πR t ∧
  w = 1
).
Proof.
induction 1.
+ left ; clear t ; intro t ; constructor ; auto.
+ left ; clear t ; intro t ; constructor ; auto.
+ left ; clear t ; intro t ; constructor ; auto.
+ left ; clear t ; intro t ; constructor ; auto.
+ left ; clear t ; intro t ; constructor ; auto.
+ left. clear t. intro t. eapply sss_then.
+ left. clear t. intro t. eapply sss_else.
+ right ; exists ktx_hole ; crush.
+ left ; clear t ; intro t ; constructor ; auto.
+ left ; clear t ; intro t ; constructor ; auto.
+ left ; clear t ; intro t ; constructor ; auto.
+ destruct IHsss as [ | Q ] ; [ left | right ].
  1:{ intro ; constructor ; auto. }
  destruct Q as [K [? ?]].
  eexists (ktx_app1 K _) ; crush.
+ destruct IHsss as [ | Q ] ; [ left | right ].
  1:{ intro ; constructor ; auto. }
  destruct Q as [K [? ?]].
  eexists (ktx_app2 _ K) ; crush.
+ destruct IHsss as [ | Q ] ; [ left | right ].
  1:{ intro ; constructor ; auto. }
  destruct Q as [K [? ?]].
  eexists (ktx_let K _) ; crush.
+ destruct IHsss as [ | Q ] ; [ left | right ].
  1:{ intro ; constructor ; auto. }
  destruct Q as [K [? ?]].
  eexists (ktx_binop1 _ K _) ; crush.
+ destruct IHsss as [ | Q ] ; [ left | right ].
  1:{ intro ; constructor ; auto. }
  destruct Q as [K [? ?]].
  eexists (ktx_binop2 _ _ K) ; crush.
+ destruct IHsss as [ | Q ] ; [ left | right ].
  1:{ intro ; constructor ; auto. }
  destruct Q as [K [? ?]].
  eexists (ktx_proj K _) ; crush.
+ destruct IHsss as [ | Q ] ; [ left | right].
  1:{ intro. constructor. auto. }
  destruct Q as [K [? ?]].
  eexists (ktx_if K _ _) ; crush.
+ destruct IHsss as [ | Q ] ; [ left | right ].
  1:{ intro ; constructor ; auto. }
  destruct Q as [K [? ?]].
  eexists (ktx_sample K) ; crush.
+ destruct IHsss as [ | Q ] ; [ left | right ].
  1:{ intro ; constructor ; auto. }
  destruct Q as [K [? ?]].
  eexists (ktx_score K) ; crush.
Qed.

(** This lemma states that whether a term can step has nothing to do with the
entropy value. *)
Lemma stuck_test_sound e :
∀ t t' e' w,
  ⟨t | e⟩ ⤳ ⟨t' | e'⟩ • w →
  ∀ s, ∃ s' e'' w', ⟨s | e⟩ ⤳ ⟨s' | e''⟩ • w'
.
Proof.
intros t t' e' w . induction 1 ; intros s;
try (repeat eexists; econstructor; eassumption);
try (destruct (IHsss s) as (? & ? & ? & ?); repeat eexists; constructor; eassumption).
(*
  TODO
  Seems that Coq can not find r_pos: (0 < r)%R in this composed tactic.
*)
Unshelve.
assumption.
Qed.

Ltac auto_sss_ktx_inv := repeat match goal with
| [ H : exp_app _ _ = _ |- _ ] => inversion H ; subst ; clear H
| [ H : exp_let _ _ = _ |- _ ] => inversion H ; subst ; clear H
| [ H : exp_binop _ _ _ = _ |- _ ] => inversion H ; subst ; clear H
| [ H : exp_proj _ _ = _ |- _ ] => inversion H ; subst ; clear H
| [ H : exp_if _ _ _ = _ |- _ ] => inversion H ; subst ; clear H
| [ H : exp_sample _ = _ |- _ ] => inversion H ; subst ; clear H
| [ H : exp_score _ = _ |- _ ] => inversion H ; subst ; clear H
| [ H : exp_exn = _ |- _ ] => inversion H ; subst ; clear H
| [ P : ∀ v, ?e = exp_val v → False, H : exp_val _ = ktx_plug _ ?e |- _ ] =>
  exfalso ; eapply P ;
  apply eq_sym in H ;
  apply ktx_plug_is_val_inv in H ;
  destruct H as [_ H] ; subst ;
  eexists
| [ H : sss _ (exp_val _) _ _ _ |- _ ] => inversion H
end.

Lemma sss_ktx_inv t Kf t' e' w :
⟨t|Kf⟩ ⤳ ⟨t'|e'⟩ • w →
∀ K f, Kf = K[/f] →
(∀ v, f = exp_val v → False) →
∃ f', ⟨t|f⟩ ⤳ ⟨t'|f'⟩ • w ∧ e' = K[/f'].
Proof.
unfold not.
induction 1 ; intros K f HKf f_not_val.
+ destruct K ; simpl in HKf ; subst ; auto_sss_ktx_inv.
  1:{ eexists ; split ; [constructor | reflexivity].  }
+ destruct K ; simpl in HKf ; subst ; auto_sss_ktx_inv.
  1:{ eexists ; split ; [constructor | reflexivity].  }
+ destruct K ; simpl in HKf ; subst ; auto_sss_ktx_inv.
  1:{ eexists ; split ; [constructor | reflexivity].  }
+ destruct K ; simpl in HKf ; subst ; auto_sss_ktx_inv.
  1:{ eexists ; split ; [constructor ; eauto | reflexivity]. }
+ destruct K ; simpl in HKf ; subst ; auto_sss_ktx_inv.
  1:{ eexists ; split ; [constructor ; eauto | reflexivity]. }
+ destruct K ; simpl in HKf ; subst ; auto_sss_ktx_inv.
  1:{ eexists ; split ; [constructor ; eauto | reflexivity]. }
+ destruct K ; simpl in HKf ; subst ; auto_sss_ktx_inv.
  1:{ eexists ; split ; [constructor ; eauto | reflexivity]. }
+ destruct K ; simpl in HKf ; subst ; auto_sss_ktx_inv.
  1:{ eexists ; split ; [constructor ; eauto | reflexivity]. }
+ destruct K ; simpl in HKf ; subst ; auto_sss_ktx_inv.
  1:{ eexists ; split ; [constructor ; eauto | reflexivity]. }
+ destruct K ; simpl in HKf ; subst ; auto_sss_ktx_inv.
  1:{ eexists ; split ; [constructor ; eauto | reflexivity]. }
+ destruct K ; simpl in HKf ; subst ; auto_sss_ktx_inv.
  1:{ eexists ; split ; [constructor ; eauto | reflexivity]. }
+ destruct K ; simpl in HKf ; subst ; auto_sss_ktx_inv.
  { eexists ; split ; [constructor ; eauto | reflexivity]. }
  { destruct (IHsss _ _ eq_refl f_not_val) as [f' [? ?]] ; subst.
    eexists ; split ; eauto. }
+ destruct K ; simpl in HKf ; subst ; auto_sss_ktx_inv.
  { eexists ; split ; [constructor ; eauto | reflexivity]. }
  { destruct (IHsss _ _ eq_refl f_not_val) as [f' [? ?]] ; subst.
    eexists ; split ; eauto. }
+ destruct K ; simpl in HKf ; subst ; auto_sss_ktx_inv.
  { eexists ; split ; [constructor ; eauto | reflexivity]. }
  { destruct (IHsss _ _ eq_refl f_not_val) as [f' [? ?]] ; subst.
    eexists ; split ; eauto. }
+ destruct K ; simpl in HKf ; subst ; auto_sss_ktx_inv.
  { eexists ; split ; [constructor ; eauto | reflexivity]. }
  { destruct (IHsss _ _ eq_refl f_not_val) as [f' [? ?]] ; subst.
    eexists ; split ; eauto. }
+ destruct K ; simpl in HKf ; subst ; auto_sss_ktx_inv.
  { eexists ; split ; [constructor ; eauto | reflexivity]. }
  { destruct (IHsss _ _ eq_refl f_not_val) as [f' [? ?]] ; subst.
    eexists ; split ; eauto. }
+ destruct K ; simpl in HKf ; subst ; auto_sss_ktx_inv.
  { eexists ; split ; [constructor ; eauto | reflexivity]. }
  { destruct (IHsss _ _ eq_refl f_not_val) as [f' [? ?]] ; subst.
    eexists ; split ; eauto. }
+ destruct K ; simpl in HKf ; subst ; auto_sss_ktx_inv.
  { eexists ; split ; [constructor ; eauto | reflexivity]. }
  { destruct (IHsss _ _ eq_refl f_not_val) as [f' [? ?]] ; subst.
    eexists ; split ; eauto. }
+ destruct K ; simpl in HKf ; subst ; auto_sss_ktx_inv.
  { eexists ; split ; [constructor ; eauto | reflexivity]. }
  { destruct (IHsss _ _ eq_refl f_not_val) as [f' [? ?]] ; subst.
    eexists ; split ; eauto. }
+ destruct K ; simpl in HKf ; subst ; auto_sss_ktx_inv.
  { eexists ; split ; [constructor ; eauto | reflexivity]. }
  { destruct (IHsss _ _ eq_refl f_not_val) as [f' [? ?]] ; subst.
    eexists ; split ; eauto. }
Qed.

Lemma sss_ktx_exn_inv t K t' e' w :
~ ⟨t | K[/exp_exn]⟩ ⤳ ⟨t' | e'⟩ • w.
Proof.
unfold not.
induction K in t', e', w |-* ; simpl; intros H.
+ inversion H.
+ eapply sss_ktx_inv in H as [? [H ?]].
  1:{ eapply IHK. apply H. } 2:{ intros. ktx_plug_is_val_absurd. }
  bind_ktx_app1. reflexivity.
+ eapply sss_ktx_inv in H as [? [H ?]].
  1:{ eapply IHK. apply H. } 2:{ intros. ktx_plug_is_val_absurd. }
  bind_ktx_app2. reflexivity.
+ eapply sss_ktx_inv in H as [? [H ?]].
  1:{ eapply IHK. apply H. } 2:{ intros. ktx_plug_is_val_absurd. }
  bind_ktx_let. reflexivity.
+ eapply sss_ktx_inv in H as [? [H ?]].
  1:{ eapply IHK. apply H. } 2:{ intros. ktx_plug_is_val_absurd. }
  bind_ktx_binop1. reflexivity.
+ eapply sss_ktx_inv in H as [? [H ?]].
  1:{ eapply IHK. apply H. } 2:{ intros. ktx_plug_is_val_absurd. }
  bind_ktx_binop2. reflexivity.
+ eapply sss_ktx_inv in H as [? [H ?]].
  1:{ eapply IHK. apply H. } 2:{ intros. ktx_plug_is_val_absurd. }
  bind_ktx_proj. reflexivity.
+ eapply sss_ktx_inv in H as [? [H ?]].
  1:{ eapply IHK. apply H. } 2:{ intros. ktx_plug_is_val_absurd. }
  bind_ktx_if. reflexivity.
+ eapply sss_ktx_inv in H as [? [H ?]].
  1:{ eapply IHK. apply H. } 2:{ intros. ktx_plug_is_val_absurd. }
  bind_ktx_sample. reflexivity.
+ eapply sss_ktx_inv in H as [? [H ?]].
  1:{ eapply IHK. apply H. } 2:{ intros. ktx_plug_is_val_absurd. }
  bind_ktx_score. reflexivity.
Qed.
End section_sss.

Notation "eval ⟨ t | e ⟩ ⤳ ⟨ t' | e' ⟩ • w" :=
  (sss eval t e t' e' w)
  (at level 40, t, e, t', e', w at level 35).


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)

(*********************************************************)
(**          Complements for the real numbers            *)
(*                                                       *)
(*********************************************************)

Require Import Rbase.
Require Import R_Ifp.
Require Import Fourier.
Local Open Scope R_scope.

Implicit Type r : R.

(*******************************)
(** *        Rmin              *)
(*******************************)

(*********)
Definition Rmin (x y:R) : R :=
  match Rle_dec x y with
    | left _ => x
    | right _ => y
  end.

(*********)
Lemma Rmin_case : forall r1 r2 (P:R -> Type), P r1 -> P r2 -> P (Rmin r1 r2).
Proof.
  intros r1 r2 P H1 H2; unfold Rmin; case (Rle_dec r1 r2); auto.
Qed.

(*********)
Lemma Rmin_case_strong : forall r1 r2 (P:R -> Type),
  (r1 <= r2 -> P r1) -> (r2 <= r1 -> P r2) -> P (Rmin r1 r2).
Proof.
  intros r1 r2 P H1 H2; unfold Rmin; destruct (Rle_dec r1 r2); auto with real.
Qed.

(*********)
Lemma Rmin_Rgt_l : forall r1 r2 r, Rmin r1 r2 > r -> r1 > r /\ r2 > r.
Proof.
  intros r1 r2 r; unfold Rmin in |- *; case (Rle_dec r1 r2); intros.
  split.
  assumption.
  unfold Rgt in |- *; unfold Rgt in H; exact (Rlt_le_trans r r1 r2 H r0).
  split.
  generalize (Rnot_le_lt r1 r2 n); intro; exact (Rgt_trans r1 r2 r H0 H).
  assumption.
Qed.

(*********)
Lemma Rmin_Rgt_r : forall r1 r2 r, r1 > r /\ r2 > r -> Rmin r1 r2 > r.
Proof.
  intros; unfold Rmin in |- *; case (Rle_dec r1 r2); elim H; clear H; intros;
    assumption.
Qed.

(*********)
Lemma Rmin_Rgt : forall r1 r2 r, Rmin r1 r2 > r <-> r1 > r /\ r2 > r.
Proof.
  intros; split.
  exact (Rmin_Rgt_l r1 r2 r).
  exact (Rmin_Rgt_r r1 r2 r).
Qed.

(*********)
Lemma Rmin_l : forall x y:R, Rmin x y <= x.
Proof.
  intros; unfold Rmin in |- *; case (Rle_dec x y); intro H1;
    [ right; reflexivity | auto with real ].
Qed.

(*********)
Lemma Rmin_r : forall x y:R, Rmin x y <= y.
Proof.
  intros; unfold Rmin in |- *; case (Rle_dec x y); intro H1;
    [ assumption | auto with real ].
Qed.

(*********)
Lemma Rmin_left : forall x y, x <= y -> Rmin x y = x.
Proof.
  intros; apply Rmin_case_strong; auto using Rle_antisym.
Qed.

(*********)
Lemma Rmin_right : forall x y, y <= x -> Rmin x y = y.
Proof.
  intros; apply Rmin_case_strong; auto using Rle_antisym.
Qed.

(*********)
Lemma Rle_min_compat_r : forall x y z, x <= y -> Rmin x z <= Rmin y z.
Proof.
  intros; do 2 (apply Rmin_case_strong; intro); eauto using Rle_trans, Rle_refl.
Qed.

(*********)
Lemma Rle_min_compat_l : forall x y z, x <= y -> Rmin z x <= Rmin z y.
Proof.
  intros; do 2 (apply Rmin_case_strong; intro); eauto using Rle_trans, Rle_refl.
Qed.

(*********)
Lemma Rmin_comm : forall x y:R, Rmin x y = Rmin y x.
Proof.
  intros; unfold Rmin; case (Rle_dec x y); case (Rle_dec y x); intros;
    try reflexivity || (apply Rle_antisym; assumption || auto with real).
Qed.

(*********)
Lemma Rmin_stable_in_posreal : forall x y:posreal, 0 < Rmin x y.
Proof.
  intros; apply Rmin_Rgt_r; split; [ apply (cond_pos x) | apply (cond_pos y) ].
Qed.

(*********)
Lemma Rmin_pos : forall x y:R, 0 < x -> 0 < y -> 0 < Rmin x y.
Proof.
  intros; unfold Rmin in |- *.
  case (Rle_dec x y); intro; assumption.
Qed.

(*********)
Lemma Rmin_glb : forall x y z:R, z <= x -> z <= y -> z <= Rmin x y.
Proof.
  intros; unfold Rmin in |- *; case (Rle_dec x y); intro; assumption.
Qed.

(*********)
Lemma Rmin_glb_lt : forall x y z:R, z < x -> z < y -> z < Rmin x y.
Proof.
  intros; unfold Rmin in |- *; case (Rle_dec x y); intro; assumption.
Qed.

(*******************************)
(** *        Rmax              *)
(*******************************)

(*********)
Definition Rmax (x y:R) : R :=
  match Rle_dec x y with
    | left _ => y
    | right _ => x
  end.

(*********)
Lemma Rmax_case : forall r1 r2 (P:R -> Type), P r1 -> P r2 -> P (Rmax r1 r2).
Proof.
  intros r1 r2 P H1 H2; unfold Rmax; case (Rle_dec r1 r2); auto.
Qed.

(*********)
Lemma Rmax_case_strong : forall r1 r2 (P:R -> Type),
  (r2 <= r1 -> P r1) -> (r1 <= r2 -> P r2) -> P (Rmax r1 r2).
Proof.
  intros r1 r2 P H1 H2; unfold Rmax; case (Rle_dec r1 r2); auto with real.
Qed.

(*********)
Lemma Rmax_Rle : forall r1 r2 r, r <= Rmax r1 r2 <-> r <= r1 \/ r <= r2.
Proof.
  intros; split.
  unfold Rmax in |- *; case (Rle_dec r1 r2); intros; auto.
  intro; unfold Rmax in |- *; case (Rle_dec r1 r2); elim H; clear H; intros;
    auto.
  apply (Rle_trans r r1 r2); auto.
  generalize (Rnot_le_lt r1 r2 n); clear n; intro; unfold Rgt in H0;
    apply (Rlt_le r r1 (Rle_lt_trans r r2 r1 H H0)).
Qed.

Lemma Rmax_comm : forall x y:R, Rmax x y = Rmax y x.
Proof.
  intros p q; unfold Rmax in |- *; case (Rle_dec p q); case (Rle_dec q p); auto;
    intros H1 H2; apply Rle_antisym; auto with real.
Qed.

(* begin hide *)
Notation RmaxSym := Rmax_comm (only parsing).
(* end hide *)

(*********)
Lemma Rmax_l : forall x y:R, x <= Rmax x y.
Proof.
  intros; unfold Rmax in |- *; case (Rle_dec x y); intro H1;
    [ assumption | auto with real ].
Qed.

(*********)
Lemma Rmax_r : forall x y:R, y <= Rmax x y.
Proof.
  intros; unfold Rmax in |- *; case (Rle_dec x y); intro H1;
    [ right; reflexivity | auto with real ].
Qed.

(* begin hide *)
Notation RmaxLess1 := Rmax_l (only parsing).
Notation RmaxLess2 := Rmax_r (only parsing).
(* end hide *)

(*********)
Lemma Rmax_left : forall x y, y <= x -> Rmax x y = x.
Proof.
  intros; apply Rmax_case_strong; auto using Rle_antisym.
Qed.

(*********)
Lemma Rmax_right : forall x y, x <= y -> Rmax x y = y.
Proof.
  intros; apply Rmax_case_strong; auto using Rle_antisym.
Qed.

(*********)
Lemma Rle_max_compat_r : forall x y z, x <= y -> Rmax x z <= Rmax y z.
Proof.
  intros; do 2 (apply Rmax_case_strong; intro); eauto using Rle_trans, Rle_refl.
Qed.

(*********)
Lemma Rle_max_compat_l : forall x y z, x <= y -> Rmax z x <= Rmax z y.
Proof.
  intros; do 2 (apply Rmax_case_strong; intro); eauto using Rle_trans, Rle_refl.
Qed.

(*********)
Lemma RmaxRmult :
  forall (p q:R) r, 0 <= r -> Rmax (r * p) (r * q) = r * Rmax p q.
Proof.
  intros p q r H; unfold Rmax in |- *.
  case (Rle_dec p q); case (Rle_dec (r * p) (r * q)); auto; intros H1 H2; auto.
  case H; intros E1.
  case H1; auto with real.
  rewrite <- E1; repeat rewrite Rmult_0_l; auto.
  case H; intros E1.
  case H2; auto with real.
  apply Rmult_le_reg_l with (r := r); auto.
  rewrite <- E1; repeat rewrite Rmult_0_l; auto.
Qed.

(*********)
Lemma Rmax_stable_in_negreal : forall x y:negreal, Rmax x y < 0.
Proof.
  intros; unfold Rmax in |- *; case (Rle_dec x y); intro;
    [ apply (cond_neg y) | apply (cond_neg x) ].
Qed.

(*********)
Lemma Rmax_lub : forall x y z:R, x <= z -> y <= z -> Rmax x y <= z.
Proof.
  intros; unfold Rmax; case (Rle_dec x y); intro; assumption.
Qed.

(*********)
Lemma Rmax_lub_lt : forall x y z:R, x < z -> y < z -> Rmax x y < z.
Proof.
  intros; unfold Rmax; case (Rle_dec x y); intro; assumption.
Qed.

(*********)
Lemma Rmax_neg : forall x y:R, x < 0 -> y < 0 -> Rmax x y < 0.
Proof.
  intros; unfold Rmax in |- *.
  case (Rle_dec x y); intro; assumption.
Qed.

(*******************************)
(** *        Rabsolu           *)
(*******************************)

(*********)
Lemma Rcase_abs : forall r, {r < 0} + {r >= 0}.
Proof.
  intro; generalize (Rle_dec 0 r); intro X; elim X; intro; clear X.
  right; apply (Rle_ge 0 r a).
  left; fold (0 > r) in |- *; apply (Rnot_le_lt 0 r b).
Qed.

(*********)
Definition Rabs r : R :=
  match Rcase_abs r with
    | left _ => - r
    | right _ => r
  end.

(*********)
Lemma Rabs_R0 : Rabs 0 = 0.
Proof.
  unfold Rabs in |- *; case (Rcase_abs 0); auto; intro.
  generalize (Rlt_irrefl 0); intro; exfalso; auto.
Qed.

Lemma Rabs_R1 : Rabs 1 = 1.
Proof.
unfold Rabs in |- *; case (Rcase_abs 1); auto with real.
intros H; absurd (1 < 0); auto with real.
Qed.

(*********)
Lemma Rabs_no_R0 : forall r, r <> 0 -> Rabs r <> 0.
Proof.
  intros; unfold Rabs in |- *; case (Rcase_abs r); intro; auto.
  apply Ropp_neq_0_compat; auto.
Qed.

(*********)
Lemma Rabs_left : forall r, r < 0 -> Rabs r = - r.
Proof.
  intros; unfold Rabs in |- *; case (Rcase_abs r); trivial; intro;
    absurd (r >= 0).
  exact (Rlt_not_ge r 0 H).
  assumption.
Qed.

(*********)
Lemma Rabs_right : forall r, r >= 0 -> Rabs r = r.
Proof.
  intros; unfold Rabs in |- *; case (Rcase_abs r); intro.
  absurd (r >= 0).
  exact (Rlt_not_ge r 0 r0).
  assumption.
  trivial.
Qed.

Lemma Rabs_left1 : forall a:R, a <= 0 -> Rabs a = - a.
Proof.
  intros a H; case H; intros H1.
  apply Rabs_left; auto.
  rewrite H1; simpl in |- *; rewrite Rabs_right; auto with real.
Qed.

(*********)
Lemma Rabs_pos : forall x:R, 0 <= Rabs x.
Proof.
  intros; unfold Rabs in |- *; case (Rcase_abs x); intro.
  generalize (Ropp_lt_gt_contravar x 0 r); intro; unfold Rgt in H;
    rewrite Ropp_0 in H; unfold Rle in |- *; left; assumption.
  apply Rge_le; assumption.
Qed.

Lemma Rle_abs : forall x:R, x <= Rabs x.
Proof.
  intro; unfold Rabs in |- *; case (Rcase_abs x); intros; fourier.
Qed.

Definition RRle_abs := Rle_abs.

(*********)
Lemma Rabs_pos_eq : forall x:R, 0 <= x -> Rabs x = x.
Proof.
  intros; unfold Rabs in |- *; case (Rcase_abs x); intro;
    [ generalize (Rgt_not_le 0 x r); intro; exfalso; auto | trivial ].
Qed.

(*********)
Lemma Rabs_Rabsolu : forall x:R, Rabs (Rabs x) = Rabs x.
Proof.
  intro; apply (Rabs_pos_eq (Rabs x) (Rabs_pos x)).
Qed.

(*********)
Lemma Rabs_pos_lt : forall x:R, x <> 0 -> 0 < Rabs x.
Proof.
  intros; generalize (Rabs_pos x); intro; unfold Rle in H0; elim H0; intro;
    auto.
  exfalso; clear H0; elim H; clear H; generalize H1; unfold Rabs in |- *;
    case (Rcase_abs x); intros; auto.
  clear r H1; generalize (Rplus_eq_compat_l x 0 (- x) H0);
    rewrite (let (H1, H2) := Rplus_ne x in H1); rewrite (Rplus_opp_r x);
      trivial.
Qed.

(*********)
Lemma Rabs_minus_sym : forall x y:R, Rabs (x - y) = Rabs (y - x).
Proof.
  intros; unfold Rabs in |- *; case (Rcase_abs (x - y));
    case (Rcase_abs (y - x)); intros.
  generalize (Rminus_lt y x r); generalize (Rminus_lt x y r0); intros;
    generalize (Rlt_asym x y H); intro; exfalso;
      auto.
  rewrite (Ropp_minus_distr x y); trivial.
  rewrite (Ropp_minus_distr y x); trivial.
  unfold Rge in r, r0; elim r; elim r0; intros; clear r r0.
  generalize (Ropp_lt_gt_0_contravar (x - y) H); rewrite (Ropp_minus_distr x y);
    intro; unfold Rgt in H0; generalize (Rlt_asym 0 (y - x) H0);
      intro; exfalso; auto.
  rewrite (Rminus_diag_uniq x y H); trivial.
  rewrite (Rminus_diag_uniq y x H0); trivial.
  rewrite (Rminus_diag_uniq y x H0); trivial.
Qed.

(*********)
Lemma Rabs_mult : forall x y:R, Rabs (x * y) = Rabs x * Rabs y.
Proof.
  intros; unfold Rabs in |- *; case (Rcase_abs (x * y)); case (Rcase_abs x);
    case (Rcase_abs y); intros; auto.
  generalize (Rmult_lt_gt_compat_neg_l y x 0 r r0); intro;
    rewrite (Rmult_0_r y) in H; generalize (Rlt_asym (x * y) 0 r1);
      intro; unfold Rgt in H; exfalso; rewrite (Rmult_comm y x) in H;
        auto.
  rewrite (Ropp_mult_distr_l_reverse x y); trivial.
  rewrite (Rmult_comm x (- y)); rewrite (Ropp_mult_distr_l_reverse y x);
    rewrite (Rmult_comm x y); trivial.
  unfold Rge in r, r0; elim r; elim r0; clear r r0; intros; unfold Rgt in H, H0.
  generalize (Rmult_lt_compat_l x 0 y H H0); intro; rewrite (Rmult_0_r x) in H1;
    generalize (Rlt_asym (x * y) 0 r1); intro; exfalso;
      auto.
  rewrite H in r1; rewrite (Rmult_0_l y) in r1; generalize (Rlt_irrefl 0);
    intro; exfalso; auto.
  rewrite H0 in r1; rewrite (Rmult_0_r x) in r1; generalize (Rlt_irrefl 0);
    intro; exfalso; auto.
  rewrite H0 in r1; rewrite (Rmult_0_r x) in r1; generalize (Rlt_irrefl 0);
    intro; exfalso; auto.
  rewrite (Rmult_opp_opp x y); trivial.
  unfold Rge in r, r1; elim r; elim r1; clear r r1; intros; unfold Rgt in H0, H.
  generalize (Rmult_lt_compat_l y x 0 H0 r0); intro;
    rewrite (Rmult_0_r y) in H1; rewrite (Rmult_comm y x) in H1;
      generalize (Rlt_asym (x * y) 0 H1); intro; exfalso;
        auto.
  generalize (Rlt_dichotomy_converse x 0 (or_introl (x > 0) r0));
    generalize (Rlt_dichotomy_converse y 0 (or_intror (y < 0) H0));
      intros; generalize (Rmult_integral x y H); intro;
        elim H3; intro; exfalso; auto.
  rewrite H0 in H; rewrite (Rmult_0_r x) in H; unfold Rgt in H;
    generalize (Rlt_irrefl 0); intro; exfalso;
      auto.
  rewrite H0; rewrite (Rmult_0_r x); rewrite (Rmult_0_r (- x)); trivial.
  unfold Rge in r0, r1; elim r0; elim r1; clear r0 r1; intros;
    unfold Rgt in H0, H.
  generalize (Rmult_lt_compat_l x y 0 H0 r); intro; rewrite (Rmult_0_r x) in H1;
    generalize (Rlt_asym (x * y) 0 H1); intro; exfalso;
      auto.
  generalize (Rlt_dichotomy_converse y 0 (or_introl (y > 0) r));
    generalize (Rlt_dichotomy_converse 0 x (or_introl (0 > x) H0));
      intros; generalize (Rmult_integral x y H); intro;
        elim H3; intro; exfalso; auto.
  rewrite H0 in H; rewrite (Rmult_0_l y) in H; unfold Rgt in H;
    generalize (Rlt_irrefl 0); intro; exfalso;
      auto.
  rewrite H0; rewrite (Rmult_0_l y); rewrite (Rmult_0_l (- y)); trivial.
Qed.

(*********)
Lemma Rabs_Rinv : forall r, r <> 0 -> Rabs (/ r) = / Rabs r.
Proof.
  intro; unfold Rabs in |- *; case (Rcase_abs r); case (Rcase_abs (/ r)); auto;
    intros.
  apply Ropp_inv_permute; auto.
  generalize (Rinv_lt_0_compat r r1); intro; unfold Rge in r0; elim r0; intros.
  unfold Rgt in H1; generalize (Rlt_asym 0 (/ r) H1); intro; exfalso;
    auto.
  generalize (Rlt_dichotomy_converse (/ r) 0 (or_introl (/ r > 0) H0)); intro;
    exfalso; auto.
  unfold Rge in r1; elim r1; clear r1; intro.
  unfold Rgt in H0; generalize (Rlt_asym 0 (/ r) (Rinv_0_lt_compat r H0));
    intro; exfalso; auto.
  exfalso; auto.
Qed.

Lemma Rabs_Ropp : forall x:R, Rabs (- x) = Rabs x.
Proof.
  intro; cut (- x = -1 * x).
  intros; rewrite H.
  rewrite Rabs_mult.
  cut (Rabs (-1) = 1).
  intros; rewrite H0.
  ring.
  unfold Rabs in |- *; case (Rcase_abs (-1)).
  intro; ring.
  intro H0; generalize (Rge_le (-1) 0 H0); intros.
  generalize (Ropp_le_ge_contravar 0 (-1) H1).
  rewrite Ropp_involutive; rewrite Ropp_0.
  intro; generalize (Rgt_not_le 1 0 Rlt_0_1); intro; generalize (Rge_le 0 1 H2);
    intro; exfalso; auto.
  ring.
Qed.

(*********)
Lemma Rabs_triang : forall a b:R, Rabs (a + b) <= Rabs a + Rabs b.
Proof.
  intros a b; unfold Rabs in |- *; case (Rcase_abs (a + b)); case (Rcase_abs a);
    case (Rcase_abs b); intros.
  apply (Req_le (- (a + b)) (- a + - b)); rewrite (Ropp_plus_distr a b);
    reflexivity.
(**)
  rewrite (Ropp_plus_distr a b); apply (Rplus_le_compat_l (- a) (- b) b);
    unfold Rle in |- *; unfold Rge in r; elim r; intro.
  left; unfold Rgt in H; generalize (Rplus_lt_compat_l (- b) 0 b H); intro;
    elim (Rplus_ne (- b)); intros v w; rewrite v in H0;
      clear v w; rewrite (Rplus_opp_l b) in H0; apply (Rlt_trans (- b) 0 b H0 H).
  right; rewrite H; apply Ropp_0.
(**)
  rewrite (Ropp_plus_distr a b); rewrite (Rplus_comm (- a) (- b));
    rewrite (Rplus_comm a (- b)); apply (Rplus_le_compat_l (- b) (- a) a);
      unfold Rle in |- *; unfold Rge in r0; elim r0; intro.
  left; unfold Rgt in H; generalize (Rplus_lt_compat_l (- a) 0 a H); intro;
    elim (Rplus_ne (- a)); intros v w; rewrite v in H0;
      clear v w; rewrite (Rplus_opp_l a) in H0; apply (Rlt_trans (- a) 0 a H0 H).
  right; rewrite H; apply Ropp_0.
(**)
  exfalso; generalize (Rplus_ge_compat_l a b 0 r); intro;
    elim (Rplus_ne a); intros v w; rewrite v in H; clear v w;
      generalize (Rge_trans (a + b) a 0 H r0); intro; clear H;
        unfold Rge in H0; elim H0; intro; clear H0.
  unfold Rgt in H; generalize (Rlt_asym (a + b) 0 r1); intro; auto.
  absurd (a + b = 0); auto.
  apply (Rlt_dichotomy_converse (a + b) 0); left; assumption.
(**)
  exfalso; generalize (Rplus_lt_compat_l a b 0 r); intro;
    elim (Rplus_ne a); intros v w; rewrite v in H; clear v w;
      generalize (Rlt_trans (a + b) a 0 H r0); intro; clear H;
        unfold Rge in r1; elim r1; clear r1; intro.
  unfold Rgt in H; generalize (Rlt_trans (a + b) 0 (a + b) H0 H); intro;
    apply (Rlt_irrefl (a + b)); assumption.
  rewrite H in H0; apply (Rlt_irrefl 0); assumption.
(**)
  rewrite (Rplus_comm a b); rewrite (Rplus_comm (- a) b);
    apply (Rplus_le_compat_l b a (- a)); apply (Rminus_le a (- a));
      unfold Rminus in |- *; rewrite (Ropp_involutive a);
        generalize (Rplus_lt_compat_l a a 0 r0); clear r r1;
          intro; elim (Rplus_ne a); intros v w; rewrite v in H;
            clear v w; generalize (Rlt_trans (a + a) a 0 H r0);
              intro; apply (Rlt_le (a + a) 0 H0).
(**)
  apply (Rplus_le_compat_l a b (- b)); apply (Rminus_le b (- b));
    unfold Rminus in |- *; rewrite (Ropp_involutive b);
      generalize (Rplus_lt_compat_l b b 0 r); clear r0 r1;
        intro; elim (Rplus_ne b); intros v w; rewrite v in H;
          clear v w; generalize (Rlt_trans (b + b) b 0 H r);
            intro; apply (Rlt_le (b + b) 0 H0).
(**)
  unfold Rle in |- *; right; reflexivity.
Qed.

(*********)
Lemma Rabs_triang_inv : forall a b:R, Rabs a - Rabs b <= Rabs (a - b).
Proof.
  intros; apply (Rplus_le_reg_l (Rabs b) (Rabs a - Rabs b) (Rabs (a - b)));
    unfold Rminus in |- *; rewrite <- (Rplus_assoc (Rabs b) (Rabs a) (- Rabs b));
      rewrite (Rplus_comm (Rabs b) (Rabs a));
        rewrite (Rplus_assoc (Rabs a) (Rabs b) (- Rabs b));
          rewrite (Rplus_opp_r (Rabs b)); rewrite (proj1 (Rplus_ne (Rabs a)));
            replace (Rabs a) with (Rabs (a + 0)).
  rewrite <- (Rplus_opp_r b); rewrite <- (Rplus_assoc a b (- b));
    rewrite (Rplus_comm a b); rewrite (Rplus_assoc b a (- b)).
  exact (Rabs_triang b (a + - b)).
  rewrite (proj1 (Rplus_ne a)); trivial.
Qed.

(* ||a|-|b||<=|a-b| *)
Lemma Rabs_triang_inv2 : forall a b:R, Rabs (Rabs a - Rabs b) <= Rabs (a - b).
Proof.
  cut
    (forall a b:R, Rabs b <= Rabs a -> Rabs (Rabs a - Rabs b) <= Rabs (a - b)).
  intros; destruct (Rtotal_order (Rabs a) (Rabs b)) as [Hlt| [Heq| Hgt]].
  rewrite <- (Rabs_Ropp (Rabs a - Rabs b)); rewrite <- (Rabs_Ropp (a - b));
    do 2 rewrite Ropp_minus_distr.
  apply H; left; assumption.
  rewrite Heq; unfold Rminus in |- *; rewrite Rplus_opp_r; rewrite Rabs_R0;
    apply Rabs_pos.
  apply H; left; assumption.
  intros; replace (Rabs (Rabs a - Rabs b)) with (Rabs a - Rabs b).
  apply Rabs_triang_inv.
  rewrite (Rabs_right (Rabs a - Rabs b));
    [ reflexivity
      | apply Rle_ge; apply Rplus_le_reg_l with (Rabs b); rewrite Rplus_0_r;
        replace (Rabs b + (Rabs a - Rabs b)) with (Rabs a);
        [ assumption | ring ] ].
Qed.

(*********)
Lemma Rabs_def1 : forall x a:R, x < a -> - a < x -> Rabs x < a.
Proof.
  unfold Rabs in |- *; intros; case (Rcase_abs x); intro.
  generalize (Ropp_lt_gt_contravar (- a) x H0); unfold Rgt in |- *;
    rewrite Ropp_involutive; intro; assumption.
  assumption.
Qed.

(*********)
Lemma Rabs_def2 : forall x a:R, Rabs x < a -> x < a /\ - a < x.
Proof.
  unfold Rabs in |- *; intro x; case (Rcase_abs x); intros.
  generalize (Ropp_gt_lt_0_contravar x r); unfold Rgt in |- *; intro;
    generalize (Rlt_trans 0 (- x) a H0 H); intro; split.
  apply (Rlt_trans x 0 a r H1).
  generalize (Ropp_lt_gt_contravar (- x) a H); rewrite (Ropp_involutive x);
    unfold Rgt in |- *; trivial.
  fold (a > x) in H; generalize (Rgt_ge_trans a x 0 H r); intro;
    generalize (Ropp_lt_gt_0_contravar a H0); intro; fold (0 > - a) in |- *;
      generalize (Rge_gt_trans x 0 (- a) r H1); unfold Rgt in |- *;
        intro; split; assumption.
Qed.

Lemma RmaxAbs :
  forall (p q:R) r, p <= q -> q <= r -> Rabs q <= Rmax (Rabs p) (Rabs r).
Proof.
  intros p q r H' H'0; case (Rle_or_lt 0 p); intros H'1.
  repeat rewrite Rabs_right; auto with real.
  apply Rle_trans with r; auto with real.
  apply RmaxLess2; auto.
  apply Rge_trans with p; auto with real; apply Rge_trans with q;
    auto with real.
  apply Rge_trans with p; auto with real.
  rewrite (Rabs_left p); auto.
  case (Rle_or_lt 0 q); intros H'2.
  repeat rewrite Rabs_right; auto with real.
  apply Rle_trans with r; auto.
  apply RmaxLess2; auto.
  apply Rge_trans with q; auto with real.
  rewrite (Rabs_left q); auto.
  case (Rle_or_lt 0 r); intros H'3.
  repeat rewrite Rabs_right; auto with real.
  apply Rle_trans with (- p); auto with real.
  apply RmaxLess1; auto.
  rewrite (Rabs_left r); auto.
  apply Rle_trans with (- p); auto with real.
  apply RmaxLess1; auto.
Qed.

Lemma Rabs_Zabs : forall z:Z, Rabs (IZR z) = IZR (Zabs z).
Proof.
  intros z; case z; simpl in |- *; auto with real.
  apply Rabs_right; auto with real.
  intros p0; apply Rabs_right; auto with real zarith.
  intros p0; rewrite Rabs_Ropp.
  apply Rabs_right; auto with real zarith.
Qed.

Lemma abs_IZR : forall z, IZR (Zabs z) = Rabs (IZR z).
Proof.
  intros.
  now rewrite Rabs_Zabs.
Qed.


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

(* Contribution to the Coq Library   V6.3 (July 1999)                    *)

(*  ---                        two_power.v                             ---  *)
(*                                                                          *)
(* Author: Pierre Casteran.                                                 *)
(*    LABRI, URA CNRS 1304,                                                 *)
(*    Departement d'Informatique, Universite Bordeaux I,                    *)
(*    33405 Talence CEDEX,                                                  *)
(*    e-mail:  casteran@labri.u-bordeaux.fr                                 *)

(* From additions/two_power.v *)

Require Import Arith.

Fixpoint two_power (m : nat) : nat :=
  match m with
  | O => 1
  | S n => S (S 0) * two_power n
  end.

Lemma mult_le_l : forall a b c : nat, b <= c -> a * b <= a * c.
(******************************************)
Proof.
 simple induction a; simpl in |- *; [ auto with arith | intros ].
 apply plus_le_compat; auto with arith.
Qed.

Lemma mult_lt_l : forall a b c : nat, 0 < a -> b < c -> a * b < a * c.
(******************************************)
Proof.
 simple induction a.
 intros; absurd (0 < 0); auto with arith.
 intros; simpl in |- *.
 apply lt_le_trans with (c + n * b).
 rewrite (plus_comm b (n * b)); rewrite (plus_comm c (n * b));
  apply plus_lt_compat_l; auto with arith.
 apply plus_le_compat_l; auto with arith.
Qed.

Lemma mult_p_lt_qp : forall p q : nat, 0 < p -> S 0 < q -> p < q * p.
(************************************)
Proof.
 intros.
 rewrite mult_comm.
 pattern p at 1 in |- *; rewrite <- mult_1_r; apply mult_lt_l; assumption.
Qed.

Lemma zero_lt_pow : forall a : nat, 0 < two_power a.
(********************************************)
Proof.
  simple induction a.
  auto.
 intros.
 apply lt_plus_trans. auto.
Qed.

Lemma two_power_S : forall n : nat, two_power (S n) = two_power n * S (S 0).
(**************************************************)
Proof.
  intros.
  unfold two_power at 1. rewrite mult_comm. auto.
Qed.

Lemma two_power_S_lt : forall n : nat, two_power n < two_power (S n).
(***************************************************************)
Proof.
  intro. rewrite two_power_S.
  rewrite mult_comm.
  apply mult_p_lt_qp. apply zero_lt_pow.
  auto.
Qed.


Require Import Coq.Classes.RelationClasses.
Require Import CommonKnowledge.Relations.RelationConstructors.
Require Import CommonKnowledge.Classes.RelationConstructorClasses.

Class AbstractEq (A: Type): Type :=
  abstract_eq: relation A.

Module EquivNotations.

Declare Scope ordering.

Notation "a == b" := (abstract_eq a b) (at level 70, no associativity): ordering.
Notation "a =/= b" := (not (abstract_eq a b)) (at level 70, no associativity): ordering.

End EquivNotations.

Definition RealEq (A: Type): AbstractEq A := @eq A.

Lemma RealEqEqu (A: Type): Equivalence (@abstract_eq _ (RealEq A)).
Proof. apply eq_equivalence. Qed.

Definition EqProd (A B: Type) {EqA: AbstractEq A} {EqB: AbstractEq B}: AbstractEq (prod A B) :=
  prod_relation abstract_eq abstract_eq.

Definition EqSum (A B: Type) {EqA: AbstractEq A} {EqB: AbstractEq B}: AbstractEq (sum A B) :=
  sum00_relation abstract_eq abstract_eq.

Definition EqSigT {I: Type} (A: I -> Type) {EqA: forall i, AbstractEq (A i)}: AbstractEq (sigT A) :=
  sigT_relation (fun i => @abstract_eq (A i) (EqA i)).

Definition EqSig {A: Type} (P: A -> Prop) {EqA: AbstractEq A}: AbstractEq (sig P) :=
  sig_relation P abstract_eq.

Lemma EqProdEqu (A B: Type) {EqA: AbstractEq A} {EqB: AbstractEq B}
  {EquA: Equivalence (@abstract_eq A EqA)} {EquB: Equivalence (@abstract_eq B EqB)}:
  Equivalence (@abstract_eq (A * B) (EqProd A B)).
Proof. apply prod_relation_Equivalence; auto. Qed.

Lemma EqSumEqu (A B: Type) {EqA: AbstractEq A} {EqB: AbstractEq B}
  {EquA: Equivalence (@abstract_eq A EqA)} {EquB: Equivalence (@abstract_eq B EqB)}:
  Equivalence (@abstract_eq (A + B) (EqSum A B)).
Proof. apply sum00_equivalence; auto. Qed.

Lemma EqSigTEqu {I: Type} (A: I -> Type) {EqA: forall i, AbstractEq (A i)}
  {EquA: forall i, Equivalence (@abstract_eq (A i) (EqA i))}:
  Equivalence (@abstract_eq (sigT A) (EqSigT A)).
Proof. apply sigT_relation_equivalence; auto. Qed.

Lemma EqSigEqu {A: Type} (P: A -> Prop) {EqA: AbstractEq A} {EquA: Equivalence abstract_eq}:
  Equivalence (@abstract_eq (sig P) (EqSig P)).
Proof. apply sig_relation_equivalence; auto. Qed.

Section IsRealEq.

Import EquivNotations.
Local Open Scope ordering.

Class IsRealEq (A: Type) (EqA: AbstractEq A) :=
  is_real_eq: forall a b: A, a == b <-> a = b.

Lemma RealEq_IsRealEq (A: Type): IsRealEq A (RealEq A).
Proof. firstorder. Qed.

Lemma EqSum_IsRealEq (A B: Type) (EqA: AbstractEq A) (EqB: AbstractEq B):
  IsRealEq A EqA -> IsRealEq B EqB -> IsRealEq (A + B) (EqSum A B).
Proof.
  intros.
  hnf; intros.
  split; intros.
  + inversion H1; subst.
    - f_equal.
      apply H; auto.
    - f_equal.
      apply H0; auto.
  + subst b.
    destruct a.
    - constructor.
      apply H; auto.
    - constructor.
      apply H0; auto.
Qed.

Lemma EqProd_IsRealEq (A B: Type) (EqA: AbstractEq A) (EqB: AbstractEq B):
  IsRealEq A EqA -> IsRealEq B EqB -> IsRealEq (A * B) (EqProd A B).
Proof.
  intros.
  hnf; intros.
  split; intros.
  + destruct a as [a1 a2], b as [b1 b2].
    destruct H1 as [H1 H2]; simpl in H1, H2.
    f_equal; [apply H | apply H0]; auto.
  + subst b.
    destruct a as [a1 a2].
    split; simpl; [apply H | apply H0]; auto.
Qed.

Lemma EqSigT_IsRealEq {I: Type} (A: I -> Type) {EqA: forall i, AbstractEq (A i)}:
  (forall i, IsRealEq (A i) (EqA i)) -> IsRealEq (sigT A) (EqSigT A).
Proof.
  intros.
  hnf; intros.
  split; intros.
  + inversion H0; subst.
    apply H in H1.
    subst; auto.
  + subst.
    destruct b as [i a].
    constructor.
    apply H; auto.
Qed.

End IsRealEq.