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

(** * refl

Pierre Letouzey & Laurent Thery

Construct a function of type [Expr -> Prop]
*)

From Coq Require Import ZArith.
From Stalmarck Require Import normalize.
From Coq Require Import Classical.
From Stalmarck Require Import sTactic.

Section refl.
Variable fmap : rNat -> Prop.
Hypothesis fmapO : fmap zero.

(** Standard translation of boolean expression to Propositions, f is the function
 that gives meaning to boolean variables *)
Fixpoint ExprToProp (e : Expr) : Prop :=
  match e with
  | V n => fmap n
  | normalize.N e' => ~ ExprToProp e'
  | Node ANd e1' e2' => ExprToProp e1' /\ ExprToProp e2'
  | Node Or e1' e2' => ExprToProp e1' \/ ExprToProp e2'
  | Node Impl e1' e2' => ExprToProp e1' -> ExprToProp e2'
  | Node normalize.Eq e1' e2' => ExprToProp e1' <-> ExprToProp e2'
  end.

(** A variable n is in a boolean expression *)
Inductive inExpr (n : rNat) : Expr -> Prop :=
  | inV : inExpr n (V n)
  | inN : forall e : Expr, inExpr n e -> inExpr n (normalize.N e)
  | inNodeLeft :
      forall (i : boolOp) (e1 e2 : Expr),
      inExpr n e1 -> inExpr n (Node i e1 e2)
  | inNodeRight :
      forall (i : boolOp) (e1 e2 : Expr),
      inExpr n e2 -> inExpr n (Node i e1 e2).

#[local] Hint Resolve inV inN inNodeLeft inNodeRight : stalmarck.

(** This is of course decidable *)
Definition inExprDec :
  forall (a : rNat) (e : Expr), {inExpr a e} + {~ inExpr a e}.
intros a e; elim e.
intros r; case (rNatDec a r).
intros H'; rewrite <- H'; auto with stalmarck.
intros H'; right; red in |- *; intros H'0; case H'; inversion H'0; auto with stalmarck.
intros e0 H'; case H'; intros H'0; auto with stalmarck.
right; red in |- *; intros H'1; case H'0; inversion H'1; auto with stalmarck.
intros b e0 H' e1 H'0; case H'; intros H'1; auto with stalmarck.
case H'0; intros H'2; auto with stalmarck.
right; red in |- *; intros H'3; generalize H'2 H'1; inversion H'3; intuition.
Defined.

(** There is a function that gives true to all the variable whose interpretation
    by f are True *)
Theorem ExprToPropF :
 forall e : Expr,
 exists f : rNat -> bool,
   f zero = true /\
   (forall n : rNat, inExpr n e -> fmap n -> f n = true) /\
   (forall n : rNat, inExpr n e -> ~ fmap n -> f n = false).
Proof.
intros e; elim e; simpl in |- *; auto with stalmarck.
intros r.
case (rNatDec r zero); auto with stalmarck.
intros H'; exists (fun n : rNat => true).
rewrite H'; split; auto with stalmarck; split; auto with stalmarck.
intros n H'0; inversion H'0; auto with stalmarck.
intros H'1; case H'1; auto with stalmarck.
intros H'; case (classic (fmap r)); intros H'1.
exists (fun n : rNat => true); simpl in |- *; split; auto with stalmarck; split; auto with stalmarck.
intros n H'0; inversion H'0; auto with stalmarck.
intros H'2; case H'2; auto with stalmarck.
exists
 (fun n : rNat =>
  match rNatDec r n with
  | left _ => false
  | right _ => true
  end); simpl in |- *.
split.
case (rNatDec r zero); auto with stalmarck.
split; intros n H'0; inversion H'0; case (rNatDec r r); auto with stalmarck.
intros H'2 H'3; case H'1; auto with stalmarck.
case H'2; auto with stalmarck.
intros e0 H'; Elimc H'; intros f E; Elimc E; intros H' H'0; Elimc H'0;
 intros H'0 H'1.
exists f; split; auto with stalmarck.
split; intros n H'2; inversion H'2; auto with stalmarck.
intros b e0 H' e1 H'0.
Elimc H'; intros f E; Elimc E; intros H' H'1; Elimc H'1; intros H'1 H'2.
Elimc H'0; intros f0 E; Elimc E; intros H'0 H'3; Elimc H'3; intros H'3 H'4.
exists
 (fun n : rNat =>
  match inExprDec n e0 with
  | left _ => f n
  | right _ => f0 n
  end); simpl in |- *.
split.
case (inExprDec zero e0); auto with stalmarck.
split; intros n H'5 H'6; inversion H'5; case (inExprDec n e0); auto with stalmarck.
intros H'7; case H'7; auto with stalmarck.
Qed.

(** The precedent condition is sufficient to insure correctness of the translation *)
Theorem ExprToPropF2 :
 forall (e : Expr) (f : rNat -> bool),
 (forall n : rNat, inExpr n e -> fmap n -> f n = true) ->
 (forall n : rNat, inExpr n e -> ~ fmap n -> f n = false) ->
 (Eval f e = true -> ExprToProp e) /\ (Eval f e = false -> ~ ExprToProp e).
intros e; Elimc e; simpl in |- *; auto with stalmarck.
intros r f H' H'0; split; case (classic (fmap r)); auto with stalmarck.
intros H'1 H'2; absurd (f r = false); auto with stalmarck.
rewrite H'2; red in |- *; intros H'3; discriminate.
intros H'1 H'2; absurd (f r = true); auto with stalmarck.
rewrite H'2; red in |- *; intros H'3; discriminate.
intros e H' f H'0 H'1; split; intros H'2; auto with stalmarck.
elim (H' f); [ intros H'6 H'7; apply H'7 | idtac | idtac ]; auto with stalmarck.
generalize H'2; case (Eval f e); auto with stalmarck.
red in |- *; intros H'3; Contradict H'3.
elim (H' f); [ intros H'4 H'5; apply H'4 | idtac | idtac ]; auto with stalmarck.
generalize H'2; case (Eval f e); auto with stalmarck.
intros b e H' e0 H'0 f H'1 H'2.
generalize (H' f) (H'0 f); clear H' H'0; case b; simpl in |- *.
case (Eval f e); simpl in |- *; auto with stalmarck.
case (Eval f e0); simpl in |- *; auto with stalmarck.
intros H' H'0; split; intros H'3; try discriminate.
split.
elim H'; auto with stalmarck.
elim H'0; auto with stalmarck.
intros H' H'0; split; intros H'3; try discriminate.
red in |- *; intros H'4; Elimc H'4; intros H'4 H'5.
absurd (ExprToProp e0); auto with stalmarck.
elim H'0; auto with stalmarck.
intros H' H'0; split; intros H'3; try discriminate.
red in |- *; intros H'4; Elimc H'4; intros H'4 H'5.
absurd (ExprToProp e); auto with stalmarck.
elim H'; auto with stalmarck.
case (Eval f e); simpl in |- *; auto with stalmarck.
intros H' H'0; split; intros H'3; try discriminate.
elim H'; auto with stalmarck.
intros H' H'0; split; intros H'3; try discriminate.
elim H'0; auto with stalmarck.
red in |- *; intros H'4; Elimc H'4; intros H'4.
absurd (ExprToProp e); auto with stalmarck.
elim H'; auto with stalmarck.
absurd (ExprToProp e0); auto with stalmarck.
elim H'0; auto with stalmarck.
case (Eval f e); case (Eval f e0); simpl in |- *; auto with stalmarck.
intros H' H'0; split; intros H'3; try discriminate.
elim H'0; auto with stalmarck.
intros H' H'0; split; intros H'3; try discriminate.
red in |- *; intros H'4.
absurd (ExprToProp e0); auto with stalmarck.
elim H'0; auto with stalmarck.
elim H'; auto with stalmarck.
intros H' H'0; split; intros H'3; try discriminate.
elim H'0; auto with stalmarck.
intros H' H'0; split; intros H'3; try discriminate.
intros H'4; absurd (ExprToProp e); auto with stalmarck.
elim H'; auto with stalmarck.
case (Eval f e); case (Eval f e0); simpl in |- *; auto with stalmarck.
intros H' H'0; split; intros H'3; try discriminate.
red in |- *; split; elim H'0; elim H'; auto with stalmarck.
intros H' H'0; split; intros H'3; try discriminate.
red in |- *; intros H'4; absurd (ExprToProp e); auto with stalmarck.
red in |- *; intros H'5; absurd (ExprToProp e0); auto with stalmarck.
elim H'0; auto with stalmarck.
elim H'4; auto with stalmarck.
elim H'; auto with stalmarck.
intros H' H'0; split; intros H'3; try discriminate.
red in |- *; intros H'4; absurd (ExprToProp e); auto with stalmarck.
elim H'; auto with stalmarck.
cut (ExprToProp e0); auto with stalmarck.
elim H'4; auto with stalmarck.
elim H'0; auto with stalmarck.
intros H' H'0; split; intros H'3; try discriminate.
red in |- *; split; intros H'4.
absurd (ExprToProp e); auto with stalmarck; elim H'; auto with stalmarck.
absurd (ExprToProp e0); auto with stalmarck; elim H'0; auto with stalmarck.
Qed.
(* If e is a tautoly then its translated is True *)

Theorem ExprToPropTautology : forall e : Expr, Tautology e -> ExprToProp e.
Proof.
intros e H'.
elim (ExprToPropF e); intros f E; elim E; intros H'1 H'2; elim H'2;
 intros H'3 H'4; clear H'2 E.
