(**
CoLoR, a Coq library on rewriting and termination.
See the COPYRIGHTS and LICENSE files.

- Frederic Blanqui, 2009-04-29 (bigN)
- Frederic Blanqui, 2009-03-19 (setoid)
- Adam Koprowski and Hans Zantema, 2007-03-22

Termination criterion based on matrix interpretations.

References:
-  J. Endrullis, J. Waldmann and H. Zantema, "Matrix Interpretations for
   Proving Termination of Term Rewriting", Proceedings of the 3rd
   International Joint Conference (IJCAR 2006), 2006.
*)

Set Implicit Arguments.

From Coq Require Import Setoid.
From CoLoR Require Import LogicUtil Matrix OrdSemiRing VecUtil AMonAlg SN
     RelUtil AWFMInterpretation NatUtil AMatrixBasedInt.
From Coq Require List.
From CoLoR Require ListUtil.

Import NMatrix.

(** Module type for proving termination with matrix interpretations *)
Module Type TMatrixInt.

  Parameter sig : Signature.
  Parameter dim : nat.
  Parameter dim_pos : (dim > 0)%nat.
  Parameter trsInt : forall f : sig, matrixInt nat matrix dim (arity f).

End TMatrixInt.

Definition matrixInt := @matrixInt A matrix.
Definition mkMatrixInt := @mkMatrixInt A matrix.

