From hahn Require Import Hahn.
Require Import Setoid.

Set Implicit Arguments.

(******************************************************************************)
(** ** ifthenelse  *)
(******************************************************************************)

Definition ifthenelse T K L (c : {K} + {L}) (x y : T) :=
  if c then x else y.

Definition ifthenelse_b T (c : bool) (x y : T) :=
  if c then x else y.

Add Parametric Morphism {A} (K : Prop) (L : Prop) (c : {K} + {L}) :
  (@ifthenelse (A -> Prop) K L c) with signature
    set_equiv ==>
    set_equiv ==>
    set_equiv as ifthenelse_more.
Proof using. intros; unfold ifthenelse; desf. Qed.

Add Parametric Morphism {A} (c : bool) :
  (@ifthenelse_b (A -> Prop) c) with signature
    set_equiv ==>
    set_equiv ==>
    set_equiv as ifthenelse_b_more.
Proof using. intros; unfold ifthenelse_b; desf. Qed.

Lemma ite_alt {A} K L (c : {K} + {L}) (x y : A -> Prop) :
  (if c then x else y) ≡₁ ifthenelse c x y.
Proof using. rels. Qed.

Lemma iteb_alt {A} (c : bool) (x y : A -> Prop) :
  (if c then x else y) ≡₁ ifthenelse_b c x y.
Proof using. rels. Qed.

Lemma ite_union_t {A} K L (c : {K} + {L}) (x y z : A -> Prop) :
  ifthenelse c (x ∪₁ y) z ≡₁ ifthenelse c x z ∪₁ ifthenelse c y z.
Proof using. by rewrite <- !ite_alt; destruct c; [|rewrite set_unionK]. Qed.


Require Export PredMonad.CtxFuns.OrderedType.
Require Export PredMonad.CtxFuns.OFuns.

(***
 *** Ordered Type Contexts
 ***)

(* A context here is just a list of type expressions *)
Inductive Ctx : Type :=
| CNil
| CCons (ctx:Ctx) A {RA:OType A}
.

Notation "ctx :> A" := (CCons ctx A) (left associativity, at level 50).

(* An element of a context is a nested tuple of elements of its types *)
Fixpoint CtxElem (ctx:Ctx) : Type :=
  match ctx with
  | CNil => unit
  | ctx' :> A => CtxElem ctx' * A
  end.

(* OTRelation instance for any CtxElem type *)
Instance OType_CtxElem ctx : OType (CtxElem ctx).
Proof.
  induction ctx; typeclasses eauto.
Defined.

(* Typeclasses Transparent OType_CtxElem. *)

Definition ctxHead ctx : Type :=
  match ctx with
  | CNil => unit
  | CCons _ A => A
  end.

Instance OType_ctxHead ctx : OType (ctxHead ctx) :=
  match ctx with
  | CNil => OTunit
  | @CCons _ _ RA => RA
  end.

Definition ctxTail ctx :=
  match ctx with
  | CNil => CNil
  | ctx' :> _ => ctx'
  end.

(***
 *** Ordered Expressions and Variables
 ***)

(* An ordered expression in ctx is just a Proper function from ctx *)
Definition OExpr ctx A `{OType A} : Type := CtxElem ctx -o> A.

Arguments OExpr ctx A {_} : simpl never.

(* Low-level lambda (we use "ofun", below, to give a nice high-level lambda) *)
(* Notation "'olambda' e" := (ofun_curry e) (at level 99, right associativity). *)

Inductive OVar : Ctx -> forall A `{OType A}, Type :=
| OVar_0 {ctx A} `{OType A} : OVar (ctx :> A) A
| OVar_S {ctx B A} `{OType A} `{OType B} (v: OVar ctx A) : OVar (ctx :> B) A
.

(* The last-bound variable in a context *)
Definition var_top {ctx A} `{OType A} : OExpr (ctx :> A) A :=
  {| ofun_app := snd; ofun_Proper := _ |}.

(* Weaken an OExpr by adding a type to the context *)
Definition weaken1 {ctx A B} `{OType A} `{OType B}
           (e: OExpr ctx A) : OExpr (ctx :> B) A :=
  compose_ofun fst_ofun e.

Fixpoint varSemantics {ctx A} `{OType A} (v:OVar ctx A) : OExpr ctx A :=
  match v in OVar ctx' A' return OExpr ctx' A' with
  | OVar_0 => var_top
  | OVar_S v => weaken1 (varSemantics v)
  end.

Coercion varSemantics : OVar >-> OExpr.

(***
 *** Weakening
 ***)

(* Inductive proof that ctx1 can be weakened to ctx2 *)
Inductive weakensTo ctx1 : Ctx -> Type :=
| WeakensRefl : weakensTo ctx1 ctx1
| WeakensCons {ctx2} (w: weakensTo ctx1 ctx2) A `{OType A}  :
    weakensTo ctx1 (ctx2 :> A)
.

Arguments WeakensRefl {_}.
Arguments WeakensCons {_ _} w A {_}.

(* Typeclass version of the above *)
Class WeakensTo ctx1 ctx2 : Type :=
  weakensProof : weakensTo ctx1 ctx2.

Instance WeakensTo_refl ctx : WeakensTo ctx ctx := WeakensRefl.

Instance WeakensTo_cons ctx1 ctx2 A `{OType A} (w: WeakensTo ctx1 ctx2) :
  WeakensTo ctx1 (ctx2 :> A) :=
  WeakensCons w A.

(* Weaken a context by mapping backwardds from the weaker to the stronger one *)
Fixpoint weakenContext {ctx1 ctx2} (w: weakensTo ctx1 ctx2) :
  CtxElem ctx2 -o> CtxElem ctx1 :=
  match w in weakensTo _ ctx2 return CtxElem ctx2 -o> CtxElem ctx1 with
  | WeakensRefl => id_ofun
  | WeakensCons w' _ => compose_ofun fst_ofun (weakenContext w')
  end.

(* Weakening for OExprs *)
Definition weakenExpr {ctx1 ctx2} `{w: WeakensTo ctx1 ctx2} {A} `{OType A}
           (e: OExpr ctx1 A) : OExpr ctx2 A :=
  compose_ofun (weakenContext w) e.

Instance Proper_weakenExpr {ctx1 ctx2} `{w: WeakensTo ctx1 ctx2} {A} `{OType A} :
  Proper (oleq ==> oleq) (weakenExpr (w:=w) (A:=A)).
Proof.
  intros e1 e2 Re. apply Proper_compose_ofun; [ reflexivity | assumption ].
Qed.

(* Weakening for variables *)
Fixpoint weakenVar_h {ctx1 ctx2} (w: weakensTo ctx1 ctx2) :
  forall {A} `{OType A}, OVar ctx1 A -> OVar ctx2 A :=
  match w in weakensTo _ ctx2
        return forall {A} `{OType A}, OVar ctx1 A -> OVar ctx2 A
  with
  | WeakensRefl => fun _ _ v => v
  | WeakensCons w' _ => fun _ _ v => OVar_S (weakenVar_h w' v)
  end.

Definition weakenVar {ctx1 ctx2} `{w:WeakensTo ctx1 ctx2} {A} `{OType A}
           (v:OVar ctx1 A) : OVar ctx2 A :=
  weakenVar_h w v.

(* Weakening is the same whether we do it before or after varSemantics *)
Lemma weakenVar_weakenExpr {ctx1 ctx2} `{w:WeakensTo ctx1 ctx2} {A} `{OType A}
      (v:OVar ctx1 A) : weakenExpr (w:=w) v =o= weakenVar v.
Proof.
  revert v; induction w; intro v; simpl.
  { apply id_compose_ofun. }
  { unfold weaken1. rewrite <- IHw. unfold weakenExpr. simpl.
    rewrite compose_compose_ofun. reflexivity. }
Qed.

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

(* A substitution for a single variable in a ctx *)
Fixpoint CtxSubst ctx : Type :=
  match ctx with
  | CNil => False
  | ctx' :> A => CtxSubst ctx' + OExpr ctx' A
  end.

(* The output context of a substitution *)
Fixpoint CtxSubstCtx {ctx} : CtxSubst ctx -> Ctx :=
  match ctx return CtxSubst ctx -> Ctx with
  | CNil => fun empty => match empty with end
  | ctx' :> A => fun subst_or_expr =>
                   match subst_or_expr with
                   | inl subst' => CtxSubstCtx subst' :> A
                   | inr _ => ctx'
                   end
  end.

(* The output type of a substitution *)
Fixpoint CtxSubstType {ctx} : CtxSubst ctx -> Type :=
  match ctx return CtxSubst ctx -> Type with
  | CNil => fun empty => match empty with end
  | ctx' :> A => fun subst_or_expr =>
                   match subst_or_expr with
                   | inl subst' => CtxSubstType subst'
                   | inr _ => A
                   end
  end.

Fixpoint CtxSubstOType {ctx} : forall s, OType (@CtxSubstType ctx s) :=
  match ctx return forall s, OType (@CtxSubstType ctx s) with
  | CNil => fun empty => match empty with end
  | ctx' :> A => fun subst_or_expr =>
                   match subst_or_expr with
                   | inl subst' => CtxSubstOType subst'
                   | inr _ => _
                   end
  end.

Instance OType_CtxSubstType ctx s : OType (@CtxSubstType ctx s) :=
  CtxSubstOType s.

(* Use a substitution like a mapping *)
Fixpoint substContext {ctx} :
  forall (s: CtxSubst ctx), CtxElem (CtxSubstCtx s) -o> CtxElem ctx :=
  match ctx return forall (s: CtxSubst ctx), CtxElem (CtxSubstCtx s) -o>
                                             CtxElem ctx
  with
  | CNil => fun empty => match empty with end
  | ctx' :> A =>
    fun s =>
      match s return CtxElem (@CtxSubstCtx (_ :> _) s) -o> CtxElem (_ :> _) with
      | inl s' => pair_ofun (compose_ofun fst_ofun (substContext s')) snd_ofun
      | inr e => pair_ofun id_ofun e
      end
  end.

Definition substExpr {ctx A} `{OType A} (e: OExpr ctx A) (s: CtxSubst ctx) :
  OExpr (CtxSubstCtx s) A :=
  compose_ofun (substContext s) e.