elim (ExprToPropF2 e f); [ intros H'7 H'8; apply H'7 | idtac | idtac ]; auto with stalmarck.
Qed.

End refl.

(** We define arrays on Prop in order to build the function for variables*)

Section rA.

Inductive POption : Type :=
  | PSome : Prop -> POption
  | PNone : POption.

Inductive rTreeP : Type :=
  | rEmptyP : rTreeP
  | rSplitP : POption -> rTreeP -> rTreeP -> rTreeP.

Fixpoint rTreeGetP (t : rTreeP) (r : rNat) {struct r} : POption :=
  match r, t with
  | _, rEmptyP => PNone
  | BinPos.xH, rSplitP a _ _ => a
  | BinPos.xO p, rSplitP _ t' _ => rTreeGetP t' p
  | BinPos.xI p, rSplitP _ _ t' => rTreeGetP t' p
  end.

Fixpoint rTreeSetP (t : rTreeP) (r : rNat) {struct r} :
 Prop -> rTreeP :=
  fun a : Prop =>
  match r, t with
  | BinPos.xH, rEmptyP => rSplitP (PSome a) rEmptyP rEmptyP
  | BinPos.xO p, rEmptyP => rSplitP PNone (rTreeSetP rEmptyP p a) rEmptyP
  | BinPos.xI p, rEmptyP => rSplitP PNone rEmptyP (rTreeSetP rEmptyP p a)
  | BinPos.xH, rSplitP _ t'1 t'2 => rSplitP (PSome a) t'1 t'2
  | BinPos.xO p, rSplitP b t'1 t'2 => rSplitP b (rTreeSetP t'1 p a) t'2
  | BinPos.xI p, rSplitP b t'1 t'2 => rSplitP b t'1 (rTreeSetP t'2 p a)
  end.

Theorem rTreeDef1P :
 forall (t : rTreeP) (m : rNat) (v : Prop),
 rTreeGetP (rTreeSetP t m v) m = PSome v.
Proof.
intros t m; generalize t; Elimc m; simpl in |- *; clear t.
intros p H' t v; case t; auto with stalmarck.
intros p H' t v; case t; auto with stalmarck.
intros t v; case t; auto with stalmarck.
Qed.

Theorem rTreeDef2 :
 forall (t : rTreeP) (m1 m2 : rNat) (v : Prop),
 m1 <> m2 -> rTreeGetP (rTreeSetP t m1 v) m2 = rTreeGetP t m2.
Proof.
intros t m; generalize t; Elimc m; simpl in |- *; clear t.
intros p H' t m2 v; case m2; simpl in |- *; case t; auto with stalmarck.
intros p0 H'0; rewrite H'; auto with stalmarck.
elim p0; simpl in |- *; auto with stalmarck.
Contradict H'0; rewrite H'0; auto with stalmarck.
intros a r1 r2 p0 H'0; rewrite H'; auto with stalmarck.
Contradict H'0; rewrite H'0; auto with stalmarck.
intros p0 H'0; elim p0; simpl in |- *; auto with stalmarck.
intros p H' t m2 v; case m2; simpl in |- *; case t; auto with stalmarck.
intros p0 H'0; elim p0; simpl in |- *; auto with stalmarck.
intros p0 H'0; rewrite H'; auto with stalmarck.
elim p0; simpl in |- *; auto with stalmarck.
Contradict H'0; rewrite H'0; auto with stalmarck.
intros a r1 r2 p0 H'0; rewrite H'; auto with stalmarck.
Contradict H'0; rewrite H'0; auto with stalmarck.
intros t m2 v; case m2; simpl in |- *; auto with stalmarck.
case t; intros p H'; elim p; simpl in |- *; auto with stalmarck.
case t; intros p H'; elim p; simpl in |- *; auto with stalmarck.
intros H'; Contradict H'; auto with stalmarck.
Qed.

Inductive rArrayP : Type :=
    rArrayMakeP : rTreeP -> (rNat -> Prop) -> rArrayP.

Definition rArrayGetP (ar : rArrayP) (r : rNat) :=
  match ar with
  | rArrayMakeP t f => match rTreeGetP t r with
                       | PSome a => a
                       | _ => f r
                       end
  end.

Definition rArraySetP (ar : rArrayP) (r : rNat) (v : Prop) :=
  match ar with
  | rArrayMakeP t f => rArrayMakeP (rTreeSetP t r v) f
  end.

Theorem rArrayDef1P :
 forall (Ar : rArrayP) (m : rNat) (v : Prop),
 rArrayGetP (rArraySetP Ar m v) m = v.
Proof.
intros Ar m v; case Ar; simpl in |- *.
intros r a; rewrite (rTreeDef1P r m v); auto with stalmarck.
Qed.

Theorem rArrayDef2P :
 forall (Ar : rArrayP) (m1 m2 : rNat) (v : Prop),
 m1 <> m2 -> rArrayGetP (rArraySetP Ar m1 v) m2 = rArrayGetP Ar m2.
Proof.
intros Ar m1 m2 v H'; case Ar; simpl in |- *.
intros r a; rewrite (rTreeDef2 r m1 m2 v); auto with stalmarck.
Qed.

Definition rArrayInitP (f : rNat -> Prop) := rArrayMakeP rEmptyP f.

Theorem rArrayDefP :
 forall (m : rNat) (f : rNat -> Prop), rArrayGetP (rArrayInitP f) m = f m.
Proof.
intros m f; simpl in |- *; auto with stalmarck.
elim m; simpl in |- *; auto with stalmarck.
Qed.

End rA.


Require Import Coq.Unicode.Utf8.
Require Export StdlibMisc.
(** printing → $\rightarrow$ #→# *)
(** printing × $\times$ #×# *)

Set Implicit Arguments.
Require Import CoList.

Definition MsgHandlerType (S I O : Type) := S → I → (S × O).

Require Export Coq.Lists.List.

CoFixpoint outMsgsAux {S I O : Type} (st : S) (mh : MsgHandlerType S I O)
           (ins : CoList I) : CoList O :=
  match ins with
    | cnil _ => cnil O
    | ccons h tl => let (ns,out) := (mh st h) in
                    ccons out (outMsgsAux ns mh tl)
  end.

Definition mkPureHandler {In Out}
 (f : In → Out) : MsgHandlerType unit In Out :=
 λ st inp, (st, f inp).

Record Process (In Out : Type) :Type := {
  State : Type;
  curState : State;
  handler : MsgHandlerType State In Out
}.

Definition procOutMsgs {I O : Type} (p : Process I O)
           (ins : CoList I) : CoList O :=
  outMsgsAux (curState p) (handler p) ins.

Definition getOutput {In Out : Type}
  (p: Process In Out) (inp : In ): Out :=
 snd ((handler p) (curState p) inp).

Definition applyProc {In Out : Type}
  (p: Process In Out) (inp : In ): (State p) * Out :=
((handler p) (curState p) inp).

Definition updateState {In Out : Type}
  (p: Process In Out) (state : State p)
 := {| State := State p; curState := state; handler := handler p|}.

Definition getNewProc {In Out : Type}
  (p: Process In Out) (inp : In ): Process In Out :=
updateState p (fst ((handler p) (curState p) inp)).

(* outermost event is the last event *)
Fixpoint getNewProcL  {In Out : Type}
  (p: Process In Out) (linp : list In ): Process In Out :=
match linp with
| nil => p
| hi::tli => getNewProc (getNewProcL p tli) hi
end.

Definition mkPureProcess {In Out}
 (f : In -> Out) : Process In Out :=
{| State := _; curState := tt; handler := mkPureHandler f|}.

Lemma getNewProcLPure : forall
    {In Out : Type}
    (f : In -> Out)
    (prefix : list In),
  getNewProcL (mkPureProcess f) prefix = (mkPureProcess f).
Proof.
  induction prefix; simpl;[ reflexivity| ].
  rewrite IHprefix.
  unfold getNewProc.
  simpl. reflexivity.
Qed.

Definition getLastOutput  {In Out : Type}
    (p: Process In Out)
    (prefix : list In)
    (last : In) : Out :=
  let procBeforeLast := getNewProcL p prefix in
  getOutput procBeforeLast last.

Lemma getLastOutputPure : forall
    {In Out : Type}
    (f : In -> Out)
    (prefix : list In)
    (last : In),
  getLastOutput (mkPureProcess f) prefix last
  = f last.
Proof.
  intros.
  unfold getLastOutput.
  rewrite getNewProcLPure.
  reflexivity.
Qed.

Definition getLastOutputL  {In Out : Type}
    (p: Process In (list Out))
    (allInputs : list In)  : list Out :=
    match allInputs with
    | nil => nil
    | last :: rest => getLastOutput p rest last
    end.


From Undecidability.L Require Import Tactics.LTactics Datatypes.LBool Tactics.GenEncode.
From Undecidability.L Require Import Functions.EqBool.
Import L_Notations.

(* ** Encoding of option type *)
Section Fix_X.
  Variable X:Type.
  Context {intX : encodable X}.

  MetaCoq Run (tmGenEncode "option_enc" (option X)).
  Hint Resolve option_enc_correct : Lrewrite.

  Global Instance encInj_option_enc {H : encInj intX} : encInj (encodable_option_enc).
  Proof. register_inj. Qed.

  (* now we must register the non-constant constructors*)

  Global Instance term_Some : computable (@Some X).
  Proof.
    extract constructor.
  Defined. (*because next lemma*)

End Fix_X.

#[export] Hint Resolve option_enc_correct : Lrewrite.

Section option_eqb.

  Variable X : Type.
  Variable eqb : X -> X -> bool.
  Variable spec : forall x y, reflect (x = y) (eqb x y).

  Definition option_eqb (A B : option X) :=
    match A,B with
    | None,None => true
    | Some x, Some y => eqb x y
    | _,_ => false
    end.

  Lemma option_eqb_spec A B : reflect (A = B) (option_eqb A B).
  Proof using spec.
    destruct A, B; try now econstructor. cbn.
    destruct (spec x x0); econstructor; congruence.
  Qed.
End option_eqb.

Section int.

  Variable X:Type.
  Context {HX : encodable X}.

  Global Instance term_option_eqb : computable (@option_eqb X).
  Proof.
    extract.
  Qed.

  Global Instance eqbOption f `{eqbClass (X:=X) f}:
    eqbClass (option_eqb f).
  Proof.
    intros ? ?. eapply option_eqb_spec. all:eauto using eqb_spec.
  Qed.

  Global Instance eqbComp_Option `{H:eqbComp X (R:=HX)}:
    eqbComp (option X).
  Proof.
    constructor. unfold option_eqb.
    change (eqb0) with (eqb (X:=X)).
    extract.
  Qed.

End int.

Definition isSome {T} (u : option T) := match u with Some _ => true | _ => false end.

#[global]
Instance term_isSome {T} `{encodable T} : computable (@isSome T).
Proof.
  extract.
Qed.

#[global]
Instance term_option_map {A B} `{encodable A} `{encodable B} : computable (@option_map A B).
Proof.
  extract.
Qed.


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

Copyright (C) 2011-2018 Sylvie Boldo
#<br />#
Copyright (C) 2011-2018 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.
*)

(** * IEEE-754 encoding of binary floating-point data *)
Require Import Core Digits Binary.

Section Binary_Bits.

Arguments exist {A} {P}.
Arguments B754_zero {prec} {emax}.
Arguments B754_infinity {prec} {emax}.
Arguments B754_nan {prec} {emax}.
Arguments B754_finite {prec} {emax}.

(** Number of bits for the fraction and exponent *)
Variable mw ew : Z.

Definition join_bits (s : bool) m e :=
  (Z.shiftl ((if s then Zpower 2 ew else 0) + e) mw + m)%Z.

Lemma join_bits_range :
  forall s m e,
  (0 <= m < 2^mw)%Z ->
  (0 <= e < 2^ew)%Z ->
  (0 <= join_bits s m e < 2 ^ (mw + ew + 1))%Z.
Proof.
intros s m e Hm He.
assert (0 <= mw)%Z as Hmw.
  destruct mw as [|mw'|mw'] ; try easy.
  clear -Hm ; simpl in Hm ; omega.
assert (0 <= ew)%Z as Hew.
  destruct ew as [|ew'|ew'] ; try easy.
  clear -He ; simpl in He ; omega.
unfold join_bits.
rewrite Z.shiftl_mul_pow2 by easy.
split.
- apply (Zplus_le_compat 0 _ 0) with (2 := proj1 Hm).
  rewrite <- (Zmult_0_l (2^mw)).
  apply Zmult_le_compat_r.
  case s.
  clear -He ; omega.
  now rewrite Zmult_0_l.
  clear -Hm ; omega.
- apply Zlt_le_trans with (((if s then 2 ^ ew else 0) + e + 1) * 2 ^ mw)%Z.
  rewrite (Zmult_plus_distr_l _ 1).
  apply Zplus_lt_compat_l.
  now rewrite Zmult_1_l.
  rewrite <- (Zplus_assoc mw), (Zplus_comm mw), Zpower_plus.
  apply Zmult_le_compat_r.
  rewrite Zpower_plus by easy.
  change (2^1)%Z with 2%Z.
  case s ; clear -He ; omega.
  clear -Hm ; omega.
  clear -Hew ; omega.
  easy.
Qed.

Definition split_bits x :=
  let mm := Zpower 2 mw in
  let em := Zpower 2 ew in
  (Zle_bool (mm * em) x, Zmod x mm, Zmod (Zdiv x mm) em)%Z.

Theorem split_join_bits :
  forall s m e,
  (0 <= m < Zpower 2 mw)%Z ->
  (0 <= e < Zpower 2 ew)%Z ->
  split_bits (join_bits s m e) = (s, m, e).
Proof.
intros s m e Hm He.
assert (0 <= mw)%Z as Hmw.
  destruct mw as [|mw'|mw'] ; try easy.
  clear -Hm ; simpl in Hm ; omega.
assert (0 <= ew)%Z as Hew.
  destruct ew as [|ew'|ew'] ; try easy.
  clear -He ; simpl in He ; omega.
unfold split_bits, join_bits.
rewrite Z.shiftl_mul_pow2 by easy.
apply f_equal2 ; [apply f_equal2|].
- case s.
  + apply Zle_bool_true.
    apply Zle_0_minus_le.
    ring_simplify.
    apply Zplus_le_0_compat.
    apply Zmult_le_0_compat.
    apply He.
    clear -Hm ; omega.
    apply Hm.
  + apply Zle_bool_false.
    apply Zplus_lt_reg_l with (2^mw * (-e))%Z.
    replace (2 ^ mw * - e + ((0 + e) * 2 ^ mw + m))%Z with (m * 1)%Z by ring.
    rewrite <- Zmult_plus_distr_r.
    apply Zlt_le_trans with (2^mw * 1)%Z.
    now apply Zmult_lt_compat_r.
    apply Zmult_le_compat_l.
    clear -He ; omega.
    clear -Hm ; omega.
- rewrite Zplus_comm.
  rewrite Z_mod_plus_full.
  now apply Zmod_small.
- rewrite Z_div_plus_full_l by (clear -Hm ; omega).
  rewrite Zdiv_small with (1 := Hm).
  rewrite Zplus_0_r.
  case s.
  + replace (2^ew + e)%Z with (e + 1 * 2^ew)%Z by ring.
    rewrite Z_mod_plus_full.
    now apply Zmod_small.
  + now apply Zmod_small.
Qed.

Hypothesis Hmw : (0 < mw)%Z.
Hypothesis Hew : (0 < ew)%Z.

Let emax := Zpower 2 (ew - 1).
Let prec := (mw + 1)%Z.
Let emin := (3 - emax - prec)%Z.
Let binary_float := binary_float prec emax.

Let Hprec : (0 < prec)%Z.
Proof.
unfold prec.
apply Zle_lt_succ.
now apply Zlt_le_weak.
Qed.

Let Hm_gt_0 : (0 < 2^mw)%Z.
Proof.
apply (Zpower_gt_0 radix2).
now apply Zlt_le_weak.
Qed.

Let He_gt_0 : (0 < 2^ew)%Z.
Proof.
apply (Zpower_gt_0 radix2).
now apply Zlt_le_weak.
Qed.

Hypothesis Hmax : (prec < emax)%Z.

Theorem join_split_bits :
  forall x,
  (0 <= x < Zpower 2 (mw + ew + 1))%Z ->
  let '(s, m, e) := split_bits x in
  join_bits s m e = x.
Proof.
intros x Hx.
unfold split_bits, join_bits.
rewrite Z.shiftl_mul_pow2 by now apply Zlt_le_weak.
pattern x at 4 ; rewrite Z_div_mod_eq_full with x (2^mw)%Z.
apply (f_equal (fun v => (v + _)%Z)).
rewrite Zmult_comm.
apply f_equal.
pattern (x / (2^mw))%Z at 2 ; rewrite Z_div_mod_eq_full with (x / (2^mw))%Z (2^ew)%Z.
apply (f_equal (fun v => (v + _)%Z)).
replace (x / 2 ^ mw / 2 ^ ew)%Z with (if Zle_bool (2 ^ mw * 2 ^ ew) x then 1 else 0)%Z.
case Zle_bool.
now rewrite Zmult_1_r.
now rewrite Zmult_0_r.
rewrite Zdiv_Zdiv.
apply sym_eq.
case Zle_bool_spec ; intros Hs.
apply Zle_antisym.
cut (x / (2^mw * 2^ew) < 2)%Z. clear ; omega.
apply Zdiv_lt_upper_bound.
now apply Zmult_lt_0_compat.
rewrite <- Zpower_exp ; try ( apply Zle_ge ; apply Zlt_le_weak ; assumption ).
change 2%Z at 1 with (Zpower 2 1).
rewrite <- Zpower_exp.
now rewrite Zplus_comm.
discriminate.
apply Zle_ge.
now apply Zplus_le_0_compat ; apply Zlt_le_weak.
apply Zdiv_le_lower_bound.
now apply Zmult_lt_0_compat.
now rewrite Zmult_1_l.
apply Zdiv_small.
now split.
now apply Zlt_le_weak.
now apply Zlt_le_weak.
now apply Zgt_not_eq.
now apply Zgt_not_eq.
Qed.

Theorem split_bits_inj :
  forall x y,
  (0 <= x < Zpower 2 (mw + ew + 1))%Z ->
  (0 <= y < Zpower 2 (mw + ew + 1))%Z ->
  split_bits x = split_bits y ->
  x = y.
Proof.
intros x y Hx Hy.
generalize (join_split_bits x Hx) (join_split_bits y Hy).
destruct (split_bits x) as ((sx, mx), ex).
destruct (split_bits y) as ((sy, my), ey).
intros Jx Jy H. revert Jx Jy.
inversion_clear H.
intros Jx Jy.
now rewrite <- Jx.
Qed.

Definition bits_of_binary_float (x : binary_float) :=
  match x with
  | B754_zero sx => join_bits sx 0 0
  | B754_infinity sx => join_bits sx 0 (Zpower 2 ew - 1)
  | B754_nan sx plx _ => join_bits sx (Zpos plx) (Zpower 2 ew - 1)
  | B754_finite sx mx ex _ =>
    let m := (Zpos mx - Zpower 2 mw)%Z in
    if Zle_bool 0 m then
      join_bits sx m (ex - emin + 1)
    else
      join_bits sx (Zpos mx) 0
  end.

Definition split_bits_of_binary_float (x : binary_float) :=
  match x with
  | B754_zero sx => (sx, 0, 0)%Z
  | B754_infinity sx => (sx, 0, Zpower 2 ew - 1)%Z
  | B754_nan sx plx _ => (sx, Zpos plx, Zpower 2 ew - 1)%Z
  | B754_finite sx mx ex _ =>
    let m := (Zpos mx - Zpower 2 mw)%Z in
    if Zle_bool 0 m then
      (sx, m, ex - emin + 1)%Z
    else
      (sx, Zpos mx, 0)%Z
  end.

Theorem split_bits_of_binary_float_correct :
  forall x,
  split_bits (bits_of_binary_float x) = split_bits_of_binary_float x.
Proof.
intros [sx|sx|sx plx Hplx|sx mx ex Hx] ;
  try ( simpl ; apply split_join_bits ; split ; try apply Zle_refl ; try apply Zlt_pred ; trivial ; omega ).
simpl. apply split_join_bits; split; try (zify; omega).
destruct (digits2_Pnat_correct plx).
unfold nan_pl in Hplx.
rewrite Zpos_digits2_pos, <- Z_of_nat_S_digits2_Pnat in Hplx.
rewrite Zpower_nat_Z in H0.
eapply Zlt_le_trans. apply H0.
change 2%Z with (radix_val radix2). apply Zpower_le.
rewrite Z.ltb_lt in Hplx.
unfold prec in *. zify; omega.
(* *)
unfold bits_of_binary_float, split_bits_of_binary_float.
assert (Hf: (emin <= ex /\ Zdigits radix2 (Zpos mx) <= prec)%Z).
destruct (andb_prop _ _ Hx) as (Hx', _).
unfold canonical_mantissa in Hx'.
rewrite Zpos_digits2_pos in Hx'.
generalize (Zeq_bool_eq _ _ Hx').
unfold FLT_exp.
unfold emin.
clear ; zify ; omega.
case Zle_bool_spec ; intros H ;
  [ apply -> Z.le_0_sub in H | apply -> Z.lt_sub_0 in H ] ;
  apply split_join_bits ; try now split.
(* *)
split.
clear -He_gt_0 H ; omega.
cut (Zpos mx < 2 * 2^mw)%Z. clear ; omega.
replace (2 * 2^mw)%Z with (2^prec)%Z.
apply (Zpower_gt_Zdigits radix2 _ (Zpos mx)).
apply Hf.
unfold prec.
rewrite Zplus_comm.
apply Zpower_exp ; apply Zle_ge.
discriminate.
now apply Zlt_le_weak.
(* *)
split.
generalize (proj1 Hf).
clear ; omega.
destruct (andb_prop _ _ Hx) as (_, Hx').
unfold emin.
replace (2^ew)%Z with (2 * emax)%Z.
generalize (Zle_bool_imp_le _ _ Hx').
clear ; omega.
apply sym_eq.
rewrite (Zsucc_pred ew).
unfold Zsucc.
rewrite Zplus_comm.
apply Zpower_exp ; apply Zle_ge.
discriminate.
now apply Zlt_0_le_0_pred.
Qed.

Theorem bits_of_binary_float_range:
  forall x, (0 <= bits_of_binary_float x < 2^(mw+ew+1))%Z.
Proof.
unfold bits_of_binary_float.
intros [sx|sx|sx pl pl_range|sx mx ex H].
- apply join_bits_range ; now split.
- apply join_bits_range.
  now split.
  clear -He_gt_0 ; omega.
- apply Z.ltb_lt in pl_range.
  apply join_bits_range.
  split.
  easy.
  apply (Zpower_gt_Zdigits radix2 _ (Zpos pl)).
  apply Z.lt_succ_r.
  now rewrite <- Zdigits2_Zdigits.
  clear -He_gt_0 ; omega.
- unfold bounded in H.
  apply Bool.andb_true_iff in H ; destruct H as [A B].
  apply Z.leb_le in B.
  unfold canonical_mantissa, FLT_exp in A. apply Zeq_bool_eq in A.
  case Zle_bool_spec ; intros H.
  + apply join_bits_range.
    * split.
      clear -H ; omega.
      rewrite Zpos_digits2_pos in A.
      cut (Zpos mx < 2 ^ prec)%Z.
      unfold prec.
      rewrite Zpower_plus by (clear -Hmw ; omega).
      change (2^1)%Z with 2%Z.
      clear ; omega.
      apply (Zpower_gt_Zdigits radix2 _ (Zpos mx)).
      clear -A ; zify ; omega.
    * split.
      unfold emin ; clear -A ; zify ; omega.
      replace ew with ((ew - 1) + 1)%Z by ring.
      rewrite Zpower_plus by (clear - Hew ; omega).
      unfold emin, emax in *.
      change (2^1)%Z with 2%Z.
      clear -B ; omega.
  + apply -> Z.lt_sub_0 in H.
    apply join_bits_range ; now split.
Qed.

Definition binary_float_of_bits_aux x :=
  let '(sx, mx, ex) := split_bits x in
  if Zeq_bool ex 0 then
    match mx with
    | Z0 => F754_zero sx
    | Zpos px => F754_finite sx px emin
    | Zneg _ => F754_nan false xH (* dummy *)
    end
  else if Zeq_bool ex (Zpower 2 ew - 1) then
    match mx with
      | Z0 => F754_infinity sx
      | Zpos plx => F754_nan sx plx
      | Zneg _ => F754_nan false xH (* dummy *)
    end
  else
    match (mx + Zpower 2 mw)%Z with
    | Zpos px => F754_finite sx px (ex + emin - 1)
    | _ => F754_nan false xH (* dummy *)
    end.

Lemma binary_float_of_bits_aux_correct :
  forall x,
  valid_binary prec emax (binary_float_of_bits_aux x) = true.
Proof.
intros x.
unfold binary_float_of_bits_aux, split_bits.
assert (Hnan: nan_pl prec 1 = true).
  apply Z.ltb_lt.
  simpl. unfold prec.
  clear -Hmw ; omega.
case Zeq_bool_spec ; intros He1.
case_eq (x mod 2^mw)%Z ; try easy.
(* subnormal *)
intros px Hm.
assert (Zdigits radix2 (Zpos px) <= mw)%Z.
apply Zdigits_le_Zpower.
simpl.
rewrite <- Hm.
eapply Z_mod_lt.
now apply Zlt_gt.
apply bounded_canonical_lt_emax ; try assumption.
unfold canonical, cexp.
fold emin.
rewrite mag_F2R_Zdigits. 2: discriminate.
unfold Fexp, FLT_exp.
apply sym_eq.
apply Zmax_right.
clear -H Hprec.
unfold prec ; omega.
apply Rnot_le_lt.
intros H0.
refine (_ (mag_le radix2 _ _ _ H0)).
rewrite mag_bpow.
rewrite mag_F2R_Zdigits. 2: discriminate.
unfold emin, prec.
apply Zlt_not_le.
cut (0 < emax)%Z. clear -H Hew ; omega.
apply (Zpower_gt_0 radix2).
clear -Hew ; omega.
apply bpow_gt_0.
case Zeq_bool_spec ; intros He2.
case_eq (x mod 2 ^ mw)%Z; try easy.
(* nan *)
intros plx Eqplx. apply Z.ltb_lt.
rewrite Zpos_digits2_pos.
assert (forall a b, a <= b -> a < b+1)%Z by (intros; omega). apply H. clear H.
apply Zdigits_le_Zpower. simpl.
rewrite <- Eqplx. edestruct Z_mod_lt; eauto.
change 2%Z with (radix_val radix2).
apply Z.lt_gt, Zpower_gt_0. omega.
case_eq (x mod 2^mw + 2^mw)%Z ; try easy.
(* normal *)
intros px Hm.
assert (prec = Zdigits radix2 (Zpos px)).
(* . *)
rewrite Zdigits_mag. 2: discriminate.
apply sym_eq.
apply mag_unique.
rewrite <- abs_IZR.
unfold Zabs.
replace (prec - 1)%Z with mw by ( unfold prec ; ring ).
rewrite <- IZR_Zpower with (1 := Zlt_le_weak _ _ Hmw).
rewrite <- IZR_Zpower. 2: now apply Zlt_le_weak.
rewrite <- Hm.
split.
apply IZR_le.
change (radix2^mw)%Z with (0 + 2^mw)%Z.
apply Zplus_le_compat_r.
eapply Z_mod_lt.
now apply Zlt_gt.
apply IZR_lt.
unfold prec.
rewrite Zpower_exp. 2: now apply Zle_ge ; apply Zlt_le_weak. 2: discriminate.
rewrite <- Zplus_diag_eq_mult_2.
apply Zplus_lt_compat_r.
eapply Z_mod_lt.
now apply Zlt_gt.
(* . *)
apply bounded_canonical_lt_emax ; try assumption.
unfold canonical, cexp.
rewrite mag_F2R_Zdigits. 2: discriminate.
unfold Fexp, FLT_exp.
rewrite <- H.
set (ex := ((x / 2^mw) mod 2^ew)%Z).
replace (prec + (ex + emin - 1) - prec)%Z with (ex + emin - 1)%Z by ring.
apply sym_eq.
apply Zmax_left.
revert He1.
fold ex.
cut (0 <= ex)%Z.
unfold emin.
clear ; intros H1 H2 ; omega.
eapply Z_mod_lt.
apply Zlt_gt.
apply (Zpower_gt_0 radix2).
now apply Zlt_le_weak.
apply Rnot_le_lt.
intros H0.
refine (_ (mag_le radix2 _ _ _ H0)).
rewrite mag_bpow.
rewrite mag_F2R_Zdigits. 2: discriminate.
rewrite <- H.
apply Zlt_not_le.
unfold emin.
apply Zplus_lt_reg_r with (emax - 1)%Z.
ring_simplify.
revert He2.
set (ex := ((x / 2^mw) mod 2^ew)%Z).
cut (ex < 2^ew)%Z.
replace (2^ew)%Z with (2 * emax)%Z.
clear ; intros H1 H2 ; omega.
replace ew with (1 + (ew - 1))%Z by ring.
rewrite Zpower_exp.
apply refl_equal.
discriminate.
clear -Hew ; omega.
eapply Z_mod_lt.
apply Zlt_gt.
apply (Zpower_gt_0 radix2).
now apply Zlt_le_weak.
apply bpow_gt_0.
Qed.

Definition binary_float_of_bits x :=
  FF2B prec emax _ (binary_float_of_bits_aux_correct x).

Theorem binary_float_of_bits_of_binary_float :
  forall x,
  binary_float_of_bits (bits_of_binary_float x) = x.
Proof.
intros x.
apply B2FF_inj.
unfold binary_float_of_bits.
rewrite B2FF_FF2B.
unfold binary_float_of_bits_aux.
rewrite split_bits_of_binary_float_correct.
destruct x as [sx|sx|sx plx Hplx|sx mx ex Bx].
apply refl_equal.
(* *)
simpl.
rewrite Zeq_bool_false.
now rewrite Zeq_bool_true.
cut (1 < 2^ew)%Z. clear ; omega.
now apply (Zpower_gt_1 radix2).
(* *)
simpl.
rewrite Zeq_bool_false.
rewrite Zeq_bool_true; auto.
cut (1 < 2^ew)%Z. clear ; omega.
now apply (Zpower_gt_1 radix2).
(* *)
unfold split_bits_of_binary_float.
case Zle_bool_spec ; intros Hm.
(* . *)
rewrite Zeq_bool_false.
rewrite Zeq_bool_false.
now ring_simplify (Zpos mx - 2 ^ mw + 2 ^ mw)%Z (ex - emin + 1 + emin - 1)%Z.
destruct (andb_prop _ _ Bx) as (_, H1).
generalize (Zle_bool_imp_le _ _ H1).
unfold emin.
replace (2^ew)%Z with (2 * emax)%Z.
clear ; omega.
replace ew with (1 + (ew - 1))%Z by ring.
rewrite Zpower_exp.
apply refl_equal.
discriminate.
clear -Hew ; omega.
destruct (andb_prop _ _ Bx) as (H1, _).
generalize (Zeq_bool_eq _ _ H1).
rewrite Zpos_digits2_pos.
unfold FLT_exp, emin.
generalize (Zdigits radix2 (Zpos mx)).
clear.
intros ; zify ; omega.
(* . *)
rewrite Zeq_bool_true. 2: apply refl_equal.
simpl.
apply f_equal.
destruct (andb_prop _ _ Bx) as (H1, _).
generalize (Zeq_bool_eq _ _ H1).
rewrite Zpos_digits2_pos.
unfold FLT_exp, emin, prec.
apply -> Z.lt_sub_0 in Hm.
generalize (Zdigits_le_Zpower radix2 _ (Zpos mx) Hm).
generalize (Zdigits radix2 (Zpos mx)).
clear.
intros ; zify ; omega.
Qed.

Theorem bits_of_binary_float_of_bits :
  forall x,
  (0 <= x < 2^(mw+ew+1))%Z ->
  bits_of_binary_float (binary_float_of_bits x) = x.
Proof.
intros x Hx.
unfold binary_float_of_bits, bits_of_binary_float.
set (Cx := binary_float_of_bits_aux_correct x).
clearbody Cx.
rewrite match_FF2B.
revert Cx.
generalize (join_split_bits x Hx).
unfold binary_float_of_bits_aux.
case_eq (split_bits x).
intros (sx, mx) ex Sx.
assert (Bm: (0 <= mx < 2^mw)%Z).
inversion_clear Sx.
apply Z_mod_lt.
now apply Zlt_gt.
case Zeq_bool_spec ; intros He1.
(* subnormal *)
case_eq mx.
intros Hm Jx _.
now rewrite He1 in Jx.
intros px Hm Jx _.
rewrite Zle_bool_false.
now rewrite <- He1.
apply <- Z.lt_sub_0.
now rewrite <- Hm.
intros px Hm _ _.
apply False_ind.
apply Zle_not_lt with (1 := proj1 Bm).
now rewrite Hm.
case Zeq_bool_spec ; intros He2.
(* infinity/nan *)
case_eq mx; intros Hm.
now rewrite He2.
now rewrite He2.
intros. zify; omega.
(* normal *)
case_eq (mx + 2 ^ mw)%Z.
intros Hm.
apply False_ind.
clear -Bm Hm ; omega.
intros p Hm Jx Cx.
rewrite <- Hm.
rewrite Zle_bool_true.
now ring_simplify (mx + 2^mw - 2^mw)%Z (ex + emin - 1 - emin + 1)%Z.
now ring_simplify.
intros p Hm.
apply False_ind.
clear -Bm Hm ; zify ; omega.
Qed.

End Binary_Bits.

(** Specialization for IEEE single precision operations *)
Section B32_Bits.

Arguments B754_nan {prec} {emax}.

Definition binary32 := binary_float 24 128.

Let Hprec : (0 < 24)%Z.
Proof.
apply refl_equal.
Qed.

Let Hprec_emax : (24 < 128)%Z.
Proof.
apply refl_equal.
Qed.

Definition default_nan_pl32 : { nan : binary32 | is_nan 24 128 nan = true } :=
  exist _ (@B754_nan 24 128 false (iter_nat xO 22 xH) (refl_equal true)) (refl_equal true).

Definition unop_nan_pl32 (f : binary32) : { nan : binary32 | is_nan 24 128 nan = true } :=
  match f as f with
  | B754_nan s pl Hpl => exist _ (B754_nan s pl Hpl) (refl_equal true)
  | _ => default_nan_pl32
  end.

Definition binop_nan_pl32 (f1 f2 : binary32) : { nan : binary32 | is_nan 24 128 nan = true } :=
  match f1, f2 with
  | B754_nan s1 pl1 Hpl1, _ => exist _ (B754_nan s1 pl1 Hpl1) (refl_equal true)
  | _, B754_nan s2 pl2 Hpl2 => exist _ (B754_nan s2 pl2 Hpl2) (refl_equal true)
  | _, _ => default_nan_pl32
  end.

Definition b32_erase : binary32 -> binary32 := erase 24 128.
Definition b32_opp : binary32 -> binary32 := Bopp 24 128 unop_nan_pl32.
Definition b32_abs : binary32 -> binary32 := Babs 24 128 unop_nan_pl32.
Definition b32_sqrt :  mode -> binary32 -> binary32 := Bsqrt  _ _ Hprec Hprec_emax unop_nan_pl32.

Definition b32_plus :  mode -> binary32 -> binary32 -> binary32 := Bplus  _ _ Hprec Hprec_emax binop_nan_pl32.
Definition b32_minus : mode -> binary32 -> binary32 -> binary32 := Bminus _ _ Hprec Hprec_emax binop_nan_pl32.
Definition b32_mult :  mode -> binary32 -> binary32 -> binary32 := Bmult  _ _ Hprec Hprec_emax binop_nan_pl32.
Definition b32_div :   mode -> binary32 -> binary32 -> binary32 := Bdiv   _ _ Hprec Hprec_emax binop_nan_pl32.

Definition b32_compare : binary32 -> binary32 -> option comparison := Bcompare 24 128.
Definition b32_of_bits : Z -> binary32 := binary_float_of_bits 23 8 (refl_equal _) (refl_equal _) (refl_equal _).
Definition bits_of_b32 : binary32 -> Z := bits_of_binary_float 23 8.

End B32_Bits.

(** Specialization for IEEE double precision operations *)
Section B64_Bits.

Arguments B754_nan {prec} {emax}.

Definition binary64 := binary_float 53 1024.

Let Hprec : (0 < 53)%Z.
Proof.
apply refl_equal.
Qed.

Let Hprec_emax : (53 < 1024)%Z.
Proof.
apply refl_equal.
Qed.

Definition default_nan_pl64 : { nan : binary64 | is_nan 53 1024 nan = true } :=
  exist _ (@B754_nan 53 1024 false (iter_nat xO 51 xH) (refl_equal true)) (refl_equal true).

Definition unop_nan_pl64 (f : binary64) : { nan : binary64 | is_nan 53 1024 nan = true } :=
  match f as f with
  | B754_nan s pl Hpl => exist _ (B754_nan s pl Hpl) (refl_equal true)
  | _ => default_nan_pl64
  end.

Definition binop_nan_pl64 (f1 f2 : binary64) : { nan : binary64 | is_nan 53 1024 nan = true } :=
  match f1, f2 with
  | B754_nan s1 pl1 Hpl1, _ => exist _ (B754_nan s1 pl1 Hpl1) (refl_equal true)
  | _, B754_nan s2 pl2 Hpl2 => exist _ (B754_nan s2 pl2 Hpl2) (refl_equal true)
  | _, _ => default_nan_pl64
  end.

Definition b64_erase : binary64 -> binary64 := erase 53 1024.
Definition b64_opp : binary64 -> binary64 := Bopp 53 1024 unop_nan_pl64.
Definition b64_abs : binary64 -> binary64 := Babs 53 1024 unop_nan_pl64.
Definition b64_sqrt : mode -> binary64 -> binary64 := Bsqrt _ _ Hprec Hprec_emax unop_nan_pl64.

Definition b64_plus  : mode -> binary64 -> binary64 -> binary64 := Bplus  _ _ Hprec Hprec_emax binop_nan_pl64.
Definition b64_minus : mode -> binary64 -> binary64 -> binary64 := Bminus _ _ Hprec Hprec_emax binop_nan_pl64.
Definition b64_mult  : mode -> binary64 -> binary64 -> binary64 := Bmult  _ _ Hprec Hprec_emax binop_nan_pl64.
Definition b64_div   : mode -> binary64 -> binary64 -> binary64 := Bdiv   _ _ Hprec Hprec_emax binop_nan_pl64.

Definition b64_compare : binary64 -> binary64 -> option comparison := Bcompare 53 1024.
Definition b64_of_bits : Z -> binary64 := binary_float_of_bits 52 11 (refl_equal _) (refl_equal _) (refl_equal _).
Definition bits_of_b64 : binary64 -> Z := bits_of_binary_float 52 11.

End B64_Bits.


Require Export basic.
Require Import Logics.

Reserved Notation "# T" (at level 200).

Set Implicit Arguments.

(***************************************************************************)
(** * 1. Sublogics, wrapped in modules and functors *)

Module Type Sublogic.
  Parameter Inline Tr : Prop -> Prop.
  Parameter TrI : forall P:Prop, P -> Tr P.
  Parameter TrP : forall P:Prop, Tr (Tr P) -> Tr P.
  Parameter TrMono : forall (P Q:Prop), (P->Q)->Tr P->Tr Q.
  Notation "# T" := (Tr T).
End Sublogic.

(** Family of sublogic *)
Module Type SublogicFamily.
  Parameter T : Type.
  Parameter Inline Tr : T -> Prop -> Prop.
  Parameter TrI : forall x (P:Prop), P -> Tr x P.
  Parameter TrP : forall x (P:Prop), Tr x (Tr x P) -> Tr x P.
  Parameter TrMono : forall x (P Q:Prop), (P->Q)->Tr x P->Tr x Q.
End SublogicFamily.

Module Type Type_sig. Parameter T : Type. End Type_sig.
Module Type Elt_sig (T:Type_sig). Parameter x : T.T. End Elt_sig.

Module InstSublogicFamily (L:SublogicFamily) (X:Elt_sig L) <: Sublogic.
  Import X.
  Definition Tr := L.Tr x.
  Definition TrI := L.TrI x.
  Definition TrP := @L.TrP x.
  Definition TrMono := @L.TrMono x.
End InstSublogicFamily.

Module Type ConsistentSublogic.
Include Sublogic.
Parameter TrCons : ~ Tr False.
End ConsistentSublogic.

(** Sublogics are monads *)
Module AlternativeFormulations.

  Module Type LogicMonad.
    Parameter Inline M : Prop -> Prop.
    Parameter ret : forall P:Prop, P -> M P.
    Parameter bind : forall P Q:Prop, M P -> (P -> M Q) -> M Q.
  End LogicMonad.

  Module SublogicToMonad (M:LogicMonad) : Sublogic with Definition Tr := M.M.
    Import M.
    Definition Tr := M.
    Definition TrI (P:Prop) (p:P) : Tr P := ret p.
    Definition TrP (P:Prop) (p:Tr(Tr P)) : Tr P := bind p (fun x => x).
    Definition TrMono (P Q:Prop) (f:P->Q) (p:Tr P) : Tr Q :=
      bind p (fun x => ret (f x)).
  End SublogicToMonad.
  Module MonadToSublogic (L:Sublogic) : LogicMonad with Definition M := L.Tr.
    Import L.
    Definition M := Tr.
    Definition ret (P:Prop) (p:P) : M P := TrI p.
    Definition bind (P Q:Prop) (p:Tr P) (f:P->Tr Q) : Tr Q :=
      TrP (TrMono f p).
  End MonadToSublogic.

End AlternativeFormulations.

(** Sublogic equipped with tools useful for doing logics *)

Module Type SublogicTheory.

Include Sublogic.

Definition isL (P:Prop) := Tr P -> P.

Global Instance Tr_morph : Proper (iff==>iff) Tr.
Admitted.
Global Instance isL_morph : Proper (iff==>iff) isL.
Admitted.

  (* monad bind *)
  Parameter TrB : forall (P Q:Prop), Tr P -> (P -> Tr Q) -> Tr Q.
  Parameter Tr_ind : forall (P Q:Prop) {i:isL Q}, (P -> Q) -> Tr P -> Q.

  (** The set of L-propositions: introduction rules *)
  Parameter Tr_isL : forall P, isL (Tr P).
  Parameter T_isL : forall P:Prop, P -> isL P.
  Parameter and_isL : forall P Q, isL P -> isL Q -> isL (P/\Q).
  Parameter fa_isL : forall A (P:A->Prop),
    (forall x, isL (P x)) -> isL(forall x, P x).
  Parameter imp_isL : forall P Q, isL Q -> isL (P -> Q).
  Parameter iff_isL : forall P Q, isL P -> isL Q -> isL (P <-> Q).

Global Hint Resolve Tr_isL T_isL and_isL fa_isL imp_isL iff_isL.

  Parameter rFF : forall (Q:Prop), Tr False -> Tr Q.
  Parameter rFF': forall (Q:Prop), Tr False -> isL Q -> Q.

(** Introduction tactics *)

Ltac Tin := apply TrI.
Ltac Texists t := Tin; exists t.
Ltac Tleft := Tin; left.
Ltac Tright := Tin; right.

(** Elimination tactics:
    - Tabsurd replaces the current goal with Tr False (ex-falso)
    - Telim H implements rules H:Tr P |- G   -->  |- P->G when G is a L-prop
    - Tdestruct H is the equivalent of destruct on a hypothesis Tr(Ind x).
      The goal shall be an L-prop
 *)

Ltac prove_isL :=
  intros;
  lazymatch goal with
  | |- isL(Tr _) => apply Tr_isL
  | |- isL(_ /\ _) => apply and_isL; prove_isL
  | |- isL True => apply T_isL; exact I
  | |- isL(impl _ _) => apply imp_isL; prove_isL
  | |- isL(iff _ _) => apply iff_isL; prove_isL
  | |- isL(_ -> _) => apply imp_isL; prove_isL
  | |- isL(forall x, _) => apply fa_isL; intro; prove_isL
  | |- isL _ => auto 10; fail "Cannot prove isL side-condition"
  | |- _ => fail "Tactic prove_isL does not apply to this goal"
  end.

Ltac Tabsurd :=
  lazymatch goal with
  | |- Tr _ => apply rFF
  | |- _ => apply rFF';[|auto 10;fail"Cannot prove isL side-condition"]
  end.
Ltac Telim H :=
  lazymatch goal with
  | |- Tr _ => apply TrB with (1:=H); try clear H
  | |- _ => apply Tr_ind with (3:=H);[auto 10;fail"Cannot prove isL side-condition"|]; try clear H
  end.
Tactic Notation "Tdestruct" constr(H) :=
  Telim H; destruct 1.
Tactic Notation "Tdestruct" constr(H) "as" simple_intropattern(p) :=
  Telim H; intros p.

End SublogicTheory.

Module BuildLogic (L:Sublogic) <: SublogicTheory.

Include L.

(** Derived sublogic concepts:
    - more elimination rules (bind of the monad)
    - the set of L-propositions *)

Global Instance Tr_morph : Proper (iff==>iff) Tr.
split; apply TrMono; apply H.
Qed.

Definition isL (P:Prop) := Tr P -> P.

Global Instance isL_morph : Proper (iff==>iff) isL.
do 2 red; intros.
unfold isL; rewrite H; reflexivity.
Qed.

  (* bind *)
  Lemma TrB : forall (P Q:Prop), Tr P -> (P -> Tr Q) -> Tr Q.
intros.
apply TrP; revert H; apply TrMono; auto.
Qed.

  Lemma Tr_ind : forall (P Q:Prop) {i:isL Q}, (P -> Q) -> Tr P -> Q.
intros.
apply i; revert H0; apply TrMono; trivial.
Qed.

(** The set of L-propositions: introduction rules.
    L-props are closed under all connectives of negative
    polarity.
 *)

Lemma Tr_isL : forall P, isL (Tr P).
Proof TrP.

Lemma T_isL : forall P:Prop, P -> isL P.
Proof (fun _ p _ => p).

Lemma and_isL : forall P Q, isL P -> isL Q -> isL (P/\Q).
compute; intros.
split; revert H1; apply Tr_ind; firstorder.
Qed.

Lemma fa_isL : forall A (P:A->Prop),
  (forall x, isL (P x)) -> isL(forall x, P x).
compute; intros.
revert H0; apply Tr_ind; firstorder.
Qed.

Lemma imp_isL : forall P Q, isL Q -> isL (P -> Q).
intros.
apply fa_isL; trivial.
Qed.

Lemma iff_isL : forall P Q, isL P -> isL Q -> isL (P <-> Q).
intros; apply and_isL; apply imp_isL; trivial.
Qed.

Global Hint Resolve Tr_isL T_isL and_isL fa_isL imp_isL iff_isL.

(** Elimination rules for falsity *)

Lemma rFF (Q:Prop) : Tr False -> Tr Q.
apply TrMono; intros; contradiction.
Qed.
Lemma rFF' (Q:Prop) : Tr False -> isL Q -> Q.
intros.
apply H0; apply rFF; trivial.
Qed.
Ltac Tin := apply TrI.
Ltac Texists t := Tin; exists t.
Ltac Tleft := Tin; left.
Ltac Tright := Tin; right.

(** Elimination tactics:
    - Tabsurd replaces the current goal with Tr False (ex-falso)
    - Telim H implements rules H:Tr P |- G   -->  |- P->G when G is a L-prop
    - Tdestruct H is the equivalent of destruct on a hypothesis Tr(Ind x).
      The goal shall be an L-prop
 *)

Ltac prove_isL :=
  intros;
  lazymatch goal with
  | |- isL(Tr _) => apply Tr_isL
  | |- isL(_ /\ _) => apply and_isL; prove_isL
  | |- isL True => apply T_isL; exact I
  | |- isL(impl _ _) => apply imp_isL; prove_isL
  | |- isL(iff _ _) => apply iff_isL; prove_isL
  | |- isL(forall x, _) => (apply imp_isL || (apply fa_isL; intro)); prove_isL
  | |- isL _ => auto 10; fail "Cannot prove isL side-condition"
  | |- _ => fail "Tactic prove_isL does not apply to this goal"
  end.

Ltac Tabsurd :=
  lazymatch goal with
  | |- Tr _ => apply rFF
  | |- _ => apply rFF';[|auto 10;fail"Cannot prove isL side-condition"]
  end.
Ltac Telim H :=
  lazymatch goal with
  | |- Tr _ => apply TrB with (1:=H); try clear H
  | |- _ => apply Tr_ind with (3:=H);[auto 10;fail"Cannot prove isL side-condition"|]; try clear H
  end.
Tactic Notation "Tdestruct" constr(H) :=
  Telim H; destruct 1.
Tactic Notation "Tdestruct" constr(H) "as" simple_intropattern(p) :=
  Telim H; intros p.

End BuildLogic.

(** The same for consistent logics: False is now an L-prop *)

Module BuildConsistentSublogic (L:ConsistentSublogic).
  Module tmp <: SublogicTheory := BuildLogic L.
  Include tmp.

Lemma FF_isL : isL False.
Proof L.TrCons.

Global Hint Resolve FF_isL.

End BuildConsistentSublogic.

(***************************************************************************)
(** * 2.Examples of sublogic modules *)

(** ** Coq's intuitionistic logic *)
Module CoqSublogic <: ConsistentSublogic.
Definition Tr P:Prop := P.
Definition TrI (P:Prop) (p:P) : Tr P := p.
Definition TrP (P:Prop) (p:Tr (Tr P)) : Tr P := p.
Definition TrMono (P Q:Prop) (f:P->Q) (p:Tr P) : Tr Q := f p.
Definition TrCons : ~ Tr False := fun h => h.
End CoqSublogic.

Module CoqSublogicThms := BuildConsistentSublogic CoqSublogic.

(** ** Classical logic through negated translation *)
Module ClassicSublogic <: ConsistentSublogic.
Definition Tr (P:Prop) := ~~P.
Definition TrI (P:Prop) (p:P) : Tr P := fun np => np p.
Definition TrP (P:Prop) (nnnnp:Tr (Tr P)) : Tr P :=
 fun np => nnnnp (fun nnp => nnp np).
Definition TrMono (P Q:Prop) (f:P->Q) (nnp:Tr P) : Tr Q :=
 fun nq => nnp (fun p => nq (f p)).
Definition TrCons : ~ Tr False := fun h => h (fun x => x).
End ClassicSublogic.

Module ClassicSublogicThms.
  Include BuildConsistentSublogic ClassicSublogic.

  Lemma nnpp (P:Prop) : ((P->False)->False) -> Tr P.
Proof (fun h => h).

  (** excluded-middle: note that P need not be classical, which makes the
     positive case stronger. *)
  Lemma classic : forall P, Tr(P \/ (Tr P -> False)).
intros P nem.
apply nem; right; intro tp.
apply Tr_ind with (3:=tp); intros; trivial.
apply nem; left; assumption.
Qed.
End ClassicSublogicThms.

(** ** Friedman's A-translation *)

Module ASublogic <: SublogicFamily.
  Definition T:=Prop.
  Definition Tr A P := P \/ A.
  Definition TrI (A P:Prop) (p:P) : Tr A P := or_introl p.
  Definition TrP (A P:Prop) (p:(P\/A)\/A) :=
    match p with
    | or_introl p => p
    | or_intror a => or_intror a
    end.
  Definition TrMono (A P Q:Prop) (f:P->Q) (p:P\/A) :=
    match p with
    | or_introl p => or_introl (f p)
    | or_intror a => or_intror a
    end.
End ASublogic.

Module Type Aprop. Parameter x:Prop. End Aprop.

Module ASublogicThms (A:Aprop) <: SublogicTheory.
  Module Asl := InstSublogicFamily ASublogic A.
  Import Asl.
  Notation A := A.x.
  Include BuildLogic Asl.

Lemma Aconsistency : isL False <-> ~A.
firstorder.
Qed.

Lemma atom_isL (P:Prop) : (A->P) -> isL P.
firstorder.
Qed.

(** or does not need to be modified *)
Lemma or_isL P Q : isL P \/ isL Q -> isL (P\/Q).
firstorder.
Qed.
Global Hint Resolve or_isL.

(** existential does need to be modified when one of the
   instances is an L-prop. *)
Lemma ex_isL_raw T (P:T->Prop):
  (exists x, isL (P x)) -> isL(ex P).
firstorder.
Qed.

(** A more usable rule (we can expect the forall x, isL (P x)
   assumption to be provable automatically), but which requires T to
   be inhabited. *)
Lemma ex_isL T (P:T->Prop) :
  T -> (forall x, isL (P x)) -> isL (ex P).
compute; intros.
destruct H0; trivial.
exists X; auto.
Qed.
Global Hint Resolve ex_isL.

Lemma FF_a : Tr False <-> A.
split.
 destruct 1;[contradiction|trivial].
 right; trivial.
Qed.

End ASublogicThms.

(** Example: if ~~exists x. P(x) is derivable, then so is exists x. P(x) *)
Module AtransExample.
Parameter (T:Type) (P : T->Prop).
Module nnex. Definition x:=exists x, P x. End nnex.
Module Atr := ASublogicThms nnex.
Import nnex Atr.

Lemma markov_rule :
  ((Tr(exists x, P x) -> Tr False) -> Tr False) ->
  exists x, P x.
intro.
apply FF_a.
apply H; intro.
apply Tr_ind with (3:=H0); intros; trivial.
 apply Atr.Tr_isL.
apply FF_a.
assumption.
Qed.
End AtransExample.

(** ** Peirce translation *)

Module PeirceTrans <: SublogicFamily.
  Definition T := Prop.
  Definition Tr (R A:Prop) := (A->R)->A.
  Definition TrI (R A:Prop) (a:A) : Tr R A := fun ar => a.
  Definition TrP (R A:Prop) (tta:Tr R (Tr R A)) : Tr R A :=
   fun ar => tta (fun ara => ar (ara ar)) ar.
  Definition TrMono (R A B:Prop) (f:A->B) (ta:Tr R A) : Tr R B :=
   fun br => f (ta (fun a => br (f a))).
  Definition TrCons (R:Prop) : ~ Tr R False :=
   fun frf => frf (False_ind R).
End PeirceTrans.

Module PeirceSublogicThms (A:Aprop) <: SublogicTheory.
  Module Psl := InstSublogicFamily PeirceTrans A.
  Import Psl.
  Notation A := A.x.
  Include BuildLogic Psl.

Lemma Pconsistency : isL False.
firstorder.
Qed.

End PeirceSublogicThms.

(** ** Intersection and cartesian product *)

Module Inter (L:SublogicFamily) <: Sublogic.
  Definition Tr P := forall x, L.Tr x P.
  Definition TrI (P:Prop) (p:P) : Tr P := fun x => L.TrI x p.
  Definition TrP (P:Prop) (ttp:Tr(Tr P)) : Tr P :=
    fun x => L.TrP (L.TrMono (fun p => p x) (ttp x)).
  Definition TrMono (P Q:Prop) (f:P->Q) (p:Tr P) : Tr Q :=
    fun x => L.TrMono f (p x).
  (* If a member of the family is consistent, then so is the intersection. *)
  Lemma equiCons : Tr False <-> forall x, L.Tr x False.
    reflexivity.
  Qed.
End Inter.

Module Inter2 (L1 L2:Sublogic) <: Sublogic.
  Definition Tr P := L1.Tr P /\ L2.Tr P.
  Definition TrI (P:Prop) (p:P) : Tr P := conj (L1.TrI p) (L2.TrI p).
  Definition TrP (P:Prop) (ttp:Tr(Tr P)) : Tr P :=
    conj (L1.TrP (L1.TrMono (fun p => proj1 p) (proj1 ttp)))
         (L2.TrP (L2.TrMono (fun p => proj2 p) (proj2 ttp))).
  Definition TrMono (P Q:Prop) (f:P->Q) (p:Tr P) : Tr Q :=
    conj (L1.TrMono f (proj1 p)) (L2.TrMono f (proj2 p)).
  (* If L1 or L2 is consistent, then so is L1/\L2. *)
  Lemma equiCons : Tr False <-> L1.Tr False /\ L2.Tr False.
    reflexivity.
  Qed.
  Lemma isL_intro P : (L1.Tr P -> P) \/ (L2.Tr P -> P) -> (Tr P -> P).
destruct 1; destruct 1; auto.
Qed.

End Inter2.

(***************************************************************************)
(** * 3. Building a higher-order logic with L-props. *)

Module SublogicToHOLogic (L:SublogicTheory) <: HOLogic.
Import L.

Record prop_ := mkP { holds : Prop; isprop : isL holds }.
Definition prop := prop_.

Definition TT : prop.
(*begin show*)
exists True; auto.
(*end show*)
Defined.
Definition FF : prop.
(*begin show*)
exists (Tr False); trivial.
(*end show*)
Defined.
Definition Imp (P Q:prop) : prop.
(*begin show*)
exists (holds P->holds Q).
(*end show*)
apply imp_isL; apply isprop.
Defined.
Definition Not p := Imp p FF.
Definition And (P Q:prop) : prop.
(*begin show*)
exists (holds P /\ holds Q).
(*end show*)
apply and_isL; apply isprop.
Defined.
Definition Or (P Q:prop) : prop.
(*begin show*)
exists (Tr(holds P \/ holds Q)).
(*end show*)
trivial.
Defined.
Definition Forall {A} (P:A->prop) : prop.
(*begin show*)
exists (forall x, holds (P x)).
(*end show*)
apply fa_isL; intros x; apply isprop.
Defined.
Definition Exist {A} (P:A->prop) : prop.
(*begin show*)
exists (Tr(exists x, holds (P x))).
(*end show*)
trivial.
Defined.
Definition Ex2 {A} (P Q:A->prop) : prop.
(*begin show*)
exists (Tr(exists2 x, holds (P x) & holds (Q x))).
(*end show*)
trivial.
Defined.

(** Inference rules *)

Lemma rTT : holds TT.
exact I.
Qed.
Lemma rFF P : holds FF -> holds P.
simpl.
apply Tr_ind; [apply isprop|contradiction].
Qed.
Lemma rAnd P Q : holds (And P Q) <-> holds P /\ holds Q.
reflexivity.
Qed.
Lemma rImp P Q : holds (Imp P Q) <-> (holds P -> holds Q).
reflexivity.
Qed.
Lemma rForall A P : holds (Forall P) <-> forall x:A, holds (P x).
reflexivity.
Qed.
Lemma rNot P : holds (Not P) <-> (holds P -> holds FF).
reflexivity.
Qed.
Lemma rOrI P Q : holds P \/ holds Q -> holds (Or P Q).
simpl.
apply TrI.
Qed.
Lemma rOrE P Q C : (holds P \/ holds Q -> holds C) -> holds (Or P Q) -> holds C.
intro; apply Tr_ind; [apply isprop|trivial].
Qed.
Lemma rExI A P : (exists (x:A), holds (P x)) -> holds (Exist P).
destruct 1; simpl; apply TrI; eauto.
Qed.
Lemma rExE A P C : (forall x:A, holds (P x) -> holds C) -> holds (Exist P) -> holds C.
intro; apply Tr_ind; [apply isprop|].
destruct 1; eauto.
Qed.
Lemma rEx2I A (P Q:A->prop) : (exists2 x, holds (P x) & holds (Q x)) -> holds (Ex2 P Q).
destruct 1; simpl; apply TrI; eauto.
Qed.
Lemma rEx2E A P Q C : (forall x:A, holds (P x) -> holds (Q x) -> holds C) -> holds (Ex2 P Q) -> holds C.
intro; apply Tr_ind; [apply isprop|].
destruct 1; eauto.
Qed.

Lemma equiCons : Tr False <-> holds FF.
reflexivity.
Qed.

End SublogicToHOLogic.

(* begin hide *)

Module TypeClasses.
(***************************************************************************)
(** * 4. The same ideas but using records and typeclasses *)

Class sub_logic0 := mkSubLogic0 {
  Tr : Prop -> Prop;
  TrI : forall P:Prop, P -> Tr P;
  TrB : forall P Q:Prop, Tr P -> (P -> Tr Q) -> Tr Q;
  Teq1 (P Q:Prop) (m:Tr P) (f:P->Tr Q) (x:P): TrB (TrI x) f = f x;
  Teq2 (P:Prop) (m:Tr P) : TrB m (@TrI _) = m
}.
Parameter M0 : sub_logic0.
Existing Instance M0.

Definition mono (P Q:Prop) (f:P->Q) (m:Tr P) : Tr Q :=
 TrB _ m (fun x => TrI (f x)).
Definition proj (P:Prop) (m:Tr(Tr P)) : Tr P :=
 TrB _ m (fun x => x).

Class sub_logic := mkSubLogic {
  P2p : Prop -> Prop;
  P2p_mono : Proper (impl ==> impl) P2p;
  P2p_proj : forall P, P2p (P2p P) -> P2p P;
  P2pI : forall P:Prop, P -> P2p P
(*  eq1 (P:Prop) (m:P2p P) : P2p_proj (P2pI m) = m;
  eq2 (P Q:Prop) (f:P->Q) (x:P) : P2p_mono f (P2pI x) = P2pI (f x)*)
}.

Parameter M : sub_logic.
Existing Instance M.

Definition ret (P:Prop) (x:P) : P2p P := P2pI x.
Definition bind (P Q:Prop) (a : P2p P) (b: P -> P2p Q) : P2p Q :=
  P2p_proj _ (P2p_mono b a).

Definition p1 := forall (P Q:Prop) (x:P) (f:P->P2p Q), bind _ (ret x) f = f x.
Definition p2 := forall (P:Prop) (x:P), let m := ret x in bind _ m (fun y => ret y) = m.
Definition p3 := forall (P Q R:Prop) (x:P) (f:P->P2p Q) (g:Q->P2p R),
  let m := ret x in
  bind R (bind Q m f) g = bind _ m (fun x => bind _ (f x) g).
(*
Lemma L1 : p1.
unfold p1, ret, bind; intros.
rewrite eq2.
rewrite eq1.
reflexivity.
Qed.
Lemma L2 : p2.
unfold p2,ret,bind; intros.
rewrite eq2.
rewrite eq1.
reflexivity.
Qed.
Lemma L3 : p3.
unfold p3,ret,bind; intros.
repeat rewrite eq2.
do 2 rewrite eq1.
reflexivity.
Qed.
*)
Section SubLogicFacts.

Hypothesis L : sub_logic.

Instance P2p_morph : Proper (iff ==> iff) P2p.
apply morph_impl_iff1; auto with *.
intros P Q e.
apply P2p_mono; destruct e; trivial.
Qed.

Class isL P : Prop :=
  isFormula : P2p P -> P.

Instance isL_morph : Proper (iff ==> iff) isL.
unfold isL; do 2 red; intros.
rewrite H; reflexivity.
Qed.

Lemma P2p_isL P : isL (P2p P).
red; apply P2p_proj.
Qed.

Lemma P2pE : forall (P Q:Prop), isL Q -> (P -> Q) -> (P2p P -> Q).
intros.
apply H.
revert H1; apply P2p_mono; trivial.
Qed.

(* Building the logic: *)

Lemma T_isL (P:Prop) : P -> isL P.
red; trivial.
Qed.

Lemma and_isL P Q : isL P -> isL Q -> isL (P/\Q).
unfold isL; intros.
split.
 apply H; revert H1; apply P2p_mono.
 red; destruct 1; trivial.

 apply H0; revert H1; apply P2p_mono.
 red; destruct 1; trivial.
Qed.

Lemma forall_isL : forall A (P:A->Prop), (forall x:A, isL (P x)) -> isL (forall x:A, P x).
unfold isL; intros.
apply H.
revert H0; apply P2p_mono; red; auto.
Qed.

Lemma impl_isL : forall P Q,
  isL Q -> isL (P -> Q).
red; intros.
apply H.
revert H0; apply P2p_mono; red; auto.
Qed.

(* Nothing about or, ex, False *)

Definition FF := P2p False.

Definition consistent := ~ FF.

Hypothesis cons : consistent.

Lemma False_isL : isL False.
Proof cons.

Lemma not_isL (P:Prop) : isL (~P).
apply impl_isL; trivial.
Qed.

Definition Or P Q := P2p(P\/Q).

Instance Or_morph : Proper (iff==>iff==>iff) Or.
do 3 red; intros.
apply P2p_morph; apply or_iff_morphism; trivial.
Qed.

Lemma orI P Q : P \/ Q -> Or P Q.
red; intros; apply P2pI; trivial.
Qed.

Lemma orE (P Q C:Prop) :
  (P -> C) -> (Q -> C) -> Or P Q -> isL C -> C.
intros.
apply P2pE with (P \/ Q); trivial.
destruct 1; auto.
Qed.

Definition Ex {A} (P:A->Prop) := P2p(ex P).

Lemma exI A (P:A->Prop) x : P x -> Ex P.
red; intros; apply P2pI.
exists x; trivial.
Qed.

Lemma exE A (P:A->Prop) (C:Prop) : (forall x, P x -> C) -> Ex P -> isL C -> C.
intros.
apply P2pE with (3:=H0); trivial.
destruct 1; eauto.
Qed.

Instance Ex_morph : forall A,
   Proper ((pointwise_relation A iff) ==> iff) (@Ex A).
do 3 red; intros.
apply P2p_morph; apply ex_morph; trivial.
Qed.

Definition Ex2 {A} (P Q:A->Prop) := P2p(ex2 P Q).

Lemma ex2I A (P Q:A->Prop) x : P x -> Q x -> Ex2 P Q.
red; intros; apply P2pI.
exists x; trivial.
Qed.

Lemma ex2E A (P Q:A->Prop) (C:Prop) : (forall x, P x -> Q x -> C) -> Ex2 P Q -> isL C -> C.
intros.
apply P2pE with (3:=H0); trivial.
destruct 1; eauto.
Qed.

Instance Ex2_morph : forall A,
   Proper (pointwise_relation A iff ==> pointwise_relation A iff ==> iff) (@Ex2 A).
do 3 red; intros.
apply P2p_morph; apply ex2_morph; trivial.
Qed.

(* Packaging the logic *)

Record prop := mkP { tr : Prop; isprop : isL tr }.

Definition TT : prop.
exists True.
apply T_isL; trivial.
Defined.
Definition FF' : prop.
exists FF.
unfold isL,FF; apply P2p_proj.
Defined.
Definition Imp (P Q:prop) : prop.
exists (tr P->tr Q).
apply impl_isL; apply isprop.
Defined.
Definition And (P Q:prop) : prop.
exists (tr P /\ tr Q).
apply and_isL; apply isprop.
Defined.
Definition Or' (P Q:prop) : prop.
exists (Or (tr P) (tr Q)).
unfold isL,Or; apply P2p_proj.
Defined.
Definition Forall {A} (P:A->prop) : prop.
exists (forall x, tr (P x)).
apply forall_isL; intros x; apply isprop.
Defined.
Definition Ex' {A} (P:A->prop) : prop.
exists (Ex (fun x => tr (P x))).
unfold isL,Ex; apply P2p_proj.
Defined.
Definition Not p := Imp p FF'.

(** Inference rules *)
Notation holds := tr.
Lemma rTT : holds TT.
exact I.
Qed.
Lemma rFF P : holds FF' -> holds P.
simpl.
apply P2pE.
 apply isprop.
 intros; contradiction.
Qed.
Lemma rAnd P Q : holds (And P Q) <-> holds P /\ holds Q.
reflexivity.
Qed.
Lemma rImp P Q : holds (Imp P Q) <-> (holds P -> holds Q).
reflexivity.
Qed.
Lemma rForall A P : holds (Forall P) <-> forall x:A, holds (P x).
reflexivity.
Qed.
Lemma rNot P : holds (Not P) <-> (holds P -> holds FF').
reflexivity.
Qed.
Lemma rOrI P Q : holds P \/ holds Q -> holds (Or' P Q).
simpl.
apply orI.
Qed.
Lemma rOrE P Q C : (holds P \/ holds Q -> holds C) -> holds (Or' P Q) -> holds C.
intros; apply orE with (3:=H0); auto.
apply isprop.
Qed.
Lemma rExI A P : (exists (x:A), holds (P x)) -> holds (Ex' P).
destruct 1.
apply exI with x; trivial.
Qed.
Lemma rExE A P C : (forall x:A, holds (P x) -> holds C) -> holds (Ex' P) -> holds C.
intros.
apply exE with (2:=H0); auto.
apply isprop; trivial.
Qed.

End SubLogicFacts.

(** Coq logic *)
Section Coq.

Definition coq := fun (P:Prop) => P.
Instance coq_logic : sub_logic := { P2p := coq }.
firstorder.
firstorder.
firstorder.
Defined.
Lemma coq_isL (P:Prop) : isL coq_logic P.
Proof (fun h=>h).

Lemma coq_cons : consistent coq_logic.
Proof (fun h => h).
End Coq.

(** Classical logic *)

Section Classic.
Definition nnt (P:Prop) := ~~P.

Instance classic_logic : sub_logic := { P2p := nnt }.
exact (fun P Q (f:P->Q) (nnp:~~P) (nq:~Q) => nnp(fun p => nq(f p))).
exact (fun P nnnnp np => nnnnp(fun nnp => nnp np)).
exact (fun P p => fun np => np p).
Defined.

Lemma em P : Or classic_logic P (~P).
firstorder.
Qed.

Lemma cl_cons : consistent classic_logic.
Proof (fun h => h(fun x => x)).

Lemma cl_isL P : (~~P->P) -> isL classic_logic P.
Proof (fun h => h).

End Classic.

(** Friedman's A-translation *)
Section Atrans.

Definition Atr A P := P \/ A.

Instance Atrans A : sub_logic := { P2p := Atr A }.
exact (fun P Q (f:P->Q) (p:P\/A) =>
  match p with
  | or_introl p => or_introl (f p)
  | or_intror a => or_intror a
  end).
exact (fun P (p:(P\/A)\/A) =>
  match p with
  | or_introl p => p
  | or_intror a => or_intror a
  end).
exact (fun P (p:P) => or_introl p).
Defined.

Lemma atr_atom (A P:Prop) : (A->P) -> isL (Atrans A) P.
firstorder.
Qed.

(* or does not need to be modified *)
Lemma atr_or_isL A P Q : isL (Atrans A) P \/ isL (Atrans A) Q -> isL (Atrans A) (P\/Q).
firstorder.
Qed.

Lemma atr_a A : FF(Atrans A) <-> A.
split.
 destruct 1;[contradiction|trivial].
 right; trivial.
Qed.

Lemma atr_nnex T (P:T->Prop) :
 (forall A, ((Ex(Atrans A) P) -> FF(Atrans A))->FF(Atrans A)) ->
 exists x:T, P x.
intros.
set (A:=exists x, P x).
apply atr_a.
apply H; intro.
apply (fun P Q => @P2pE (Atrans A) P (P2p Q)) with (3:=H0).
 apply P2p_isL.
apply atr_a.
Qed.

End Atrans.

(** Peirce's translation *)

Section PeirceTrans.

Definition Ptr (R A:Prop) := (A->R)->A.

Instance Ptrans R : sub_logic := { P2p := Ptr R }.
firstorder.
firstorder.
firstorder.
Defined.

Lemma Pcons R : consistent (Ptrans R).
do 2 red.
unfold FF, Ptrans.
unfold P2p.
unfold Ptr.
intros.
apply H; intros.
contradiction.
Qed.

End PeirceTrans.

End TypeClasses.
(* end hide *)