Module MatrixInt (MI : TMatrixInt).

  Export MI.

  Module Conf <: MatrixMethodConf.

    Module Export OSRT := NOrdSemiRingT.
    Module Export M := Matrix OSRT.

    Definition sig := sig.
    Definition dim := dim.
    Definition dim_pos := dim_pos.

    Definition trsInt := trsInt.
    Notation vec := (vec dim).
    Definition vec_invariant (v : vec) := True.

    Lemma inv_id_matrix :
      vec_invariant (Vreplace (Vconst A0 dim) dim_pos A1).

    Proof.
      compute. trivial.
    Qed.

  End Conf.

  Module Export MBI := MatrixBasedInt Conf.

  (** Monotone algebra instantiated to matrices *)
  Module Export MonotoneAlgebra <: MonotoneAlgebraType.

    Notation mint := (matrixInt dim).

    Lemma mi_eval_ok : forall f v,
      vec_invariant (mi_eval_aux (trsInt f) (Vmap dom2vec v)).

    Proof.
      compute. trivial.
    Qed.

    Definition I := MBI.I mi_eval_ok.

    Definition succeq := MBI.succeq.

    Definition refl_succeq := MBI.refl_succeq.
    Definition monotone_succeq := @MBI.monotone_succeq mi_eval_ok.
    Definition trans_succeq := MBI.trans_succeq.

    Definition succeq' := MBI.succeq'.
    Definition succeq'_sub := @MBI.succeq'_sub mi_eval_ok.
    Definition succeq'_dec := MBI.succeq'_dec.

    Definition Sig := sig.

    Definition succ_vec v1 v2 := v1 >=v v2 /\ vec_at0 v1 > vec_at0 v2.
    Definition succ := Rof succ_vec dom2vec.

    Lemma succ_wf : WF succ.

    Proof.
      apply WF_incl with (Rof gt (fun v : dom => vec_at0 (dom2vec v))).
      unfold succ, succ_vec, Rof, gt. intros x y. intuition.
      apply WF_inverse. apply gt_WF.
    Qed.

    Global Instance trans_succ : Transitive succ.

    Proof.
      apply Rof_trans. unfold succ_vec. intros v1 v2 v3 h12 h23. intuition.
      trans v2; hyp.
    Qed.

    Lemma succ_succeq_compat : absorbs_left succ succeq.

    Proof.
      intros x z xz. destruct xz as [y [xy yz]]. split.
      apply trans_succeq with y. hyp. destruct yz. hyp.
      apply ge_gt_compat with (Vnth (dom2vec y) dim_pos). unfold MBI.vec_at0.
      apply Vforall2_elim_nth. hyp.
      destruct yz. hyp.
    Qed.

    Lemma succ_dec : rel_dec succ.

    Proof.
      apply intersection_dec. apply succeq_dec. intros x y. apply gt_dec.
    Defined.

    Notation IR_succ := (IR I succ).

    Definition mint_gt n (l r : mint n) :=
      mint_ge l r /\ vec_at0 (const l) > vec_at0 (const r).

    Definition term_gt := MBI.term_gt mint_gt.

    Lemma vec_plus_gt_compat_l : forall vl vl' vr vr',
      vec_at0 vl >= vec_at0 vl' -> vec_at0 vr > vec_at0 vr' ->
      vec_at0 (vl [+] vr) > vec_at0 (vl' [+] vr').

    Proof.
      unfold MBI.vec_at0, vector_plus. intros. rewrite !Vnth_map2.
      unfold Aplus. apply plus_gt_compat_r; hyp.
    Qed.

    Lemma mint_eval_mon_succ : forall (val : valuation I) k
      (mi mi' : mint k), mint_gt mi mi' ->
      succ_vec (mint_eval val mi) (mint_eval val mi').

    Proof.
      intros. destruct H. split.
      apply mint_eval_mon_succeq. hyp.
      unfold mint_eval, add_vectors. simpl.
      apply vec_plus_gt_compat_l.
      unfold MBI.vec_at0. apply Vforall2_elim_nth.
      exact (mint_eval_mon_succeq_args _ H). hyp.
    Qed.

    Lemma term_gt_incl_succ : term_gt << IR_succ.

    Proof.
      intros l r lr v. destruct (mint_eval_equiv l r v). simpl in * .
      unfold succ, Rof, I, succ_vec. symmetry in H. symmetry in H0.
      rewrite (vec_ge_mor H H0), (Vforall2_elim_nth dim_pos H),
        (Vforall2_elim_nth dim_pos H0).
      change (succ_vec (mint_eval v
        (mi_of_term (ABterm.inject_term (Max.le_max_l (maxvar l) (maxvar r)))))
      (mint_eval v (mi_of_term
        (ABterm.inject_term (Max.le_max_r (maxvar l) (maxvar r)))))).
      apply mint_eval_mon_succ. hyp.
    Qed.

    Lemma mint_gt_dec : forall n, rel_dec (@mint_gt n).

    Proof.
      intro. apply intersection_dec. apply mint_ge_dec.
      intros x y. apply gt_dec.
    Defined.

    Definition succ' := term_gt.
    Definition succ'_sub := term_gt_incl_succ.
    Definition succ'_dec := term_gt_dec mint_gt mint_gt_dec.

    Section ExtendedMonotoneAlgebra.

      Section VecMonotonicity.

        Lemma vec_plus_gt_compat_r : forall vl vl' vr vr',
          vec_at0 vl > vec_at0 vl' -> vec_at0 vr >= vec_at0 vr' ->
          vec_at0 (vl [+] vr) > vec_at0 (vl' [+] vr').

        Proof.
          unfold MBI.vec_at0, vector_plus. intros.
          simpl. rewrite !Vnth_map2.
          unfold Aplus, Peano.gt. apply plus_gt_compat_l; hyp.
        Qed.

        Variable f : matrix dim dim -> vec -> vec.
        Variable f_mon : forall M v1 v2, get_elem M dim_pos dim_pos > 0 ->
          v1 >=v v2 -> vec_at0 v1 > vec_at0 v2 ->
          vec_at0 (f M v1) > vec_at0 (f M v2).

        Variables (a b : vec).

        Lemma vec_add_monotone_map2 : forall n1 (v1 : vector vec n1) n2
          (v2 : vector vec n2)  n (M : vector (matrix dim dim) n) i_j,
          Vforall (fun m => get_elem m dim_pos dim_pos > 0) M ->
          a >=v b -> vec_at0 a > vec_at0 b ->
          vec_at0 (add_vectors
            (Vmap2 f M (Vcast (Vapp v1 (Vcons a v2)) i_j))) >
          vec_at0 (add_vectors
            (Vmap2 f M (Vcast (Vapp v1 (Vcons b v2)) i_j))).

        Proof.
          induction v1; intros; simpl.
          destruct n. lia.
          rewrite !Vcast_cons.
          unfold add_vectors, MBI.vec_at0, vector_plus. simpl.
          rewrite !Vnth_map2.
          unfold Aplus. apply plus_gt_compat_r. apply eq_ge_compat. refl.
          unfold MBI.vec_at0 in f_mon. apply f_mon; try hyp.
          apply (Vforall_in (x:=Vhead M) H). apply Vin_head.

          destruct n0. lia.
          rewrite !Vcast_cons.
          unfold add_vectors, MBI.vec_at0, vector_plus. simpl.
          rewrite !Vnth_map2.
          unfold Aplus. apply plus_gt_compat_l. 2: apply eq_ge_compat; refl.
          match goal with |- ?Hl > ?Hr => fold (Hr > Hl) end.
          unfold MBI.vec_at0, add_vectors in IHv1.
          apply IHv1; try hyp.
          apply Vforall_incl with (S n0) M.
          intros. VSntac M. simpl. auto.
          hyp.
        Qed.

      End VecMonotonicity.

      Lemma dot_product_mon_r : forall i j (jp : (j < i)%nat)
        (v v' w w' : vector nat i),
        v >=v v' -> w >=v w' -> Vnth v jp > A0 ->
        Vnth w jp > Vnth w' jp ->
        dot_product v w > dot_product v' w'.

      Proof.
        intros i j. gen i. clear i.
        induction j; intros.
        destruct i. lia.
        VSntac v. VSntac w. VSntac v'. VSntac w'.
        unfold dot_product. simpl.
        fold (dot_product (Vtail v') (Vtail w')).
        fold (dot_product (Vtail v) (Vtail w)).
        unfold Aplus, Peano.gt. apply plus_gt_compat_r.
        apply dot_product_mon; apply Vforall2_tail; hyp.
        rewrite !Vhead_nth. apply mult_lt_compat_lr.
        apply (Vforall2_elim_nth (R:=ge)). hyp.
        rewrite (lt_unique (lt_O_Sn i) jp). hyp.
        rewrite (lt_unique (lt_O_Sn i) jp). hyp.
        destruct i. lia.
        VSntac v. VSntac w. VSntac v'. VSntac w'.
        unfold dot_product. simpl.
        fold (dot_product (Vtail v') (Vtail w')).
        fold (dot_product (Vtail v) (Vtail w)).
        unfold Aplus, Peano.gt. apply plus_gt_compat_l.
        apply IHj with (lt_S_n jp).
        apply Vforall2_tail. hyp.
        apply Vforall2_tail. hyp.
        rewrite Vnth_tail, lt_nS_Sn. hyp.
        rewrite !Vnth_tail, lt_nS_Sn. hyp.
        apply mult_le_compat.
        rewrite !Vhead_nth. apply (Vforall2_elim_nth (R:=ge)). hyp.
        rewrite !Vhead_nth. apply (Vforall2_elim_nth (R:=ge)). hyp.
      Qed.

      (* additional property of interpretation required to ensure strict
         monotonicity of interpretations: upper left corner of every matrix
         needs to be positive *)
      Definition monotone_interpretation n (fi : matrixInt dim n) :=
        Vforall (fun m => get_elem m dim_pos dim_pos > 0) (args fi).

      Definition bmonotone_interpretation n (fi : matrixInt dim n) :=
        bVforall (fun m => bgt_nat (get_elem m dim_pos dim_pos) 0) (args fi).

      Lemma bmonotone_interpretation_ok : forall n (fi : matrixInt dim n),
        bmonotone_interpretation fi = true <-> monotone_interpretation fi.

      Proof.
        intros. apply bVforall_ok. intro. apply bgt_nat_ok.
      Qed.

      Lemma monotone_succ :
        (forall f : sig, monotone_interpretation (trsInt f)) ->
        monotone I succ.

      Proof.
        intros H f i j i_j vi vj a b ab. split.
        apply monotone_succeq. destruct ab. hyp.
        simpl. unfold mi_eval_aux. apply vec_plus_gt_compat_r.
        rewrite !Vmap_cast, !Vmap_app. simpl.
        apply vec_add_monotone_map2; try solve [destruct ab; hyp].
        intros. unfold MBI.vec_at0. unfold mat_vec_prod.
        rewrite !Vnth_col_mat, !mat_mult_spec.
        apply dot_product_mon_r with 0%nat dim_pos.
        unfold ge. apply Vforall2_intro_nth. intros. apply le_refl.
        unfold ge. apply Vforall2_intro_nth. intros.
        rewrite !get_col_col_mat. destruct ab.
        apply Vforall2_elim_nth. hyp.
        hyp.
        rewrite !get_col_col_mat. hyp.
        apply H. apply le_refl.
      Qed.

      Import List ListUtil.

      Section fin_Sig.

        Variable Fs : list Sig.
        Variable Fs_ok : forall f : Sig, In f Fs.

        Lemma fin_monotone_succ :
          forallb (fun f => bmonotone_interpretation (trsInt f)) Fs = true ->
          monotone I succ.

        Proof.
          intro H. apply monotone_succ. intro f.
          rewrite <- bmonotone_interpretation_ok.
          rewrite forallb_forall in H. apply H. apply Fs_ok.
        Qed.

      End fin_Sig.

    End ExtendedMonotoneAlgebra.

  End MonotoneAlgebra.

  Arguments fin_monotone_succ [Fs] _ _ _ _ _ _ _ _ _ _ _.

  Ltac prove_cc_succ Fs_ok :=
    apply IR_context_closed; apply (fin_monotone_succ Fs_ok);
      (check_eq || fail 10
         "could not prove the monotony of this matrix interpretation").

End MatrixInt.


(* 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.