(* The result of looking up a variable in a substitution; see substVarLookup *)
Inductive VarLookupRes ctx A `{OType A} (s:CtxSubst ctx) : Type :=
| mkVarLookupRes ctx' (w: weakensTo ctx' (CtxSubstCtx s))
                 (v_or_e: OVar ctx' A + OExpr ctx' A) :
    VarLookupRes ctx A s.

(* Weaken a VarLookupRes *)
Definition weakenVarLookupRes {ctx A B} `{OType A} `{OType B} {s}
           (res: VarLookupRes ctx A s) :
  VarLookupRes (ctx :> B) A (inl s) :=
  match res with
  | mkVarLookupRes _ _ _ ctx' w v_or_e =>
    mkVarLookupRes (_:>_) A (inl s) ctx' (WeakensCons w B) v_or_e
  end.

(* Look up a variable in a substitution, getting either an OExpr or a
strengthened variable. We existentially quantify over the returned context so
that we can do one combined weakening, either of the returned variable or oexpr,
rather than having N weakening steps *)
Program Fixpoint substVarLookup {ctx A} `{OType A} (v: OVar ctx A) :
  forall (s:CtxSubst ctx), VarLookupRes ctx A s :=
  match v in OVar ctx A return forall s, VarLookupRes ctx A s with
  | OVar_0 =>
    fun (s: CtxSubst (_ :> _)) =>
      match s return VarLookupRes (_:>_) _ s
      with
      | inl s' =>
        mkVarLookupRes (_:>_) _ (inl s') _ WeakensRefl (inl OVar_0)
      | inr e =>
        mkVarLookupRes (_:>_) _ (inr e) _ WeakensRefl (inr e)
      end
  | OVar_S v' =>
    fun (s: CtxSubst (_:>_)) =>
      match s return VarLookupRes (_:>_) _ s with
      | inl s' =>
        weakenVarLookupRes (substVarLookup v' s')
      | inr e =>
        mkVarLookupRes (_:>_) _ (inr e) _ WeakensRefl (inl v')
      end
  end.

(* Substitute into a variable *)
Definition substVar {ctx A} `{OType A} (v: OVar ctx A) (s:CtxSubst ctx) :
  OExpr (CtxSubstCtx s) A :=
  match substVarLookup v s with
  | mkVarLookupRes _ _ _ ctx' w (inl v') => weakenVar_h w v'
  | mkVarLookupRes _ _ _ ctx' w (inr e) => weakenExpr (w:=w) e
  end.

(* Substitution is the same whether we do it before or after varSemantics *)
Lemma substVar_substExpr {ctx} {A} `{OType A} (v: OVar ctx A)
      (s: CtxSubst ctx) : substExpr v s =o= substVar v s.
Proof.
  revert s; induction v; intro s; unfold substExpr.
  { destruct s as [ s | e ]; simpl; apply funOExt; intro c; reflexivity. }
  { destruct s as [ s | e ]; simpl; apply funOExt; intro c; [ | reflexivity ].
    simpl.
    assert ((substVar (OVar_S v) (inl s)) = weakenExpr (substVar v s)).
    - unfold substVar. simpl. destruct (substVarLookup v s); simpl.
      destruct v_or_e; admit.
    - rewrite H1. rewrite <- IHv. reflexivity. }
Admitted.

(***
 *** Notation for Application
 ***)

(* FIXME: weaken both sides to a join of their respective contexts! *)
Definition oexpr_apply {ctx A B} `{OType A} `{OType B}
           (f: OExpr ctx (A -o> B)) (g: OExpr ctx A) : OExpr ctx B :=
  ofun_apply f g.

(* Application *)
Notation "x @o@ y" :=
  (oexpr_apply x y) (left associativity, at level 20).

(***
 *** Notation for Lambdas
 ***)

Definition ovar {ctx A} `{OType A} {ctx'} `{w:WeakensTo ctx ctx'}
           (e:OExpr ctx A) : OExpr ctx' A := weakenExpr e.

(* Helper function to build lambdas *)
(*
Definition mkLam {ctx A B} `{OType A} `{OType B}
           (body : (forall {ctx'} `{WeakensTo (ctx :> A) ctx'}, OVar ctx' A) ->
                   OExpr (ctx :> A) B) :
  OExpr ctx (A -o> B) :=
  ofun_curry (body (fun _ _ => weakenVar OVar_0)).
 *)

Definition mkLam {ctx A B} `{OType A} `{OType B}
           (body : OVar (ctx :> A) A -> OExpr (ctx :> A) B) :
  OExpr ctx (A -o> B) := ofun_curry (body OVar_0).

Notation "'ofun' x => e" :=
  (mkLam (fun x => e))
    (right associativity, at level 99).

Notation "'ofun' ( x : A ) => e" :=
  (mkLam (fun (x : OVar _ A) => e))
    (right associativity, at level 99, x at level 0).

(***
 *** Ordered Expressions for Pairs
 ***)

Definition opair {ctx A B} `{OType A} `{OType B} : OExpr ctx (A -o> B -o> A*B) :=
  const_ofun (ofun_curry id_ofun).
Definition ofst {ctx A B} `{OType A} `{OType B} : OExpr ctx (A * B -o> A) :=
  const_ofun fst_ofun.
Definition osnd {ctx A B} `{OType A} `{OType B} : OExpr ctx (A * B -o> B) :=
  const_ofun snd_ofun.

Notation "( x ,o, y )" := (opair @o@ x @o@ y : OExpr _ _) (at level 0).

Lemma ofst_opair {ctx A B} `{OType A} `{OType B}
      (e1: OExpr ctx A) (e2: OExpr ctx B) :
  ofst @o@ (e1 ,o, e2) =o= e1.
Proof.
  apply funOExt; intro c. reflexivity.
Qed.

Lemma osnd_opair {ctx A B} `{OType A} `{OType B}
      (e1: OExpr ctx A) (e2: OExpr ctx B) :
  osnd @o@ (e1 ,o, e2) =o= e2.
Proof.
  apply funOExt; intro c. reflexivity.
Qed.

Lemma opair_ext {ctx A B} `{OType A} `{OType B} (e: OExpr ctx (A*B)) :
  opair @o@ (ofst @o@ e) @o@ (osnd @o@ e) =o= e.
Proof.
  apply funOExt; intro c. simpl. destruct (ofun_app e c). reflexivity.
Qed.

(***
 *** Ordered Expressions for Sums
 ***)

Definition oinl {ctx A B} `{OType A} `{OType B} : OExpr ctx (A -o> A + B) :=
  const_ofun inl_ofun.
Definition oinr {ctx A B} `{OType A} `{OType B} : OExpr ctx (B -o> A + B) :=
  const_ofun inr_ofun.
Definition osumElim {ctx A B C} `{OType A} `{OType B} `{OType C} :
  OExpr ctx ((A -o> C) -o> (B -o> C) -o> A + B -o> C) :=
  const_ofun sum_elim_ofun.

Lemma osumElim_oinl {ctx A B C} `{OType A} `{OType B} `{OType C}
      (f1 : OExpr ctx (A -o> C)) (f2 : OExpr ctx (B -o> C)) e :
  osumElim @o@ f1 @o@ f2 @o@ (oinl @o@ e) =o= f1 @o@ e.
Proof.
  apply funOExt; intro c. reflexivity.
Qed.

Lemma osumElim_oinr {ctx A B C} `{OType A} `{OType B} `{OType C}
      (f1 : OExpr ctx (A -o> C)) (f2 : OExpr ctx (B -o> C)) e :
  osumElim @o@ f1 @o@ f2 @o@ (oinr @o@ e) =o= f2 @o@ e.
Proof.
  apply funOExt; intro c. reflexivity.
Qed.

(***
 *** Ordered Expressions for Propositions
 ***)

Definition oforall {ctx A} `{OType A} : OExpr ctx ((A -o> Prop) -o> Prop) :=
  const_ofun forall_ofun.
Definition oexists {ctx A} `{OType A} : OExpr ctx ((A -o> Prop) -o> Prop) :=
  const_ofun exists_ofun.
Definition oexists2 {ctx A} `{OType A} :
  OExpr ctx ((A -o> Prop) -o> (Flip A -o> Prop) -o> Prop) :=
  const_ofun exists2flip_ofun.
Definition oand {ctx} : OExpr ctx (Prop -o> Prop -o> Prop) :=
  const_ofun and_ofun.
Definition oor {ctx} : OExpr ctx (Prop -o> Prop -o> Prop) :=
  const_ofun or_ofun.
Definition oimpl {ctx} : OExpr ctx (Flip Prop -o> Prop -o> Prop) :=
  const_ofun impl_ofun.
Definition oappr {ctx A} `{OType A} : OExpr ctx (Flip A -o> A -o> Prop) :=
  const_ofun oleq_ofun.


Require Import Arith Nat Lia.

From CoqMTL Require Import Control.Monad.
From CoqMTL Require Import Control.Monad.All.

(** * Just do It: Simple Monadic Equational Reasoning *)

(** ** 1. Introduction *)

(** ** 2. Background *)

(** ** 3. A counter example: Towers of Hanoi *)

Set Implicit Arguments.

Section S0.

Variable M : Type -> Type.

Variable inst : Monad M.

Class MonadCount : Type :=
{
  tick : M unit;
}.

Definition skip : M unit := pure tt.

Fixpoint hanoi {inst' : MonadCount} (n : nat) : M unit :=
match n with
| 0 => skip
| S n' => hanoi n' >> tick >> hanoi n'
end.

Fixpoint rep (n : nat) (x : M unit) : M unit :=
match n with
| 0 => skip
| S n' => x >> rep n' x
end.

Lemma rep_constrA :
  forall (x : M unit) (n m : nat),
    rep (n + m) x = rep n x >> rep m x.
Proof.
  induction n as [| n']; cbn; intros.
    unfold skip. rewrite constrA_spec. rewrite bind_pure_l. reflexivity.
    rewrite IHn'. rewrite constrA_assoc. reflexivity.
Qed.

Lemma rep1 :
  forall x : M unit, rep 1 x = x.
Proof.
  intros. cbn. unfold skip, constrA, compose. monad.
Qed.

Theorem hanoi_rep :
  forall (inst' : MonadCount) (n : nat),
    hanoi n = rep (2 ^ n - 1) tick.
Proof.
  induction n as [| n']; cbn; try reflexivity.
  rewrite IHn'. rewrite <- (rep1 tick) at 2.
  rewrite <- !rep_constrA, <- plus_n_O. rewrite !Nat.sub_1_r. f_equal.
  induction n' as [| n'']; cbn.
    reflexivity.
    erewrite (Nat.lt_succ_pred 0).
      lia.
      clear. induction n'' as [| n''']; cbn; lia.
Qed.

(** ** 4. Nondeterministic computations *)

(** *** 4.1 Failure *)

Class MonadFail : Type :=
{
  fail : forall {A :  Type}, M A;
  constrA_fail_l :
    forall (A B : Type) (mb : M B),
      @fail A >> mb = @fail B;
  (** BEWARE! This law is custom, not from the paper. *)
  bind_fail_l :
    forall (A B : Type) (f : A -> M B),
      fail >>= f = fail
}.

Hint Rewrite @constrA_fail_l : CoqMTL.

Definition guard {inst' : MonadFail} (b : bool) : M unit :=
  if b then skip else fail.

Definition assert
  {inst' : MonadFail} {A : Type} (p : A -> bool) (ma : M A) : M A :=
  do
    a <- ma;
    guard (p a);;
    pure a.

(** *** 4.2 Choice *)

Class MonadAlt : Type :=
{
  choose : forall {A : Type}, M A -> M A -> M A;
  choose_assoc :
    forall {X : Type} (a b c : M X),
      choose (choose a b) c = choose a (choose b c);
  choose_bind :
    forall (A B : Type) (x y : M A) (f : A -> M B),
      choose x y >>= f = choose (x >>= f) (y >>= f);
}.

(** *** 4.3 Nondeterminism *)

Class MonadNondet : Type :=
{
  instF :> MonadFail;
  instA :> MonadAlt;
  choose_fail_l :
    forall (A : Type) (x : M A),
      choose fail x = x;
  choose_fail_r :
    forall (A : Type) (x : M A),
      choose x fail = x;
}.

Coercion instF : MonadNondet >-> MonadFail.
Coercion instA : MonadNondet >-> MonadAlt.

End S0.

#[refine]
#[export]
Instance MonadFail_List : MonadFail Monad_List :=
{
  fail := @nil
}.
Proof.
  all: compute; reflexivity.
Defined.

#[refine]
#[export]
Instance MonadAlt_List : MonadAlt Monad_List :=
{
  choose := @app;
}.
Proof.
  all: intros.
    rewrite app_assoc. reflexivity.
    cbn. apply bind_List_app.
Defined.

#[refine]
#[export]
Instance MonadNondet_List : MonadNondet Monad_List :=
{
  instF := MonadFail_List;
  instA := MonadAlt_List;
}.
Proof.
  all: cbn; intros.
    reflexivity.
    rewrite app_nil_r. reflexivity.
Defined.

Arguments fail {M inst MonadFail A}.
Arguments choose {M inst MonadAlt A} _ _.

Section S1.

Variable M : Type -> Type.
Variable inst : Monad M.

Fixpoint select
  {inst' : MonadNondet inst} {A : Type} (l : list A) : M (A * list A) :=
match l with
| [] => fail
| x :: xs =>
    choose (pure (x, xs)) $ do
      p <- select xs;
      let '(y, ys) := p in
        pure (y, x :: ys)
end.

Fixpoint perms' (n : nat)
  {inst' : MonadNondet inst} {A : Type} (l : list A) : M (list A) :=
match n, l with
| 0, _ => fail
| _, [] => pure []
| S n', _ => do
    p <- select l;
    let '(h, t) := p in
    rest <- perms' n' t;
    pure (h :: rest)
end.

Definition perms
  {inst' : MonadNondet inst} {A : Type} (l : list A) : M (list A) :=
    perms' (S (length l)) l.

End S1.

(* TODO: commented out *)

(*
Compute select [1; 2; 3].

Compute perms [1; 2; 3].
*)

(** ** 5. Exceptional computations *)

Section S2.

Variable M : Type -> Type.
Variable inst : Monad M.

(** [catch] and [fail] form a monoid. Pure computations need no handler. *)
Class MonadExcept
  (inst' : MonadFail inst) : Type :=
{
  catch : forall {A : Type}, M A -> M A -> M A;
  catch_fail_l :
    forall (A : Type) (x : M A),
      catch fail x = x;
  catch_fail_r :
    forall (A : Type) (x : M A),
      catch x fail = x;
  catch_assoc :
    forall (A : Type) (x y z : M A),
      catch (catch x y) z = catch x (catch y z);
  catch_pure :
    forall (A : Type) (x : A) (h : M A),
      catch (pure x) h = pure x;
}.

Hint Rewrite @catch_fail_l @catch_fail_r @catch_assoc @catch_pure : CoqMTL.

(*
Lemma product_In_0 :
  forall l : list nat,
    In 0 l -> product l = 0.
Proof.
  induction l as [| h t]; cbn; destruct 1; subst.
    reflexivity.
    rewrite IHt; auto.
Qed.
*)

Fixpoint product (l : list nat) : nat :=
match l with
| [] => 1
| h :: t => h * product t
end.

Fixpoint has (n : nat) (l : list nat) : bool :=
match l with
| [] => false
| h :: t => Nat.eqb n h || has n t
end.

Lemma product_has_0 :
  forall l : list nat,
    has 0 l = true -> product l = 0.
Proof.
  induction l as [| h t]; cbn; intros.
    congruence.
    destruct h as [| h'].
      reflexivity.
      rewrite IHt; auto.
Qed.

Definition work
  {inst' : MonadFail inst} (l : list nat) : M nat :=
    if has 0 l then fail else pure (product l).

Definition fastprod
  {inst' : MonadFail inst} {inst'' : MonadExcept inst'}
    (l : list nat) : M nat := catch (work l) (pure 0).

Theorem fastprod_spec :
  forall
    (inst' : MonadFail inst) (inst'' : MonadExcept inst')
    (l : list nat),
      fastprod l = pure (product l).
Proof.
  unfold fastprod, work; intros.
  case_eq (has 0 l); intros.
    rewrite catch_fail_l, product_has_0.
      reflexivity.
      assumption.
    rewrite catch_pure. reflexivity.
Qed.

Definition next
  {inst' : MonadFail inst} (n : nat) (ml : M nat) : M nat :=
    if Nat.eqb 0 n then fail else fmap (mult n) ml.

Theorem work_foldr :
  forall (inst' : MonadFail inst),
    work = fold_right next (pure 1).
Proof.
  intros. ext l. induction l as [| h t]; cbn.
    reflexivity.
    unfold work in *. cbn. destruct h as [| h']; cbn.
      reflexivity.
      case_eq (has 0 t); intros.
        rewrite H in *. rewrite <- IHt. rewrite fmap_bind_pure.
          rewrite bind_fail_l. reflexivity.
        rewrite H in *. rewrite <- IHt. rewrite fmap_pure. reflexivity.
Qed.

Fixpoint hasE
  {inst' : MonadFail inst} (*{inst'' : MonadExcept inst'}*)
  (n : nat) (l : list nat) : M unit :=
match l with
| [] => pure tt
| h :: t => if Nat.eqb n h then fail else hasE n t
end.

Definition fastprod'
  {inst' : MonadFail inst} {inst'' : MonadExcept inst'}
  (l : list nat) : M nat :=
    catch (hasE 0 l >> pure (product l)) (pure 0).

Lemma aux :
  forall (inst' : MonadFail inst) (inst'' : MonadExcept inst')
  (n m : nat) (l : list nat),
    catch (hasE 0 l >> pure n) (pure m) =
    if has 0 l then pure m else pure n.
Proof.
  induction l as [| h t]; cbn in *; intros.
    rewrite constrA_spec. monad.
    destruct h as [| h'].
      rewrite constrA_fail_l, catch_fail_l. cbn. reflexivity.
      rewrite IHt. cbn. reflexivity.
Qed.

Theorem fastprod'_spec :
  forall (inst' : MonadFail inst) (inst'' : MonadExcept inst') (l : list nat),
    fastprod' l = pure (product l).
Proof.
  intros. unfold fastprod'. rewrite aux.
  case_eq (has 0 l); intros.
    rewrite product_has_0; auto.
    reflexivity.
Qed.

End S2.

(** ** 6. Stateful computations *)

Arguments skip {M inst}.

Class MonadState
  (S : Type) (M : Type -> Type) (inst : Monad M) : Type :=
{
  get : M S;
  put : S -> M unit;
  put_put :
    forall s s' : S,
      put s >> put s' = put s';
  put_get :
    forall s : S,
      put s >> get = put s >> pure s;
  get_put :
    get >>= put = skip; (* skip = pure tt *)
  get_get :
    forall (A : Type) (f : S -> S -> M A),
      get >>= (fun s : S => get >>= f s) =
      get >>= (fun s : S => f s s);
}.

(** ** 7. Combining effects *)

Class MonadStateNondet
  (S : Type) (M : Type -> Type) (inst : Monad M) : Type :=
{
  instS :> MonadState S inst;
  instN :> MonadNondet inst;
  seq_fail_r :
    forall (A B : Type) (x : M A),
      x >> fail = @fail M inst instN B;
  bind_choose_distr :
    forall (A B : Type) (f g : A -> M B) (ma : M A),
      ma >>= (fun x : A => choose (f x) (g x)) =
      choose (ma >>= f) (ma >>= g)
}.

Section S3.

Variable M : Type -> Type.
Variable inst : Monad M.

Lemma guard_seq_bind :
  forall (S : Type) (inst' : MonadStateNondet S inst) (A : Type)
  (b : bool) (ma : M A),
    guard b >> ma = ma >>= fun a : A => guard b >> pure a.
Proof.
  intros. unfold guard. destruct b.
    unfold skip, constrA. unfold compose. monad.
    rewrite constrA_fail_l. rewrite <- (seq_fail_r _ _ ma).
      rewrite constrA_spec. f_equal. ext a. rewrite constrA_fail_l.
        reflexivity.
Qed.

End S3.

(** ** 8. Probabilistic computations *)

Section S4.

Axiom (Prob : Type).
Axiom p0 : Prob.
Axiom p1 : Prob.
Axiom neg : Prob -> Prob.
Axiom mul : Prob -> Prob -> Prob.

Class MonadProb_no_laws
  (M : Type -> Type) (inst : Monad M) : Type :=
{
  choice : forall {A : Type}, Prob -> M A -> M A -> M A;
}.

Notation "x <| p |> y" := (choice p x y)
  (left associativity, at level 5).

Class MonadProb
  (M : Type -> Type) (inst : Monad M) : Type :=
{
  instP :> MonadProb_no_laws inst;
  choice_p0 :
    forall (A : Type) (x y : M A),
      x <| p0 |> y = x;
  choice_p1 :
    forall (A : Type) (x y : M A),
      x <| p1 |> y = y;
  choice_qcomm :
    forall (A : Type) (x y : M A) (p : Prob),
      x <| p |> y = y <| neg p |> x;
  choice_idempotent :
    forall (A : Type) (x : M A) (p : Prob),
      x <| p |> x = x;
  choice_qassoc :
    forall (A : Type) (x y z : M A) (p q r s : Prob),
      p = mul r s -> neg s = mul (neg p) (neg q) ->
        x <| p |> (y <| q |> z) =
        (x <| r |> y) <| s |> z;
  bind_choice :
    forall (A B : Type) (p : Prob) (x y : M A) (f : A -> M B),
      (x <| p |> y) >>= f = (x >>= f) <| p |> (y >>= f);
  choice_bind :
    forall (A B : Type) (p : Prob) (ma : M A) (f g : A -> M B),
      ma >>= (fun x : A => (f x) <| p |> (g x)) =
      (ma >>= f) <| p |> (ma >>= g)
}.

End S4.


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

(** Author: Bruno Barras *)

Require Import Relation_Definitions.
Require Import Relation_Operators.

Section Wf_Transitive_Closure.
  Variable A : Type.
  Variable R : relation A.

  Notation trans_clos := (clos_trans A R).

  Lemma incl_clos_trans : inclusion A R trans_clos.
    red; auto with sets.
  Qed.

  Lemma Acc_clos_trans : forall x:A, Acc R x -> Acc trans_clos x.
    induction 1 as [x0 _ H1].
    apply Acc_intro.
    intros y H2.
    induction H2; auto with sets.
    apply Acc_inv with y; auto with sets.
  Defined.

  Hint Resolve Acc_clos_trans.

  Lemma Acc_inv_trans : forall x y:A, trans_clos y x -> Acc R x -> Acc R y.
  Proof.
    induction 1 as [| x y]; auto with sets.
    intro; apply Acc_inv with y; assumption.
  Qed.

  Theorem wf_clos_trans : well_founded R -> well_founded trans_clos.
  Proof.
    unfold well_founded; auto with sets.
  Defined.

End Wf_Transitive_Closure.


Require Import Logic_and_Set_Theory.
From Coq Require Import Sets.Ensembles.
From Coq Require Import Sets.Powerset_facts.
From Coq Require Import Bool.
From Coq Require Import Constructive_sets.

Lemma Oral: forall (f1 f2 : bool),
(orb f1 f2) = true <-> (f1 = false -> f2 = true) \/ (f2 = false -> f1 = true) \/ ( f1=true /\ f2=true ).
Proof.
Admitted.
Lemma Classic_or : forall (f1 f2: bool),
(orb f1 f2) = true <-> (f1 = true /\ f2 = false) \/ (f2 = true /\ f1 = false) \/ (f1 = true /\ f2 = true).
Proof. split.
-intros H. destruct f1. destruct f2.
+right. right. split. ++reflexivity. ++reflexivity.
+left. split. ++reflexivity. ++reflexivity.
+right. left. split. ++apply orb_true_iff in H. destruct H. +++discriminate. +++apply H. ++reflexivity.
-destruct f1. destruct f2.
+intros H. simpl. reflexivity.
+intros H. simpl. reflexivity.
+intros H. destruct H. ++destruct H. discriminate. ++ destruct H. +++destruct H. rewrite -> H.
simpl. reflexivity. +++destruct H. discriminate.
Qed.

Theorem Soundness: forall (Gamma:Ensemble Formula) (f:Formula) ,
ND Gamma f -> sfSf Gamma f.
Proof.

    intros Gamma f H.
    unfold sfSf.
    intros model H1.
    induction H.
    +apply H1. apply H.
    +apply IHND in H1. simpl in H1. apply andb_true_iff in H1. apply H1.
    +apply IHND in H1. simpl in H1. apply andb_true_iff in H1. apply H1.
    +assert (H2: mSsf model C). -apply H1. -apply IHND1 in H1. apply IHND2 in H2.
    simpl. apply andb_true_iff. split. --apply H1. --apply H2.
    +assert (H1':mSsf model C). -apply H1.
    -apply IHND3 in H1. simpl in H1. apply orb_true_iff in H1. destruct H1.
    --apply IHND1. unfold mSsf. intros f0. unfold mSsf in IHND1. unfold mSsf in H1'.
    intros H3. apply Union_inv in H3. destruct H3. ---apply H1'. apply H3.
    ---apply Singleton_inv in H3. rewrite <- H3. apply H1.
    --apply IHND2. unfold mSsf. intros f0. unfold mSsf in IHND1. unfold mSsf in H1'.
    intros H3. apply Union_inv in H3. destruct H3. ---apply H1'. apply H3.
    ---apply Singleton_inv in H3. rewrite <- H3. apply H1.
    +simpl. apply orb_true_iff. left. apply IHND. apply H1.
    +simpl. apply orb_true_iff. right. apply IHND. apply H1.
    +assert (H2:mSsf model C). -apply H1. -apply IHND1 in H1. apply IHND2 in H2.
    simpl in H1.  apply orb_true_iff in H1. destruct H1. apply negb_true_iff in H1.
    --rewrite -> H1 in H2. discriminate. --apply H1.
    +assert (forall b : bool, b=true \/ b=false).
    -intros b. destruct b. --left. reflexivity. --right. reflexivity.
    -assert (val model f1 = true \/ val model f1 = false).
    --apply H0. --destruct H2.
    ---simpl. apply orb_true_iff. right. apply IHND.
    unfold mSsf. intros f H3. apply Union_inv in H3.
    destruct H3. ----apply H1. apply H3.
    ----apply Singleton_inv in H3. rewrite <- H3. apply H2.
    ---simpl. apply orb_true_iff. left. apply negb_true_iff. apply H2.
    +simpl. assert (H2:mSsf model C). ++apply H1. ++apply IHND1 in H1. apply IHND2 in H2.
    simpl in H2. rewrite -> H1 in H2. simpl in H2. apply H2.
    +assert (mSsf model
    (Union Formula C (Singleton Formula f)) -> False).
    -intros H2. apply IHND in H2. simpl in H2. discriminate.
    -assert (val model f = true -> False).
    --intros H3. apply H0. unfold mSsf. intros f0 H4.
    apply Union_inv in H4. destruct H4.
    ---apply H1 in H2. apply H2.
    ---apply Singleton_inv in H2. rewrite <- H2. apply H3.
    --simpl. apply negb_true_iff. assert (forall b:bool, b=true \/ b=false).
    ---intros b. destruct b. ----left. reflexivity. ----right. reflexivity.
    ---assert (HL:val model f = true \/ val model f = false).
    ----apply H3. ----destruct HL.
    -----apply H2 in H4. exfalso. apply H4.
    -----apply H4.
    +apply IHND in H1. simpl in H1. discriminate.
    +assert (mSsf model
    (Union Formula C (Singleton Formula (neg f))) -> False).
    -intros H2. apply IHND in H2. simpl in H2. discriminate.
    -assert (val model (neg f) = true -> False).
    --intros H2. apply H0. unfold mSsf. intros f0 H3.
    apply Union_inv in H3. destruct H3.
    ---apply H1. apply H3. ---apply Singleton_inv in H3. rewrite -> H3 in H2. apply H2.
    --assert (forall b:bool, b=true \/ b=false).
    ---intros b. destruct b. ----left. reflexivity. ----right. reflexivity.
    ---assert (HL:val model (neg f) = true \/ val model (neg f) = false).
    ----apply H3. ----destruct HL.
    -----apply H2 in H4. exfalso. apply H4. -----simpl in H4.
    apply negb_false_iff in H4. apply H4.


Add LoadPath "D:\sfsol".
Require Export Stlc.

Module STLCProp.
Import STLC.

Theorem progress : forall t T,
     empty |- t \in T ->
     value t \/ exists t', t ==> t'.
Proof with eauto.
  intros t T H.
  remember (@empty ty) as Gamma.
  has_type_cases (induction H) Case; subst Gamma...
    inversion H.
    right. destruct IHhas_type1...
      destruct IHhas_type2...
        inversion H; subst; try solve by inversion.
        exists ([x0:=t2]t12)...
        inversion H2 as [t2' Hstep].
        exists (tapp t1 t2')...
      inversion H1 as [t1' Hstep].
        exists (tapp t1' t2)...
    right. destruct IHhas_type1...
      inversion H2; subst...
      solve by inversion.
      inversion H2...
  Qed.

Theorem progress' : forall t T,
     empty |- t \in T ->
     value t \/ exists t', t ==> t'.
Proof.
  intros t.
  t_cases (induction t) Case; intros T Ht; auto.
  solve by inversion 2.
  inversion Ht; subst. right.
  assert(value t1 \/ (exists t' : tm, t1 ==> t')).
    eauto.
  assert(value t2 \/ (exists t' : tm, t2 ==> t')). eauto.
  inversion H. inversion H0. inversion H2; subst; try solve by inversion.
    exists ([x0:=t2]t12). auto.
    inversion H3. exists (tapp t1 x0). auto.
    inversion H1. exists (tapp x0 t2). auto.
  inversion Ht; subst. right.
  assert(value t1 \/ (exists t' : tm, t1 ==> t')). eauto.
  inversion H. inversion H3; subst; try solve by inversion.
    eauto.
    eauto.
    inversion H0.
    exists(tif x0 t2 t3). auto.
  Qed.

Inductive appears_free_in : id -> tm -> Prop :=
  | afi_var : forall x,
      appears_free_in x (tvar x)
  | afi_app1 : forall x t1 t2,
      appears_free_in x t1 -> appears_free_in x (tapp t1 t2)
  | afi_app2 : forall x t1 t2,
      appears_free_in x t2 -> appears_free_in x (tapp t1 t2)
  | afi_abs : forall x y T11 t12,
      y <> x ->
      appears_free_in x t12 ->
      appears_free_in x (tabs y T11 t12)
  | afi_if1 : forall x t1 t2 t3,
      appears_free_in x t1 ->
      appears_free_in x (tif t1 t2 t3)
  | afi_if2 : forall x t1 t2 t3,
      appears_free_in x t2 ->
      appears_free_in x (tif t1 t2 t3)
  | afi_if3 : forall x t1 t2 t3,
      appears_free_in x t3 ->
      appears_free_in x (tif t1 t2 t3).

Tactic Notation "afi_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "afi_var"
  | Case_aux c "afi_app1" | Case_aux c "afi_app2"
  | Case_aux c "afi_abs"
  | Case_aux c "afi_if1" | Case_aux c "afi_if2"
  | Case_aux c "afi_if3" ].

Hint Constructors appears_free_in.

Definition closed (t:tm) :=
  forall x, ~ appears_free_in x t.

Lemma free_in_context : forall x t T Gamma,
   appears_free_in x t ->
   Gamma |- t \in T ->
   exists T', Gamma x = Some T'.
 Proof.
  intros x t T Gamma H H0. generalize dependent Gamma.
  generalize dependent T.
  afi_cases (induction H) Case;
         intros; try solve [inversion H0; eauto].
  Case "afi_abs".
    inversion H1; subst.
    apply IHappears_free_in in H7.
    rewrite extend_neq in H7; assumption.
Qed.

Corollary typable_empty__closed : forall t T,
    empty |- t \in T ->
    closed t.
Proof with auto.
  intros t T H x contra.
  apply free_in_context with (T:=T) (Gamma:=empty) in contra...
  solve by inversion 2.
  Qed.

Lemma context_invariance : forall Gamma Gamma' t T,
     Gamma |- t \in T ->
     (forall x, appears_free_in x t -> Gamma x = Gamma' x) ->
     Gamma' |- t \in T.
Proof.
  intros.
  generalize dependent Gamma'.
  induction H; intros; eauto. econstructor. symmetry. rewrite <- H.
  apply H0. auto.
  econstructor. apply IHhas_type.
  intros. unfold extend.
  destruct (eq_id_dec x0 x1). reflexivity.
  apply H0. eauto.
  econstructor; auto.
  econstructor; auto.
  Qed.

Lemma substitution_preserves_typing : forall Gamma x U t v T,
     extend Gamma x U |- t \in T ->
     empty |- v \in U ->
     Gamma |- [x:=v]t \in T.
Proof.
  intros.
  generalize dependent Gamma.
  generalize dependent T.
  induction t; intros; simpl; inversion H; subst; eauto;
  destruct (eq_id_dec x0 i); subst.
  rewrite -> extend_eq in H3. inv H3.
  eapply context_invariance. apply H0.
  intros. assert (contra:False); try inversion contra.
  eapply typable_empty__closed. apply H0. apply H1.
  rewrite extend_neq in H3; eauto.
  econstructor. eapply context_invariance.
  apply H6. intros. apply extend_shadow.
  econstructor. apply IHt. eapply context_invariance.
  apply H6. intros.
  destruct (eq_id_dec i x1); subst.
  rewrite extend_eq. rewrite extend_neq; auto. rewrite extend_eq. reflexivity.
  rewrite extend_neq; auto. destruct (eq_id_dec x0 x1); subst.
  rewrite extend_eq. rewrite extend_eq. reflexivity.
  repeat rewrite extend_neq; auto.
  Qed.

Theorem preservation : forall t t' T,
     empty |- t \in T ->
     t ==> t' ->
     empty |- t' \in T.
Proof with eauto.
  intros.
  remember (@empty ty) as Gamma.
  generalize dependent t'.
  induction H; intros t' HE; subst;
  try solve [inversion HE; subst; auto].
  inversion HE; subst...
  apply substitution_preserves_typing with T11...
  inversion H...
  Qed.

Definition stuck (t:tm) : Prop :=
  (normal_form step) t /\ ~ value t.

Corollary soundness : forall t t' T,
  empty |- t \in T ->
  t ==>* t' ->
  ~(stuck t').
Proof with auto.
  intros t t' T Hhas_type Hmulti. unfold stuck.
  intros [Hnf Hnot_val]. unfold normal_form in Hnf.
  induction Hmulti.
  assert((value x0)\/(exists t' : tm, x0 ==> t')).
    eapply progress. apply Hhas_type.
  inversion H...
  apply IHHmulti.
  eapply preservation. apply Hhas_type. assumption.
  assumption. assumption.
  Qed.

Theorem no_subject_expansion : exists t, exists t', exists T,
  (t ==> t')->(empty |- t' \in T) ->
  ~ (empty |- t \in T).
Proof with eauto.
  apply ex_intro with (tapp (tabs y TBool ttrue) (tvar z)).
  apply ex_intro with ttrue. apply ex_intro with TBool.
  intros. inversion H. subst.
  intro contra. inversion contra; subst.
  inversion H7; subst. inversion H4.
  Qed.

Theorem types_unique : forall t Gamma T1 T2,
  Gamma |- t \in T1 ->
  Gamma |- t \in T2 ->
  T1 = T2.
Proof with eauto.
  induction t; intros; inversion H; inversion H0; subst...
  rewrite H3 in H7. inversion H7...
  assert (T0 = T11)... subst.
  assert (TArrow T11 T1 = TArrow T11 T2)... inversion H1...
  assert (T12 = T3)... subst. reflexivity.
  Qed.

(*

  stlc_variation1
    determinism becomes false, trivial
    progress remains true
    preservation becomes false, trivial

  stlc_variation2
    determisim becomes false, tapp (tabs x x) (tabs x true)
    Progress remains true
    preservation becomes false, same for determinism

  stlc_variation3
    determinism remains true,
    progress becomes false, when t1 is non-value
    preservation remains true

  stlc_variation4
    determinism becomes false, tif true t1 t2
    progress remains true
    preservation becomes false, same as determinsim, yet t1 must have type diferent than bool

  stlc_variation5
    determinism remains true
    progress remains true
    preservation becomes false, (/\ x : Bool , /\ y : Bool y) (true)

  stlc_variation6
    determinsim remains true
    progress remains true
    preservation remains true

  stlc_variton7
    determinism remains true
    progress remains true
    preservation remains true

*)

End STLCProp.

Module STLCArith.

Inductive ty : Type :=
  | TArrow : ty -> ty -> ty
  | TNat : ty.

Inductive tm : Type :=
  | tvar : id -> tm
  | tapp : tm -> tm -> tm
  | tabs : id -> ty -> tm -> tm
  | tnat : nat -> tm
  | tsucc : tm -> tm
  | tpred : tm -> tm
  | tmult : tm -> tm -> tm
  | tif0 : tm -> tm -> tm -> tm.

Tactic Notation "t_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "tvar" | Case_aux c "tapp"
  | Case_aux c "tabs" | Case_aux c "tnat"
  | Case_aux c "tsucc" | Case_aux c "tpred"
  | Case_aux c "tmult" | Case_aux c "tif0" ].

Inductive value : tm -> Prop :=
  | v_abs : forall x T t,
      value (tabs x T t)
  | v_nat : forall x,
      value (tnat x).

Check value.

Hint Constructors value.

Reserved Notation "'[' x ':=' s ']' t" (at level 20).

Fixpoint subst (x:id) (s:tm) (t:tm) : tm :=
  match t with
  | tvar x' =>
      if eq_id_dec x x' then s else t
  | tabs x' T t1 =>
      tabs x' T (if eq_id_dec x x' then t1 else ([x:=s] t1))
  | tapp t1 t2 =>
      tapp ([x:=s] t1) ([x:=s] t2)
  | tnat n =>
      tnat n
  | tsucc t1 =>
      tsucc ([x:=s]t1)
  | tpred t1 =>
      tpred ([x:=s]t1)
  | tmult t1 t2 =>
      tmult ([x:=s]t1) ([x:=s]t2)
  | tif0 t1 t2 t3 =>
      tif0 ([x:=s] t1) ([x:=s] t2) ([x:=s] t3)
  end

where "'[' x ':=' s ']' t" := (subst x s t).

Reserved Notation "t1 '==>' t2" (at level 40).

Inductive step : tm -> tm -> Prop :=
  | ST_AppAbs : forall x T t12 v2,
         value v2 ->
         (tapp (tabs x T t12) v2) ==> [x:=v2]t12
  | ST_App1 : forall t1 t1' t2,
         t1 ==> t1' ->
         tapp t1 t2 ==> tapp t1' t2
  | ST_App2 : forall v1 t2 t2',
         value v1 ->
         t2 ==> t2' ->
         tapp v1 t2 ==> tapp v1 t2'
  | ST_If0 : forall t1 t2,
      (tif0 (tnat 0) t1 t2) ==> t1
  | ST_IfN0 : forall x t1 t2,
      x <> 0 -> (tif0 (tnat x) t1 t2) ==> t2
  | ST_If : forall t1 t1' t2 t3,
      t1 ==> t1' ->
      (tif0 t1 t2 t3) ==> (tif0 t1' t2 t3)
  | ST_SuccNat : forall x,
      tsucc (tnat x) ==> tnat (S x)
  | ST_Succ : forall t1 t2,
      t1 ==> t2 ->
      tsucc t1 ==> tsucc t2
  | ST_PredNat : forall x,
      tpred (tnat x) ==> tnat (pred x)
  | ST_Pred : forall t1 t2,
      t1 ==> t2 ->
      tpred t1 ==> tpred t2
  | ST_MultNatNat : forall x y,
      tmult (tnat x) (tnat y) ==> tnat (mult x y)
  | ST_MultNat : forall v t1 t2,
      value v ->
      t1 ==> t2 ->
      tmult v t1 ==> tmult v t2
  | ST_Mult : forall t1 t2 t3,
      t1 ==> t2 ->
      tmult t1 t3 ==> tmult t2 t3

where "t1 '==>' t2" := (step t1 t2).

Hint Constructors step.

Notation multistep := (multi step).
Notation "t1 '==>*' t2" := (multistep t1 t2) (at level 40).

Definition context := partial_map ty.

Reserved Notation "Gamma '|-' t '\in' T" (at level 40).

Inductive has_type : context -> tm -> ty -> Prop :=
  | T_Var : forall Gamma x T,
      Gamma x = Some T ->
      Gamma |- tvar x \in T
  | T_Abs : forall Gamma x T11 T12 t12,
      extend Gamma x T11 |- t12 \in T12 ->
      Gamma |- tabs x T11 t12 \in TArrow T11 T12
  | T_App : forall T11 T12 Gamma t1 t2,
      Gamma |- t1 \in TArrow T11 T12 ->
      Gamma |- t2 \in T11 ->
      Gamma |- tapp t1 t2 \in T12
  | T_Nat : forall Gamma x,
       Gamma |- tnat x \in TNat
  | T_Succ : forall Gamma t1,
       Gamma |- t1 \in TNat ->
       Gamma |- tsucc t1 \in TNat
  | T_Pred : forall Gamma t1,
       Gamma |- t1 \in TNat ->
       Gamma |- tpred t1 \in TNat
  | T_Mult : forall Gamma t1 t2,
       Gamma |- t1 \in TNat ->
       Gamma |- t2 \in TNat ->
       Gamma |- tmult t1 t2 \in TNat
  | T_If0 : forall t1 t2 t3 T Gamma,
       Gamma |- t1 \in TNat ->
       Gamma |- t2 \in T ->
       Gamma |- t3 \in T ->
       Gamma |- tif0 t1 t2 t3 \in T

where "Gamma '|-' t '\in' T" := (has_type Gamma t T).

Theorem progress : forall t T,
     empty |- t \in T ->
     value t \/ exists t', t ==> t'.
Proof with eauto.
  intros.
  remember (@empty ty) as Gamma.
  induction H; subst Gamma...
  inversion H.
  right. destruct IHhas_type1...
    destruct IHhas_type2...
    inversion H1...
    rewrite <- H3 in H.
    inversion H.
    inversion H2...
    inversion H1...
  right.
    destruct IHhas_type...
    inversion H0... rewrite <- H1 in H.
    inversion H...
    inversion H0...
  right.
    destruct IHhas_type...
    inversion H0... rewrite <- H1 in H.
    inversion H...
    inversion H0...
  right.
    destruct IHhas_type1; eauto;
    inversion H1; subst;eauto; inversion H;
    destruct IHhas_type2; eauto;
    inversion H3; subst; eauto; inversion H0.
  right.
    destruct IHhas_type1; eauto;
    inversion H2; subst...
      inversion H.
      destruct x...
  Qed.

Inductive appears_free_in : id -> tm -> Prop :=
  | afi_var : forall x,
      appears_free_in x (tvar x)
  | afi_app1 : forall x t1 t2,
      appears_free_in x t1 -> appears_free_in x (tapp t1 t2)
  | afi_app2 : forall x t1 t2,
      appears_free_in x t2 -> appears_free_in x (tapp t1 t2)
  | afi_abs : forall x y T11 t12,
      y <> x ->
      appears_free_in x t12 ->
      appears_free_in x (tabs y T11 t12)
  | afi_tsucc : forall x t,
      appears_free_in x t ->
      appears_free_in x (tsucc t)
  | afi_tpred : forall x t,
      appears_free_in x t ->
      appears_free_in x (tpred t)
  | afi_if1 : forall x t1 t2 t3,
      appears_free_in x t1 ->
      appears_free_in x (tif0 t1 t2 t3)
  | afi_if2 : forall x t1 t2 t3,
      appears_free_in x t2 ->
      appears_free_in x (tif0 t1 t2 t3)
  | afi_if3 : forall x t1 t2 t3,
      appears_free_in x t3 ->
      appears_free_in x (tif0 t1 t2 t3)
  | afi_mult1 : forall x t1 t2,
      appears_free_in x t1 ->
      appears_free_in x (tmult t1 t2)
  | afi_mult2 : forall x t1 t2,
      appears_free_in x t2 ->
      appears_free_in x (tmult t1 t2).

Tactic Notation "afi_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "afi_var"
  | Case_aux c "afi_app1" | Case_aux c "afi_app2"
  | Case_aux c "afi_abs"  | Case_aux c "afi_tsucc"
  | Case_aux c "afi_tpred" | Case_aux c "afi_mult1"
  | Case_aux c "afi_mult2"
  | Case_aux c "afi_if1" | Case_aux c "afi_if2"
  | Case_aux c "afi_if3" ].

Hint Constructors appears_free_in.

Definition closed (t:tm) :=
  forall x, ~ appears_free_in x t.

Lemma free_in_context : forall x t T Gamma,
   appears_free_in x t ->
   Gamma |- t \in T ->
   exists T', Gamma x = Some T'.
Proof.
  intros x t T Gamma H H0. generalize dependent Gamma.
  generalize dependent T.
  afi_cases (induction H) Case;
         intros; try solve [inversion H0; eauto].
  Case "afi_abs".
    inversion H1; subst.
    apply IHappears_free_in in H7.
    rewrite extend_neq in H7; assumption.
Qed.

Corollary typable_empty__closed : forall t T,
    empty |- t \in T ->
    closed t.
Proof with auto.
  intros t T H x contra.
  apply free_in_context with (T:=T) (Gamma:=empty) in contra...
  solve by inversion 2.
  Qed.

Lemma context_invariance : forall Gamma Gamma' t T,
     Gamma |- t \in T ->
     (forall x, appears_free_in x t -> Gamma x = Gamma' x) ->
     Gamma' |- t \in T.
Proof with eauto.
  intros.
  generalize dependent Gamma'.
  induction H; intros; econstructor; eauto. symmetry. rewrite <- H.
  apply H0. auto.
  apply IHhas_type.
  intros. unfold extend.
  destruct (eq_id_dec x x0). reflexivity.
  apply H0...
  Qed.

Lemma substitution_preserves_typing : forall Gamma x U t v T,
     extend Gamma x U |- t \in T ->
     empty |- v \in U ->
     Gamma |- [x:=v]t \in T.
Proof.
  intros.
  generalize dependent Gamma.
  generalize dependent T.
  induction t; intros; simpl; inversion H; subst; eauto.
  destruct (eq_id_dec x i); subst.
  rewrite -> extend_eq in H3. inv H3.
  eapply context_invariance. apply H0.
  intros. assert (contra:False); try inversion contra.
  eapply typable_empty__closed. apply H0. apply H1.
  rewrite extend_neq in H3; eauto.
  econstructor. auto.
  econstructor. apply IHt1. apply H4.
  apply IHt2. apply H6.
  destruct (eq_id_dec x i); subst. econstructor.
  eapply context_invariance. apply H6. intros.
  destruct (eq_id_dec x i); subst; eauto.
  rewrite extend_eq; rewrite extend_eq; auto.
  rewrite extend_neq; try rewrite extend_neq; try rewrite extend_neq; auto.
  econstructor. apply IHt. eapply context_invariance.
  apply H6. intros. destruct (eq_id_dec x x0); subst; eauto.
  rewrite extend_neq. rewrite extend_eq. rewrite extend_eq. auto. auto.
  destruct (eq_id_dec i x0); subst.
  rewrite extend_eq; auto. rewrite extend_neq. rewrite extend_eq. auto. auto.
  rewrite extend_neq; auto. rewrite extend_neq; auto.
  rewrite extend_neq; auto. rewrite extend_neq; auto.
  econstructor.
  econstructor;auto.
  econstructor;auto.
  econstructor;auto.
  econstructor; auto.
  Qed.

Theorem preservation : forall t t' T,
     empty |- t \in T ->
     t ==> t' ->
     empty |- t' \in T.
Proof with eauto.
  intros.
  remember (@empty ty) as Gamma.
  generalize dependent t'.
  induction H; intros t' HE; subst;
  try solve [inversion HE; subst; eauto; econstructor; eauto].
  inversion HE; subst...
  apply substitution_preserves_typing with T11...
  inversion H...
  econstructor...
  econstructor...
  Qed.

Definition stuck (t:tm) : Prop :=
  (normal_form step) t /\ ~ value t.

Corollary soundness : forall t t' T,
  empty |- t \in T ->
  t ==>* t' ->
  ~(stuck t').
Proof with auto.
  intros t t' T Hhas_type Hmulti. unfold stuck.
  intros [Hnf Hnot_val]. unfold normal_form in Hnf.
  induction Hmulti.
  assert((value x)\/(exists t' : tm, x ==> t')).
    eapply progress. apply Hhas_type.
  inversion H...
  apply IHHmulti.
  eapply preservation. apply Hhas_type. assumption.
  assumption. assumption.
  Qed.

End STLCArith.


From Hammer Require Import Hammer.

Require Export Decidable.
Require Export NAxioms.
Require Import NZProperties.

Module NBaseProp (Import N : NAxiomsMiniSig').

Include NZProp N.

Theorem neq_succ_0 : forall n, S n ~= 0.
Proof. hammer_hook "NBase" "NBase.NBaseProp.neq_succ_0".
intros n EQ.
assert (EQ' := pred_succ n).
rewrite EQ, pred_0 in EQ'.
rewrite <- EQ' in EQ.
now apply (neq_succ_diag_l 0).
Qed.

Theorem neq_0_succ : forall n, 0 ~= S n.
Proof. hammer_hook "NBase" "NBase.NBaseProp.neq_0_succ".
intro n; apply neq_sym; apply neq_succ_0.
Qed.

Theorem le_0_l : forall n, 0 <= n.
Proof. hammer_hook "NBase" "NBase.NBaseProp.le_0_l".
nzinduct n.
now apply eq_le_incl.
intro n; split.
apply le_le_succ_r.
intro H; apply le_succ_r in H; destruct H as [H | H].
assumption.
symmetry in H; false_hyp H neq_succ_0.
Qed.

Theorem induction :
forall A : N.t -> Prop, Proper (N.eq==>iff) A ->
A 0 -> (forall n, A n -> A (S n)) -> forall n, A n.
Proof. hammer_hook "NBase" "NBase.NBaseProp.induction".
intros A A_wd A0 AS n; apply right_induction with 0; try assumption.
intros; auto; apply le_0_l. apply le_0_l.
Qed.

Ltac induct n := induction_maker n ltac:(apply induction).

Theorem case_analysis :
forall A : N.t -> Prop, Proper (N.eq==>iff) A ->
A 0 -> (forall n, A (S n)) -> forall n, A n.
Proof. hammer_hook "NBase" "NBase.NBaseProp.case_analysis".
intros; apply induction; auto.
Qed.

Ltac cases n := induction_maker n ltac:(apply case_analysis).

Theorem neq_0 : ~ forall n, n == 0.
Proof. hammer_hook "NBase" "NBase.NBaseProp.neq_0".
intro H; apply (neq_succ_0 0). apply H.
Qed.

Theorem neq_0_r : forall n, n ~= 0 <-> exists m, n == S m.
Proof. hammer_hook "NBase" "NBase.NBaseProp.neq_0_r".
cases n. split; intro H;
[now elim H | destruct H as [m H]; symmetry in H; false_hyp H neq_succ_0].
intro n; split; intro H; [now exists n | apply neq_succ_0].
Qed.

Theorem zero_or_succ : forall n, n == 0 \/ exists m, n == S m.
Proof. hammer_hook "NBase" "NBase.NBaseProp.zero_or_succ".
cases n.
now left.
intro n; right; now exists n.
Qed.

Theorem eq_pred_0 : forall n, P n == 0 <-> n == 0 \/ n == 1.
Proof. hammer_hook "NBase" "NBase.NBaseProp.eq_pred_0".
cases n.
rewrite pred_0. now split; [left|].
intro n. rewrite pred_succ.
split. intros H; right. now rewrite H, one_succ.
intros [H|H]. elim (neq_succ_0 _ H).
apply succ_inj_wd. now rewrite <- one_succ.
Qed.

Theorem succ_pred : forall n, n ~= 0 -> S (P n) == n.
Proof. hammer_hook "NBase" "NBase.NBaseProp.succ_pred".
cases n.
intro H; exfalso; now apply H.
intros; now rewrite pred_succ.
Qed.

Theorem pred_inj : forall n m, n ~= 0 -> m ~= 0 -> P n == P m -> n == m.
Proof. hammer_hook "NBase" "NBase.NBaseProp.pred_inj".
intros n m; cases n.
intros H; exfalso; now apply H.
intros n _; cases m.
intros H; exfalso; now apply H.
intros m H2 H3. do 2 rewrite pred_succ in H3. now rewrite H3.
Qed.

Section PairInduction.

Variable A : N.t -> Prop.
Hypothesis A_wd : Proper (N.eq==>iff) A.

Theorem pair_induction :
A 0 -> A 1 ->
(forall n, A n -> A (S n) -> A (S (S n))) -> forall n, A n.
Proof. hammer_hook "NBase" "NBase.NBaseProp.pair_induction".
rewrite one_succ.
intros until 3.
assert (D : forall n, A n /\ A (S n)); [ |intro n; exact (proj1 (D n))].
induct n; [ | intros n [IH1 IH2]]; auto.
Qed.

End PairInduction.

Section TwoDimensionalInduction.

Variable R : N.t -> N.t -> Prop.
Hypothesis R_wd : Proper (N.eq==>N.eq==>iff) R.

Theorem two_dim_induction :
R 0 0 ->
(forall n m, R n m -> R n (S m)) ->
(forall n, (forall m, R n m) -> R (S n) 0) -> forall n m, R n m.
Proof. hammer_hook "NBase" "NBase.NBaseProp.two_dim_induction".
intros H1 H2 H3. induct n.
induct m.
exact H1. exact (H2 0).
intros n IH. induct m.
now apply H3. exact (H2 (S n)).
Qed.

End TwoDimensionalInduction.

Section DoubleInduction.

Variable R : N.t -> N.t -> Prop.
Hypothesis R_wd : Proper (N.eq==>N.eq==>iff) R.

Theorem double_induction :
(forall m, R 0 m) ->
(forall n, R (S n) 0) ->
(forall n m, R n m -> R (S n) (S m)) -> forall n m, R n m.
Proof. hammer_hook "NBase" "NBase.NBaseProp.double_induction".
intros H1 H2 H3; induct n; auto.
intros n H; cases m; auto.
Qed.

End DoubleInduction.

Ltac double_induct n m :=
try intros until n;
try intros until m;
pattern n, m; apply double_induction; clear n m;
[solve_proper | | | ].

End NBaseProp.


(**
This file is part of the Flocq formalization of floating-point
arithmetic in Coq: http://flocq.gforge.inria.fr/

Copyright (C) 2010-2011 Sylvie Boldo
#<br />#
Copyright (C) 2010-2011 Guillaume Melquiond

This library 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 3 of the License, or (at your option) any later version.

This library 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
COPYING file for more details.
*)

(** * Relative error of the roundings *)
Require Import Fcore.

Section Fprop_relative.

Variable beta : radix.
Notation bpow e := (bpow beta e).

Section Fprop_relative_generic.

Variable fexp : Z -> Z.
Context { prop_exp : Valid_exp fexp }.

Section relative_error_conversion.

Variable rnd : R -> Z.
Context { valid_rnd : Valid_rnd rnd }.

Lemma relative_error_lt_conversion :
  forall x b, (0 < b)%R ->
  (Rabs (round beta fexp rnd x - x) < b * Rabs x)%R ->
  exists eps,
  (Rabs eps < b)%R /\ round beta fexp rnd x = (x * (1 + eps))%R.
Proof with auto with typeclass_instances.
intros x b Hb0 Hxb.
destruct (Req_dec x 0) as [Hx0|Hx0].
(* *)
exists R0.
split.
now rewrite Rabs_R0.
rewrite Hx0, Rmult_0_l.
apply round_0...
(* *)
exists ((round beta fexp rnd x - x) / x)%R.
split. 2: now field.
unfold Rdiv.
rewrite Rabs_mult.
apply Rmult_lt_reg_r with (Rabs x).
now apply Rabs_pos_lt.
rewrite Rmult_assoc, <- Rabs_mult.
rewrite Rinv_l with (1 := Hx0).
now rewrite Rabs_R1, Rmult_1_r.
Qed.

Lemma relative_error_le_conversion :
  forall x b, (0 <= b)%R ->
  (Rabs (round beta fexp rnd x - x) <= b * Rabs x)%R ->
  exists eps,
  (Rabs eps <= b)%R /\ round beta fexp rnd x = (x * (1 + eps))%R.
Proof with auto with typeclass_instances.
intros x b Hb0 Hxb.
destruct (Req_dec x 0) as [Hx0|Hx0].
(* *)
exists R0.
split.
now rewrite Rabs_R0.
rewrite Hx0, Rmult_0_l.
apply round_0...
(* *)
exists ((round beta fexp rnd x - x) / x)%R.
split. 2: now field.
unfold Rdiv.
rewrite Rabs_mult.
apply Rmult_le_reg_r with (Rabs x).
now apply Rabs_pos_lt.
rewrite Rmult_assoc, <- Rabs_mult.
rewrite Rinv_l with (1 := Hx0).
now rewrite Rabs_R1, Rmult_1_r.
Qed.

End relative_error_conversion.

Variable emin p : Z.
Hypothesis Hmin : forall k, (emin < k)%Z -> (p <= k - fexp k)%Z.

Variable rnd : R -> Z.
Context { valid_rnd : Valid_rnd rnd }.

Theorem relative_error :
  forall x,
  (bpow emin <= Rabs x)%R ->
  (Rabs (round beta fexp rnd x - x) < bpow (-p + 1) * Rabs x)%R.
Proof.
intros x Hx.
apply Rlt_le_trans with (ulp beta fexp x)%R.
now apply ulp_error.
unfold ulp, canonic_exp.
assert (Hx': (x <> 0)%R).
intros H.
apply Rlt_not_le with (2 := Hx).
rewrite H, Rabs_R0.
apply bpow_gt_0.
destruct (ln_beta beta x) as (ex, He).
simpl.
specialize (He Hx').
apply Rle_trans with (bpow (-p + 1) * bpow (ex - 1))%R.
rewrite <- bpow_plus.
apply bpow_le.
assert (emin < ex)%Z.
apply (lt_bpow beta).
apply Rle_lt_trans with (2 := proj2 He).
exact Hx.
generalize (Hmin ex).
omega.
apply Rmult_le_compat_l.
apply bpow_ge_0.
apply He.
Qed.

(** 1+#ε# property in any rounding *)
Theorem relative_error_ex :
  forall x,
  (bpow emin <= Rabs x)%R ->
  exists eps,
  (Rabs eps < bpow (-p + 1))%R /\ round beta fexp rnd x = (x * (1 + eps))%R.
Proof with auto with typeclass_instances.
intros x Hx.
apply relative_error_lt_conversion...
apply bpow_gt_0.
now apply relative_error.
Qed.

Theorem relative_error_F2R_emin :
  forall m, let x := F2R (Float beta m emin) in
  (x <> 0)%R ->
  (Rabs (round beta fexp rnd x - x) < bpow (-p + 1) * Rabs x)%R.
Proof.
intros m x Hx.
apply relative_error.
unfold x.
rewrite <- F2R_Zabs.
apply bpow_le_F2R.
apply F2R_lt_reg with beta emin.
rewrite F2R_0, F2R_Zabs.
now apply Rabs_pos_lt.
Qed.

Theorem relative_error_F2R_emin_ex :
  forall m, let x := F2R (Float beta m emin) in
  (x <> 0)%R ->
  exists eps,
  (Rabs eps < bpow (-p + 1))%R /\ round beta fexp rnd x = (x * (1 + eps))%R.
Proof with auto with typeclass_instances.
intros m x Hx.
apply relative_error_lt_conversion...
apply bpow_gt_0.
now apply relative_error_F2R_emin.
Qed.

Theorem relative_error_round :
  (0 < p)%Z ->
  forall x,
  (bpow emin <= Rabs x)%R ->
  (Rabs (round beta fexp rnd x - x) < bpow (-p + 1) * Rabs (round beta fexp rnd x))%R.
Proof with auto with typeclass_instances.
intros Hp x Hx.
apply Rlt_le_trans with (ulp beta fexp x)%R.
now apply ulp_error.
assert (Hx': (x <> 0)%R).
intros H.
apply Rlt_not_le with (2 := Hx).
rewrite H, Rabs_R0.
apply bpow_gt_0.
unfold ulp, canonic_exp.
destruct (ln_beta beta x) as (ex, He).
simpl.
specialize (He Hx').
assert (He': (emin < ex)%Z).
apply (lt_bpow beta).
apply Rle_lt_trans with (2 := proj2 He).
exact Hx.
apply Rle_trans with (bpow (-p + 1) * bpow (ex - 1))%R.
rewrite <- bpow_plus.
apply bpow_le.
generalize (Hmin ex).
omega.
apply Rmult_le_compat_l.
apply bpow_ge_0.
generalize He.
apply round_abs_abs...
clear rnd valid_rnd x Hx Hx' He.
intros rnd valid_rnd x Hx.
rewrite <- (round_generic beta fexp rnd (bpow (ex - 1))).
now apply round_le.
apply generic_format_bpow.
ring_simplify (ex - 1 + 1)%Z.
generalize (Hmin ex).
omega.
Qed.

Theorem relative_error_round_F2R_emin :
  (0 < p)%Z ->
  forall m, let x := F2R (Float beta m emin) in
  (x <> 0)%R ->
  (Rabs (round beta fexp rnd x - x) < bpow (-p + 1) * Rabs (round beta fexp rnd x))%R.
Proof.
intros Hp m x Hx.
apply relative_error_round.
exact Hp.
unfold x.
rewrite <- F2R_Zabs.
apply bpow_le_F2R.
apply F2R_lt_reg with beta emin.
rewrite F2R_0, F2R_Zabs.
now apply Rabs_pos_lt.
Qed.

Variable choice : Z -> bool.

Theorem relative_error_N :
  forall x,
  (bpow emin <= Rabs x)%R ->
  (Rabs (round beta fexp (Znearest choice) x - x) <= /2 * bpow (-p + 1) * Rabs x)%R.
Proof.
intros x Hx.
apply Rle_trans with (/2 * ulp beta fexp x)%R.
now apply ulp_half_error.
rewrite Rmult_assoc.
apply Rmult_le_compat_l.
apply Rlt_le.
apply Rinv_0_lt_compat.
now apply (Z2R_lt 0 2).
assert (Hx': (x <> 0)%R).
intros H.
apply Rlt_not_le with (2 := Hx).
rewrite H, Rabs_R0.
apply bpow_gt_0.
unfold ulp, canonic_exp.
destruct (ln_beta beta x) as (ex, He).
simpl.
specialize (He Hx').
apply Rle_trans with (bpow (-p + 1) * bpow (ex - 1))%R.
rewrite <- bpow_plus.
apply bpow_le.
assert (emin < ex)%Z.
apply (lt_bpow beta).
apply Rle_lt_trans with (2 := proj2 He).
exact Hx.
generalize (Hmin ex).
omega.
apply Rmult_le_compat_l.
apply bpow_ge_0.
apply He.
Qed.

(** 1+#ε# property in rounding to nearest *)
Theorem relative_error_N_ex :
  forall x,
  (bpow emin <= Rabs x)%R ->
  exists eps,
  (Rabs eps <= /2 * bpow (-p + 1))%R /\ round beta fexp (Znearest choice) x = (x * (1 + eps))%R.
Proof with auto with typeclass_instances.
intros x Hx.
apply relative_error_le_conversion...
apply Rlt_le.
apply Rmult_lt_0_compat.
apply Rinv_0_lt_compat.
now apply (Z2R_lt 0 2).
apply bpow_gt_0.
now apply relative_error_N.
Qed.

Theorem relative_error_N_F2R_emin :
  forall m, let x := F2R (Float beta m emin) in
  (Rabs (round beta fexp (Znearest choice) x - x) <= /2 * bpow (-p + 1) * Rabs x)%R.
Proof with auto with typeclass_instances.
intros m x.
destruct (Req_dec x 0) as [Hx|Hx].
(* . *)
rewrite Hx, round_0...
unfold Rminus.
rewrite Rplus_0_l, Rabs_Ropp, Rabs_R0.
rewrite Rmult_0_r.
apply Rle_refl.
(* . *)
apply relative_error_N.
unfold x.
rewrite <- F2R_Zabs.
apply bpow_le_F2R.
apply F2R_lt_reg with beta emin.
rewrite F2R_0, F2R_Zabs.
now apply Rabs_pos_lt.
Qed.

Theorem relative_error_N_F2R_emin_ex :
  forall m, let x := F2R (Float beta m emin) in
  exists eps,
  (Rabs eps <= /2 * bpow (-p + 1))%R /\ round beta fexp (Znearest choice) x = (x * (1 + eps))%R.
Proof with auto with typeclass_instances.
intros m x.
apply relative_error_le_conversion...
apply Rlt_le.
apply Rmult_lt_0_compat.
apply Rinv_0_lt_compat.
now apply (Z2R_lt 0 2).
apply bpow_gt_0.
now apply relative_error_N_F2R_emin.
Qed.

Theorem relative_error_N_round :
  (0 < p)%Z ->
  forall x,
  (bpow emin <= Rabs x)%R ->
  (Rabs (round beta fexp (Znearest choice) x - x) <= /2 * bpow (-p + 1) * Rabs (round beta fexp (Znearest choice) x))%R.
Proof with auto with typeclass_instances.
intros Hp x Hx.
apply Rle_trans with (/2 * ulp beta fexp x)%R.
now apply ulp_half_error.
rewrite Rmult_assoc.
apply Rmult_le_compat_l.
apply Rlt_le.
apply Rinv_0_lt_compat.
now apply (Z2R_lt 0 2).
assert (Hx': (x <> 0)%R).
intros H.
apply Rlt_not_le with (2 := Hx).
rewrite H, Rabs_R0.
apply bpow_gt_0.
unfold ulp, canonic_exp.
destruct (ln_beta beta x) as (ex, He).
simpl.
specialize (He Hx').
assert (He': (emin < ex)%Z).
apply (lt_bpow beta).
apply Rle_lt_trans with (2 := proj2 He).
exact Hx.
apply Rle_trans with (bpow (-p + 1) * bpow (ex - 1))%R.
rewrite <- bpow_plus.
apply bpow_le.
generalize (Hmin ex).
omega.
apply Rmult_le_compat_l.
apply bpow_ge_0.
generalize He.
apply round_abs_abs...
clear rnd valid_rnd x Hx Hx' He.
intros rnd valid_rnd x Hx.
rewrite <- (round_generic beta fexp rnd (bpow (ex - 1))).
now apply round_le.
apply generic_format_bpow.
ring_simplify (ex - 1 + 1)%Z.
generalize (Hmin ex).
omega.
Qed.

Theorem relative_error_N_round_F2R_emin :
  (0 < p)%Z ->
  forall m, let x := F2R (Float beta m emin) in
  (Rabs (round beta fexp (Znearest choice) x - x) <= /2 * bpow (-p + 1) * Rabs (round beta fexp (Znearest choice) x))%R.
Proof with auto with typeclass_instances.
intros Hp m x.
destruct (Req_dec x 0) as [Hx|Hx].
(* . *)
rewrite Hx, round_0...
unfold Rminus.
rewrite Rplus_0_l, Rabs_Ropp, Rabs_R0.
rewrite Rmult_0_r.
apply Rle_refl.
(* . *)
apply relative_error_N_round with (1 := Hp).
unfold x.
rewrite <- F2R_Zabs.
apply bpow_le_F2R.
apply F2R_lt_reg with beta emin.
rewrite F2R_0, F2R_Zabs.
now apply Rabs_pos_lt.
Qed.

End Fprop_relative_generic.

Section Fprop_relative_FLT.

Variable emin prec : Z.
Variable Hp : Zlt 0 prec.

Lemma relative_error_FLT_aux :
  forall k, (emin + prec - 1 < k)%Z -> (prec <= k - FLT_exp emin prec k)%Z.
Proof.
intros k Hk.
unfold FLT_exp.
generalize (Zmax_spec (k - prec) emin).
omega.
Qed.

Variable rnd : R -> Z.
Context { valid_rnd : Valid_rnd rnd }.

Theorem relative_error_FLT_F2R_emin :
  forall m, let x := F2R (Float beta m (emin + prec - 1)) in
  (x <> 0)%R ->
  (Rabs (round beta (FLT_exp emin prec) rnd x - x) < bpow (-prec + 1) * Rabs x)%R.
Proof with auto with typeclass_instances.
intros m x Hx.
apply relative_error_F2R_emin...
apply relative_error_FLT_aux.
Qed.

Theorem relative_error_FLT :
  forall x,
  (bpow (emin + prec - 1) <= Rabs x)%R ->
  (Rabs (round beta (FLT_exp emin prec) rnd x - x) < bpow (-prec + 1) * Rabs x)%R.
Proof with auto with typeclass_instances.
intros x Hx.
apply relative_error with (emin + prec - 1)%Z...
apply relative_error_FLT_aux.
Qed.

Theorem relative_error_FLT_F2R_emin_ex :
  forall m, let x := F2R (Float beta m (emin + prec - 1)) in
  (x <> 0)%R ->
  exists eps,
  (Rabs eps < bpow (-prec + 1))%R /\ round beta (FLT_exp emin prec) rnd x = (x * (1 + eps))%R.
Proof with auto with typeclass_instances.
intros m x Hx.
apply relative_error_lt_conversion...
apply bpow_gt_0.
now apply relative_error_FLT_F2R_emin.
Qed.

(** 1+#ε# property in any rounding in FLT *)
Theorem relative_error_FLT_ex :
  forall x,
  (bpow (emin + prec - 1) <= Rabs x)%R ->
  exists eps,
  (Rabs eps < bpow (-prec + 1))%R /\ round beta (FLT_exp emin prec) rnd x = (x * (1 + eps))%R.
Proof with auto with typeclass_instances.
intros x Hx.
apply relative_error_lt_conversion...
apply bpow_gt_0.
now apply relative_error_FLT.
Qed.

Variable choice : Z -> bool.

Theorem relative_error_N_FLT :
  forall x,
  (bpow (emin + prec - 1) <= Rabs x)%R ->
  (Rabs (round beta (FLT_exp emin prec) (Znearest choice) x - x) <= /2 * bpow (-prec + 1) * Rabs x)%R.
Proof with auto with typeclass_instances.
intros x Hx.
apply relative_error_N with (emin + prec - 1)%Z...
apply relative_error_FLT_aux.
Qed.

(** 1+#ε# property in rounding to nearest in FLT *)
Theorem relative_error_N_FLT_ex :
  forall x,
  (bpow (emin + prec - 1) <= Rabs x)%R ->
  exists eps,
  (Rabs eps <= /2 * bpow (-prec + 1))%R /\ round beta (FLT_exp emin prec) (Znearest choice) x = (x * (1 + eps))%R.
Proof with auto with typeclass_instances.
intros x Hx.
apply relative_error_le_conversion...
apply Rlt_le.
apply Rmult_lt_0_compat.
apply Rinv_0_lt_compat.
now apply (Z2R_lt 0 2).
apply bpow_gt_0.
now apply relative_error_N_FLT.
Qed.

Theorem relative_error_N_FLT_round :
  forall x,
  (bpow (emin + prec - 1) <= Rabs x)%R ->
  (Rabs (round beta (FLT_exp emin prec) (Znearest choice) x - x) <= /2 * bpow (-prec + 1) * Rabs (round beta (FLT_exp emin prec) (Znearest choice) x))%R.
Proof with auto with typeclass_instances.
intros x Hx.
apply relative_error_N_round with (emin + prec - 1)%Z...
apply relative_error_FLT_aux.
Qed.

Theorem relative_error_N_FLT_F2R_emin :
  forall m, let x := F2R (Float beta m (emin + prec - 1)) in
  (Rabs (round beta (FLT_exp emin prec) (Znearest choice) x - x) <= /2 * bpow (-prec + 1) * Rabs x)%R.
Proof with auto with typeclass_instances.
intros m x.
apply relative_error_N_F2R_emin...
apply relative_error_FLT_aux.
Qed.

Theorem relative_error_N_FLT_F2R_emin_ex :
  forall m, let x := F2R (Float beta m (emin + prec - 1)) in
  exists eps,
  (Rabs eps <= /2 * bpow (-prec + 1))%R /\ round beta (FLT_exp emin prec) (Znearest choice) x = (x * (1 + eps))%R.
Proof with auto with typeclass_instances.
intros m x.
apply relative_error_le_conversion...
apply Rlt_le.
apply Rmult_lt_0_compat.
apply Rinv_0_lt_compat.
now apply (Z2R_lt 0 2).
apply bpow_gt_0.
now apply relative_error_N_FLT_F2R_emin.
Qed.

Theorem relative_error_N_FLT_round_F2R_emin :
  forall m, let x := F2R (Float beta m (emin + prec - 1)) in
  (Rabs (round beta (FLT_exp emin prec) (Znearest choice) x - x) <= /2 * bpow (-prec + 1) * Rabs (round beta (FLT_exp emin prec) (Znearest choice) x))%R.
Proof with auto with typeclass_instances.
intros m x.
apply relative_error_N_round_F2R_emin...
apply relative_error_FLT_aux.
Qed.

Lemma error_N_FLT_aux :
  forall x,
  (0 < x)%R ->
  exists eps, exists  eta,
  (Rabs eps <= /2 * bpow (-prec + 1))%R /\
  (Rabs eta <= /2 * bpow (emin))%R      /\
  (eps*eta=0)%R /\
  round beta (FLT_exp emin prec) (Znearest choice) x = (x * (1 + eps) + eta)%R.
Proof.
intros x Hx2.
case (Rle_or_lt (bpow (emin+prec)) x); intros Hx.
(* *)
destruct relative_error_N_ex with (FLT_exp emin prec) (emin+prec)%Z prec choice x
  as (eps,(Heps1,Heps2)).
now apply FLT_exp_valid.
intros; unfold FLT_exp.
rewrite Zmax_left; omega.
rewrite Rabs_right;[assumption|apply Rle_ge; now left].
exists eps; exists 0%R.
split;[assumption|split].
rewrite Rabs_R0; apply Rmult_le_pos.
auto with real.
apply bpow_ge_0.
split;[apply Rmult_0_r|idtac].
now rewrite Rplus_0_r.
(* *)
exists 0%R; exists (round beta (FLT_exp emin prec) (Znearest choice) x - x)%R.
split.
rewrite Rabs_R0; apply Rmult_le_pos.
auto with real.
apply bpow_ge_0.
split.
apply Rle_trans with (/2*ulp beta (FLT_exp emin prec) x)%R.
apply ulp_half_error.
now apply FLT_exp_valid.
apply Rmult_le_compat_l; auto with real.
unfold ulp.
apply bpow_le.
unfold FLT_exp, canonic_exp.
rewrite Zmax_right.
omega.
destruct (ln_beta beta x) as (e,He); simpl.
assert (e-1 < emin+prec)%Z.
apply (lt_bpow beta).
apply Rle_lt_trans with (2:=Hx).
rewrite <- (Rabs_right x).
apply He; auto with real.
apply Rle_ge; now left.
omega.
split;ring.
Qed.

End Fprop_relative_FLT.

Section Fprop_relative_FLX.

Variable prec : Z.
Variable Hp : Zlt 0 prec.

Lemma relative_error_FLX_aux :
  forall k, (prec <= k - FLX_exp prec k)%Z.
Proof.
intros k.
unfold FLX_exp.
omega.
Qed.

Variable rnd : R -> Z.
Context { valid_rnd : Valid_rnd rnd }.

Theorem relative_error_FLX :
  forall x,
  (x <> 0)%R ->
  (Rabs (round beta (FLX_exp prec) rnd x - x) < bpow (-prec + 1) * Rabs x)%R.
Proof with auto with typeclass_instances.
intros x Hx.
destruct (ln_beta beta x) as (ex, He).
specialize (He Hx).
apply relative_error with (ex - 1)%Z...
intros k _.
apply relative_error_FLX_aux.
apply He.
Qed.

(** 1+#ε# property in any rounding in FLX *)
Theorem relative_error_FLX_ex :
  forall x,
  (x <> 0)%R ->
  exists eps,
  (Rabs eps < bpow (-prec + 1))%R /\ round beta (FLX_exp prec) rnd x = (x * (1 + eps))%R.
Proof with auto with typeclass_instances.
intros x Hx.
apply relative_error_lt_conversion...
apply bpow_gt_0.
now apply relative_error_FLX.
Qed.

Theorem relative_error_FLX_round :
  forall x,
  (x <> 0)%R ->
  (Rabs (round beta (FLX_exp prec) rnd x - x) < bpow (-prec + 1) * Rabs (round beta (FLX_exp prec) rnd x))%R.
Proof with auto with typeclass_instances.
intros x Hx.
destruct (ln_beta beta x) as (ex, He).
specialize (He Hx).
apply relative_error_round with (ex - 1)%Z...
intros k _.
apply relative_error_FLX_aux.
apply He.
Qed.

Variable choice : Z -> bool.

Theorem relative_error_N_FLX :
  forall x,
  (Rabs (round beta (FLX_exp prec) (Znearest choice) x - x) <= /2 * bpow (-prec + 1) * Rabs x)%R.
Proof with auto with typeclass_instances.
intros x.
destruct (Req_dec x 0) as [Hx|Hx].
(* . *)
rewrite Hx, round_0...
unfold Rminus.
rewrite Rplus_0_l, Rabs_Ropp, Rabs_R0.
rewrite Rmult_0_r.
apply Rle_refl.
(* . *)
destruct (ln_beta beta x) as (ex, He).
specialize (He Hx).
apply relative_error_N with (ex - 1)%Z...
intros k _.
apply relative_error_FLX_aux.
apply He.
Qed.

(** 1+#ε# property in rounding to nearest in FLX *)
Theorem relative_error_N_FLX_ex :
  forall x,
  exists eps,
  (Rabs eps <= /2 * bpow (-prec + 1))%R /\ round beta (FLX_exp prec) (Znearest choice) x = (x * (1 + eps))%R.
Proof with auto with typeclass_instances.
intros x.
apply relative_error_le_conversion...
apply Rlt_le.
apply Rmult_lt_0_compat.
apply Rinv_0_lt_compat.
now apply (Z2R_lt 0 2).
apply bpow_gt_0.
now apply relative_error_N_FLX.
Qed.

Theorem relative_error_N_FLX_round :
  forall x,
  (Rabs (round beta (FLX_exp prec) (Znearest choice) x - x) <= /2 * bpow (-prec + 1) * Rabs (round beta (FLX_exp prec) (Znearest choice) x))%R.
Proof with auto with typeclass_instances.
intros x.
destruct (Req_dec x 0) as [Hx|Hx].
(* . *)
rewrite Hx, round_0...
unfold Rminus.
rewrite Rplus_0_l, Rabs_Ropp, Rabs_R0.
rewrite Rmult_0_r.
apply Rle_refl.
(* . *)
destruct (ln_beta beta x) as (ex, He).
specialize (He Hx).
apply relative_error_N_round with (ex - 1)%Z.
now apply FLX_exp_valid.
intros k _.
apply relative_error_FLX_aux.
exact Hp.
apply He.
Qed.

End Fprop_relative_FLX.

End Fprop_relative.


From Hammer Require Import Hammer.

Require Import ExtLib.Core.RelDec.
Require Import ExtLib.Tactics.Consider.
Require Import ExtLib.Tactics.Injection.

Set Implicit Arguments.
Set Strict Implicit.

Section PairParam.
Variable T : Type.
Variable eqT : T -> T -> Prop.
Variable U : Type.
Variable eqU : U -> U -> Prop.

Inductive sum_eq : T + U -> T + U -> Prop :=
| Inl_eq : forall a b, eqT a b -> sum_eq (inl a) (inl b)
| Inr_eq : forall a b, eqU a b -> sum_eq (inr a) (inr b).

Variable EDT : RelDec eqT.
Variable EDU : RelDec eqU.

Global Instance RelDec_equ_sum
: RelDec (sum_eq) :=
{ rel_dec := fun x y =>
match x , y with
| inl x , inl y => rel_dec x y
| inr x , inr y => rel_dec x y
| inl _ , inr _ => false
| inr _ , inl _ => false
end }.

Variable EDCT : RelDec_Correct EDT.
Variable EDCU : RelDec_Correct EDU.

Global Instance RelDec_Correct_equ_sum : RelDec_Correct RelDec_equ_sum.
Proof. hammer_hook "Sum" "Sum.RelDec_Correct_equ_sum".
constructor; destruct x; destruct y; split; simpl in *; intros;
repeat match goal with
| [ H : context [ rel_dec ?X ?Y ] |- _ ] =>
consider (rel_dec X Y); intros; subst
| [ |- context [ rel_dec ?X ?Y ] ] =>
consider (rel_dec X Y); intros; subst
end; intuition; try solve [ constructor; auto | congruence ].
+ inversion H. intuition.
+ inversion H.
+ inversion H.
+ inversion H; intuition.
Qed.
End PairParam.

Section SumEq.
Variable T : Type.
Variable U : Type.

Variable EDT : RelDec (@eq T).
Variable EDU : RelDec (@eq U).

Global Instance RelDec_eq_pair : RelDec (@eq (T + U)) :=
{ rel_dec := fun x y =>
match x , y with
| inl x , inl y => rel_dec x y
| inr x , inr y => rel_dec x y
| inl _ , inr _ => false
| inr _ , inl _ => false
end }.

Variable EDCT : RelDec_Correct EDT.
Variable EDCU : RelDec_Correct EDU.

Global Instance RelDec_Correct_eq_pair : RelDec_Correct RelDec_eq_pair.
Proof. hammer_hook "Sum" "Sum.RelDec_Correct_eq_pair".
constructor; destruct x; destruct y; split; simpl in *; intros;
repeat match goal with
| [ H : context [ rel_dec ?X ?Y ] |- _ ] =>
consider (rel_dec X Y); intros; subst
| [ |- context [ rel_dec ?X ?Y ] ] =>
consider (rel_dec X Y); intros; subst
end; congruence.
Qed.
End SumEq.

Global Instance Injective_inl T U a c : Injective (@inl T U a = inl c).
refine {| result := a = c |}.
Proof. hammer_hook "Sum" "Sum.Injective_inl". abstract (inversion 1; intuition). Defined.

Global Instance Injective_inr T U a c : Injective (@inr T U a = inr c).
refine {| result := a = c |}.
Proof. hammer_hook "Sum" "Sum.Injective_inr". abstract (inversion 1; intuition). Defined.

Global Instance Injective_inl_False T U a c : Injective (@inl T U a = inr c).
refine {| result := False |}.
Proof. hammer_hook "Sum" "Sum.Injective_inl_False". abstract (inversion 1; intuition). Defined.

Global Instance Injective_inr_False T U a c : Injective (@inr T U a = inl c).
refine {| result := False |}.
Proof. hammer_hook "Sum" "Sum.Injective_inr_False". abstract (inversion 1; intuition). Defined.


From Coq.Logic Require Import ConstructiveEpsilon.
Require Import Lia Arith List Bool.

(** ** Classical logical axioms  *)

Definition LEM := forall P, P \/ ~ P.
Definition DNE := forall P, ~~P -> P.
Definition CP : Prop := forall X Y : Prop, (~Y -> ~X) -> X -> Y.        (* contraposition *)
Definition Peirce := forall P Q : Prop, ((P -> Q) -> P) -> P.

Goal LEM -> DNE.
unfold LEM, DNE.
intros.
specialize (H P).
unfold not in H0.
destruct H.
- assumption.
- specialize (H0 H).
  contradiction.
Qed.

Goal DNE -> CP.
unfold DNE, CP.
intros.
  apply (H Y).
  unfold not in *.
  intros.
  apply H0.
  apply H2.
  assumption.
Qed.

Goal CP -> Peirce.
	unfold CP, Peirce.
  intros.

  specialize (H P Q) as HPQ.
  intros.
  unfold not in *.
Admitted.

Lemma nnLEM : forall P, ~~ (P \/ ~ P).
intros.
  unfold not.
  intro.
  apply H.
  right.
  intro.
  apply H.
  left.
  assumption.
Qed.

Goal forall p : nat -> Prop, (exists n, p n) -> ~~ exists n, p n /\ forall k, p k -> n <= k.
  intros.
  unfold not.
  intros.
  apply H0.
  destruct H.
  exists x.
  split.
  assumption.
  intros.

Admitted.

Goal Peirce -> forall philosophers_stone infinite_gold : Prop, philosophers_stone \/ (philosophers_stone -> infinite_gold). Admitted.

Goal Peirce -> LEM.
  unfold Peirce, LEM.
  intros.
Admitted.

Definition DGP := forall P Q : Prop, (P -> Q) \/ (Q -> P).
Definition WLEM := forall P, ~~P \/ ~ P.

(* Optional *) Goal LEM -> DGP. Admitted.

(* Optional *) Goal DGP -> WLEM. Admitted.

Definition IP := forall (P : Prop), forall p : nat -> Prop, (P -> exists n, p n) -> exists n, P -> p n.

(* Optional *) Goal LEM -> IP. Admitted.

(* Decidability, semi-decidability *)

Definition semi_decidable {X} (p : X -> Prop) :=
  exists f : X -> nat -> bool, forall x, p x <-> exists n, f x n = true.

Definition co_semi_decidable {X} (p : X -> Prop) :=
  exists f : X -> nat -> bool, forall x, p x <-> forall n, f x n = false.

Definition decidable {X} (p : X -> Prop) :=
  exists f : X -> bool, forall x, p x <-> f x = true.

Lemma decidable_semi_decidable {X} (p : X -> Prop) :
  decidable p -> semi_decidable p.
  unfold decidable, semi_decidable.
  intros.
  destruct H.
  unfold iff in H.

  exists (fun x0 n => x x0).

Admitted.

(*

    LEM --> DGP --> WLEM
     |               |
     |               |
     v               v
    LPO     -->    WLPO   -->   LLPO
     ^               ^
     |               |
     v               v
  MP /\ WLPO     PFP /\ LLPO

     ^
     |

  MP /\ IP

 *)

Definition LPO := forall f : nat -> bool, (exists n, f n = true) \/ ~ (exists n, f n = true).
Definition WLPO := forall f : nat -> bool, (forall n, f n = false) \/ ~ (forall n, f n = false).

Lemma forall_neg_exists_iff (f : nat -> bool) :
  (forall n, f n = false) <-> ~ exists n, f n = true.
Proof.
  unfold iff.
  split; intro.
  - unfold not.
    intro.
    destruct H0.
    specialize (H x).
    rewrite H0 in H.
    inversion H.
  - unfold not in H.
    intro.

Admitted.

Goal LEM -> LPO.
  unfold LEM,LPO.
  intros.
  specialize (H (exists n : nat, f n = true)).
  assumption.
Qed.

Goal WLEM -> WLPO.
  unfold WLEM, WLPO.
  intros.
  specialize (H (forall n : nat, f n = false)).

  destruct H.
  - eapply nnLEM.
  - right.
    assumption.

Admitted.

Goal LPO -> WLPO. Admitted.

Definition LPO_semidecidable := forall X (p : X -> Prop), semi_decidable p -> forall x, p x \/ ~ p x.

Lemma LPO_semidecidable_iff :
  LPO <-> LPO_semidecidable.
Proof.
  split.
  - intros H X p [f Hf] x.
    rewrite Hf. eapply H.
  - intros H f.
    eapply (H unit (fun _ => exists n, f n = true)).
    exists (fun _ => f). cbv. intuition. econstructor.
Qed.

Definition WLPO_semidecidable := forall X (p : X -> Prop), semi_decidable p -> forall x, ~ p x \/ ~~ p x.

Goal WLPO <-> WLPO_semidecidable.
Admitted.

Definition WLPO_cosemidecidable := forall X (p : X -> Prop), co_semi_decidable p -> forall x, p x \/ ~ p x.

Goal WLPO_cosemidecidable <-> WLPO_semidecidable.
Admitted.

Definition MP := forall f : nat -> bool, ~~ (exists n, f n = true) -> exists n, f n = true.

Goal LPO <-> MP /\ WLPO. Admitted.

Goal IP -> MP -> LPO. Admitted.

(** ** Choice axioms *)

(* (** ** Provable choice axioms  *) *)

Definition AC_on X Y :=
  forall R : X -> Y -> Prop, (forall x, exists y, R x y) -> exists f : X -> Y, forall x, R x (f x).

Definition AC := forall X Y, AC_on X Y.

Lemma AC_iff_commute :
  AC <-> forall X (A : X -> Type), (forall x, inhabited (A x)) -> inhabited (forall x, A x).
Proof.
  split.
  - intros ac X A HA.
    destruct (ac X {x & A x} (fun x '(existT _ x' ax) => x = x')) as [f Hf].
    all: admit.
  - intros H X Y R Htot.
Admitted.

Definition UNIF_on X Y := forall R : X -> Y -> Prop,
  (forall x, exists y, R x y) -> exists R' : X -> Y -> Prop, (forall x y, R' x y -> R x y) /\ (forall x, exists! y, R' x y).

Definition AUC_on X Y :=
  forall R : X -> Y -> Prop, (forall x, exists! y, R x y) -> exists f : X -> Y, forall x, R x (f x).

Definition AC_0_0 :=
  AC_on nat nat.

Definition AC_1_0 :=
  AC_on (nat -> nat) nat.

Definition ADC_on X := forall R : X -> X -> Prop, forall x0, (forall x, exists x', R x x') -> exists f : nat -> X, f 0 = x0 /\ forall n, R (f n) (f (S n)).

Definition ADC := forall X, ADC_on X.
Definition ACC := forall X, AC_on nat X.

Goal forall X Y,
  AC_on X Y <-> AUC_on X Y /\ UNIF_on X Y.
Proof. Admitted.

(** ** Extensionality axioms  *)

Definition Fext := forall X Y (f g : X -> Y), (forall x, f x = g x) -> f = g.
Definition Pext := forall P Q : Prop, P <-> Q -> P = Q.
Definition hProp (P : Type) := forall x1 x2 : P, x1 = x2.
Definition PI := forall P : Prop, hProp P.

Lemma Pext_to_PI : Pext -> PI. Admitted.

Lemma hProp_disj (P Q : Prop) :
  hProp P -> hProp Q -> ~ (P /\ Q) -> hProp (P \/ Q).
Proof. Admitted.

Lemma Fext_hProp_neg P :
  Fext -> hProp (~ P).
Proof.
  intros fext H1 H2.
  eapply fext. intros x. exfalso. tauto.
Qed.

Lemma Fext_hProp_disj (P : Prop) :
  Fext -> hProp P -> hProp (P \/ ~ P).
Proof.
  intros. now eapply hProp_disj; [ | eapply Fext_hProp_neg | ].
Qed.

Lemma Diaconescu :
  (forall X Y, AC_on X Y) -> Fext -> Pext -> LEM.
Proof.
  intros C fext pext P.
  pose (U (x : bool) := x = true \/ P).
  pose (V (x : bool) := x = false \/ P).
  destruct (C ({ p : bool -> Prop | p = U \/ p = V}) bool (fun p b => (proj1_sig p b))) as [f Hf].
  - admit.
  - pose proof (Hf (exist _ U (or_introl eq_refl))) as H1.
    pose proof (Hf (exist _ V (or_intror eq_refl))) as H2. cbn in *.
    admit.
Admitted.

(* bijection from nat * nat to nat *)
Definition embed '(x, y) : nat :=
  y + (nat_rec _ 0 (fun i m => (S i) + m) (y + x)).

(* bijection from nat to nat * nat *)
Definition unembed (n : nat) : nat * nat :=
  nat_rec _ (0, 0) (fun _ '(x, y) => match x with S x => (x, S y) | _ => (S y, 0) end) n.

Lemma embedP {xy: nat * nat} : unembed (embed xy) = xy.
Proof.
  assert (forall n, embed xy = n -> unembed n = xy).
    intro n. revert xy. induction n as [|n IH].
      intros [[|?] [|?]]; intro H; inversion H; reflexivity.
    intros [x [|y]]; simpl.
      case x as [|x]; simpl; intro H.
        inversion H.
      rewrite (IH (0, x)); [reflexivity|].
      inversion H; simpl. rewrite Nat.add_0_r. reflexivity.
    intro H. rewrite (IH (S x, y)); [reflexivity|].
    inversion H. simpl. rewrite Nat.add_succ_r. reflexivity.
  apply H. reflexivity.
Qed.

Lemma unembedP {n: nat} : embed (unembed n) = n.
Proof.
  induction n as [|n IH]; [reflexivity|].
  simpl. revert IH. case (unembed n). intros x y.
  case x as [|x]; intro Hx; rewrite <- Hx; simpl.
    rewrite Nat.add_0_r. reflexivity.
  rewrite ?Nat.add_succ_r. simpl. rewrite ?Nat.add_succ_r. reflexivity.
Qed.
Arguments embed : simpl never.

Module EmbedNatNotations.
  Notation "âŸ¨ a , b âŸ©" := (embed (a, b)) (at level 0).
  Notation "'fun!' 'âŸ¨' x ',' y 'âŸ©' '=>' b" := (fun p => let (x,y) := unembed p in b) (at level 30, b at level 200).
End EmbedNatNotations.

Import EmbedNatNotations.

Lemma decidable_AC X :
  forall R : X -> nat -> Prop, decidable (uncurry R) -> (forall x, exists n, R x n) -> exists f, forall x, R x (f x).
Proof.
  intros R [f Hf] Htot.
  assert (H : forall x, exists n, f (x, n) = true).  { intros x. destruct (Htot x) as [y]. exists y. now eapply Hf. }
  eexists (fun x => proj1_sig (constructive_indefinite_ground_description_nat _ _ (H x))).
  intros x. destruct constructive_indefinite_ground_description_nat as [n Hn]; cbn.
  eapply (Hf (x, n)), Hn.
  Unshelve. intros. cbn. destruct f; firstorder congruence.
Qed.

Lemma semi_decidable_AC X (R : X -> nat -> Prop) :
  semi_decidable (uncurry R) ->
  (forall x, exists y, R x y) ->
  exists f : X -> nat, forall x, R x (f x).
Proof.
  intros [g Hg] Htot'. red in Hg. unfold uncurry in *.
  pose (R' x := fun! âŸ¨n,mâŸ© => g (x,n) m = true).
  assert (Htot : forall x, exists n, R' x n). {
    subst R'. intros x. destruct (Htot' x) as (n & [m H] % (Hg (_, _))).
    exists âŸ¨n,mâŸ©. now rewrite embedP.
  }
  assert (Hdec : decidable (uncurry R')). {
    exists  (fun '(x, nm) => let (n, m) := unembed nm in g (x, n) m).
    unfold R'. unfold uncurry. intros (x, nm). destruct (unembed nm) as (n, m).
    destruct g; firstorder congruence.
  }
  eapply (decidable_AC _ _ Hdec) in Htot as [f' Hf'].
  exists (fun x => (fun! âŸ¨n, mâŸ© => n) (f' x)).
  intros x. subst R'. specialize (Hf' x). cbn in Hf'.
  destruct (unembed (f' x)). eapply (Hg (_, _)). eauto.
Qed.

Lemma sdec_compute_lor {X} {p q : X -> Prop} :
  semi_decidable p -> semi_decidable q -> (forall x, p x \/ q x) -> exists f : X -> bool, forall x, if f x then p x else q x.
Proof.
  intros Hp Hq Hpq.
  edestruct (semi_decidable_AC X (fun x n => match n with 0 => p x | _ => q x end)) as [f Hf].
  - destruct Hp as [f1 H1], Hq as [f2 H2].
    exists (fun '(x,n) m => match n with 0 => f1 x m | _ => f2 x m end).
    now intros (x,[]); cbn; rewrite ?H1, ?H2.
  - intros x. destruct (Hpq x). now exists 0. now exists 1.
  - exists (fun x => match f x with 0 => true | _ => false end). intros x.
    specialize (Hf x). destruct (f x); firstorder.
Qed.

Lemma AUC_to_dec (p : nat -> Prop) :
  AUC_on nat bool -> (forall n, p n \/ ~ p n) -> decidable p.
Proof.
  admit.
Admitted.

(* Markov's principle and Post's theorem *)

Definition MP_semidecidable := forall X (p : X -> Prop), semi_decidable p -> forall x, ~~ p x -> p x.
Definition Post_logical := forall X (p : X -> Prop), semi_decidable p -> semi_decidable (fun x => ~ p x) -> forall x, p x \/ ~ p x.
Definition Post := forall X (p : X -> Prop), semi_decidable p -> semi_decidable (fun x => ~ p x) -> decidable p.

Lemma MP_to_MP_semidecidable :
  MP -> MP_semidecidable.
Proof.
Admitted.

Lemma semi_decidable_or {X} {p q : X -> Prop} :
  semi_decidable p -> semi_decidable q -> semi_decidable (fun x => p x \/ q x).
Proof. Admitted.

Lemma MP_semidecidable_to_Post_logical :
  MP_semidecidable -> Post_logical.
Proof. Admitted.

Lemma Post_logical_to_Post :
  Post_logical -> Post.
Proof. Admitted.

Lemma Post_nempty_to_MP {X} (x0 : X) :
  (forall (p : X -> Prop), semi_decidable p -> semi_decidable (fun x => ~ p x) -> decidable p) -> MP.
Proof. Admitted.

Lemma Post_to_MP :
  Post -> MP.
Proof. Admitted.


Require Export XR_Rmult_lt_reg_r.
Require Export XR_Rmult_assoc.
Require Export XR_Rinv_l.
Require Export XR_Rlt_not_eq.
Require Export XR_Rmult_neq_0_reg.

Local Open Scope R_scope.

Lemma Rinv_lt_contravar : forall r1 r2,
  R0 < r1 * r2 ->
  r1 < r2 ->
  / r2 < / r1.
Proof.
  intros x y h hxy.
  apply Rmult_lt_reg_r with (x*y).
  { exact h. }
  {
    apply Rlt_not_eq in h.
    apply not_eq_sym in h.
    apply Rmult_neq_0_reg in h.
    destruct h as [ hx hy ].
    pattern (x*y) at 1 ; rewrite (Rmult_comm x).
    repeat rewrite <- Rmult_assoc.
    rewrite Rinv_l.
    {
      rewrite Rinv_l.
      {
        rewrite Rmult_1_l.
        rewrite Rmult_1_l.
        exact hxy.
      }
      { exact hx. }
    }
    { exact hy. }
  }
Qed.


Require Export Structure.

Module Pointed.
Section category.
Context {C: TopCategory}.

Structure obj := Obj {
  carrier: C;
  element: 1 ~> carrier;
}.

Local Coercion carrier: obj >-> Category.obj.

Structure hom (X Y: obj) := Hom {
  arr: X ~> Y;
  comm: arr ∘ element X = element Y;
}.

Global Arguments Hom {X Y} arr comm.
Global Arguments arr {X Y} _.
Global Arguments comm {X Y} _.
Local Coercion arr: hom >-> Categories.hom.

Lemma obj_eq (X Y: obj): X = Y <-> carrier X = Y /\ forall e: carrier X = Y, eq_iso e ∘ element X = element Y.
Proof.
  split.
  + intros H.
    subst Y.
    split.
    reflexivity.
    intros e.
    rewrite eq_iso_refl; clear e.
    apply comp_id_l.
  + destruct X as [X x], Y as [Y y].
    simpl.
    intros [Hc He].
    subst Y.
    specialize (He eq_refl).
    simpl in He.
    rewrite comp_id_l in He.
    now f_equal.
Qed.

Lemma hom_eq {X Y: obj} (f g: hom X Y): f = g <-> arr f = g.
Proof.
  split.
  intros H.
  now subst g.
  destruct f as [f Hf], g as [g Hg].
  simpl.
  intros H.
  subst g.
  f_equal.
  apply proof_irrelevance.
Qed.

Let id (X: obj): hom X X := {|
  arr := id X;
  comm := comp_id_l (element X);
|}.

Program Let comp {X Y Z: obj} (f: hom Y Z) (g: hom X Y): hom X Z := {|
  arr := f ∘ g;
|}.
Next Obligation.
  rewrite <- comp_assoc.
  rewrite comm.
  apply comm.
Qed.

Lemma comp_assoc {X Y Z V: obj} (f: hom Z V) (g: hom Y Z) (h: hom X Y): comp f (comp g h) = comp (comp f g) h.
Proof.
  apply hom_eq; simpl.
  apply comp_assoc.
Qed.

Lemma comp_id_l {X Y: obj} (f: hom X Y): comp (id Y) f = f.
Proof.
  apply hom_eq; simpl.
  apply comp_id_l.
Qed.

Lemma comp_id_r {X Y: obj} (f: hom X Y): comp f (id X) = f.
Proof.
  apply hom_eq; simpl.
  apply comp_id_r.
Qed.

Definition cat_mixin: Category.mixin_of obj :=
  Category.Mixin obj hom id (@comp) (@comp_assoc) (@comp_id_l) (@comp_id_r).

Definition cat := Category.Pack obj cat_mixin.

End category.

Arguments obj C: clear implicits.
Arguments cat_mixin C: clear implicits.
Arguments cat C: clear implicits.

Program Definition forget {C: TopCategory}: Functor (cat C) C := {|
  fobj := carrier;
  fmap := @arr C;
|}.

End Pointed.

Notation Pointed := Pointed.cat.


(* -*- mode: coq; mode: visual-line -*- *)
(** Contractibility *)

Require Import Overture PathGroupoids.
Local Open Scope path_scope.

(** Naming convention: we consistently abbreviate "contractible" as "contr".  A theorem about a space [X] being contractible (which will usually be an instance of the typeclass [Contr]) is called [contr_X]. *)

(** Allow ourselves to implicitly generalize over types [A] and [B], and a function [f]. *)
Generalizable Variables A B f.

(** If a space is contractible, then any two points in it are connected by a path in a canonical way. *)
Definition path_contr `{Contr A} (x y : A) : x = y
  := (contr x)^ @ (contr y).

(** Similarly, any two parallel paths in a contractible space are homotopic, which is just the principle UIP. *)
Definition path2_contr `{Contr A} {x y : A} (p q : x = y) : p = q.
Proof.
  assert (K : forall (r : x = y), r = path_contr x y).
  - intro r; destruct r; symmetry; now apply concat_Vp.
  - transitivity (path_contr x y);auto with path_hints.
Defined.

(** It follows that any space of paths in a contractible space is contractible. *)
(** Because [Contr] is a notation, and [Contr_internal] is the record, we need to iota expand to fool Coq's typeclass machinery into accepting supposedly "mismatched" contexts. *)

Global Instance contr_paths_contr `{Contr A} (x y : A) : Contr (x = y) | 10000 := let c := {|
  center := (contr x)^ @ contr y;
  contr := path2_contr ((contr x)^ @ contr y)
|} in c.

(** Also, the total space of any based path space is contractible.  We define the [contr] fields as separate definitions, so that we can give them [simpl nomatch] annotations. *)

Definition path_basedpaths {X : Type} {x y : X} (p : x = y)
: (x;1) = (y;p) :> {z:X & x=z}.
Proof.
  destruct p; reflexivity.
Defined.

Arguments path_basedpaths {X x y} p : simpl nomatch.

Global Instance contr_basedpaths {X : Type} (x : X) : Contr {y : X & x = y} | 100.
Proof.
  exists (x ; 1).
  intros [y p]; apply path_basedpaths.
Defined.

(* Sometimes we end up with a sigma of a one-sided path type that's not eta-expanded, which Coq doesn't seem able to match with the previous instance. *)
Global Instance contr_basedpaths_etashort {X : Type} (x : X) : Contr (sigT (@paths X x)) | 100
  := contr_basedpaths x.

Definition path_basedpaths' {X : Type} {x y : X} (p : y = x)
: (x;1) = (y;p) :> {z:X & z=x}.
Proof.
  destruct p; reflexivity.
Defined.

Global Instance contr_basedpaths' {X : Type} (x : X) : Contr {y : X & y = x} | 100.
Proof.
  refine (Build_Contr _ (x;1) _).
  intros [y p]; apply path_basedpaths'.
Defined.

Arguments path_basedpaths' {X x y} p : simpl nomatch.

(** Some useful computation laws for based path spaces *)

Definition ap_pr1_path_contr_basedpaths {X : Type}
           {x y z : X} (p : x = y) (q : x = z)
: ap pr1 (path_contr ((y;p):{y':X & x = y'}) (z;q)) = p^ @ q.
Proof.
  destruct p,q; reflexivity.
Defined.

Definition ap_pr1_path_contr_basedpaths' {X : Type}
           {x y z : X} (p : y = x) (q : z = x)
: ap pr1 (path_contr ((y;p):{y':X & y' = x}) (z;q)) = p @ q^.
Proof.
  destruct p,q; reflexivity.
Defined.

Definition ap_pr1_path_basedpaths {X : Type}
           {x y : X} (p : x = y)
: ap pr1 (path_basedpaths p) = p.
Proof.
  destruct p; reflexivity.
Defined.

Definition ap_pr1_path_basedpaths' {X : Type}
           {x y : X} (p : y = x)
: ap pr1 (path_basedpaths' p) = p^.
Proof.
  destruct p; reflexivity.
Defined.

(** If the domain is contractible, the function is propositionally constant. *)
Definition contr_dom_equiv {A B} (f : A -> B) `{Contr A} : forall x y : A, f x = f y
  := fun x y => ap f ((contr x)^ @ contr y).

(** Any retract of a contractible type is contractible *)
Definition contr_retract {X Y : Type} `{Contr X}
           (r : X -> Y) (s : Y -> X) (h : forall y, r (s y) = y)
  : Contr Y
  := Build_Contr _ (r (center X)) (fun y => (ap r (contr _)) @ h _).


Inductive day : Type :=
  | monday
  | tuesday
  | wednesday
  | thursday
  | friday
  | saturday
  | sunday.

Definition aday : day := thursday.

Inductive list (a : Type) : Type :=
  | nil
  | cons : a -> list a -> list a.

Definition xs : list nat := cons nat 5 (nil nat).

Variable A : Type.

Definition length2 (a : Type) (xs : list a) : nat :=
  match xs with
  | nil _ => 0
  | cons _ x xs => 0
  end.

(* Eval compute in length2 nat (cons nat 0 (nil nat)). *)

Inductive Product (a : Type) (b : Type) : Type :=
  P : a -> b -> Product a b.

Definition swap (a:Type) (b:Type) (p : Product a b) : (Product b a) :=
  match p with
  | P _ _ x y => P b a y x
  end.

Eval compute in swap nat day (P nat day 0 monday).

Variable a : Type.
Variable b : Type.
Variable p : Product a b.

Example swap_prop_1: swap b a (swap a b (p : Product a b)) = p.
Proof.
simpl.
destruct p.
simpl.
reflexivity.
Qed.