(* Definition and properties of circular shift.
   Definition of a relation CiculiarShift_R, similar to Perm_R.v but using circular shifts instead of permutation. *)

From Coq Require Import CMorphisms Bool PeanoNat Lia.
From OLlibs Require Import List_more.
Require Import List_nat Fun_nat Perm Perm_R_more length_lia.

(** Definition *)

Definition cond_circularShift l := {' (n, m) & l = cfun (S n) (S m) } + { l = Id (length l) }.

Lemma Id_cond_circular : forall n, cond_circularShift (Id n).
Proof. intros; right; now rewrite seq_length. Qed.

Lemma cfun_S_cond_circular : forall n m, cond_circularShift (cfun (S n) (S m)).
Proof. intros; left; now split with (n, m). Qed.

Lemma cfun_cond_circular : forall n m, cond_circularShift (cfun n m).
Proof.
intros n m; destruct n ; [ | destruct m ].
- unfold cfun; simpl; rewrite app_nil_r.
  apply Id_cond_circular.
- unfold cfun; simpl; rewrite cons_seq.
  apply Id_cond_circular.
- apply cfun_S_cond_circular.
Qed.

Lemma cond_circular_cfun_lt {l} : cond_circularShift l -> {' (n, m) & l = cfun n m & m = 0 -> n = 0}.
Proof.
intros [[[n m] Heqcp] | Heqcp]; subst.
- now exists (S n, S m).
- now exists (0, length l); unfold cfun; [ rewrite app_nil_r | ].
Qed.

Lemma cond_circular_cfun {l} : cond_circularShift l -> {' (n, m) : _ & l = cfun n m }.
Proof. intros Hc; destruct (cond_circular_cfun_lt Hc) as [(n,m) Heq Hlt]; now exists (n,m). Qed.

Lemma cond_circular_is_perm {l} : cond_circularShift l -> is_perm l = true.
Proof. intros Hc; destruct (cond_circular_cfun Hc) as [(n, m) Heq]; subst; apply cfun_is_perm. Qed.

Definition CircularShift_R {A} (l1 l2 : list A) :=
  { f : _ & cond_circularShift f & prod (length f = length l1) (l2 = f ∘ l1) }.

Infix "~°~" := CircularShift_R (at level 70).

Section Properties.

Context {A : Type}.
Implicit Types la lb lc : list A.

#[local]
Instance CircularShift_Perm_R : Proper (CircularShift_R ==> (@Perm_R A)) (fun a => a).
Proof. intros l1 l2 [f Hc [Hlen Heq]]; subst; now exists f; [ apply cond_circular_is_perm | ]. Defined.

#[local]
Instance CircularShift_R_refl : Reflexive (@CircularShift_R A).
Proof.
  intros l.
  split with (Id (length l)); repeat split.
  - apply Id_cond_circular.
  - length_lia.
  - symmetry; apply app_Id.
Defined.

#[local]
Instance CircularShift_R_sym : Symmetric (@CircularShift_R A).
Proof.
intros l l' [f Hc [Hlen Heq]]; subst.
destruct (cond_circular_cfun Hc) as [(n,m) Heq]; subst.
exists (cfun m n); [ | split ].
- apply cfun_cond_circular.
- rewrite app_nat_fun_length by assumption.
  length_lia.
- rewrite <- asso_app_nat_fun, cfun_inv.
  rewrite cfun_length in Hlen; rewrite Hlen.
  symmetry; apply app_Id.
Defined.

#[local]
Instance CircularShift_R_trans : Transitive (@CircularShift_R A).
Proof.
intros l1 l2 l3 [c1 HC1 [Hlen1 Heq1]] [c2 HC2 [Hlen2 Heq2]]; subst.
destruct (cond_circular_cfun HC1) as [(i,j) Heq]; subst.
destruct (cond_circular_cfun HC2) as [(k,l) Heq]; subst.
rewrite app_nat_fun_length in Hlen2 by assumption.
rewrite_all cfun_length.
destruct (cfun_cfun i j k l) as [(n,m) Heq]; [ lia | ].
rewrite <- asso_app_nat_fun, Heq.
exists (cfun n m); [ | split ].
- apply cfun_cond_circular.
- rewrite <- Heq.
  rewrite app_nat_fun_length; rewrite ? cfun_length; lia.
- reflexivity.
Defined.

#[global]
Instance CircularShift_R_equiv : Equivalence (@CircularShift_R A).
Proof. split; [ apply CircularShift_R_refl | apply CircularShift_R_sym | apply CircularShift_R_trans ]. Qed.

Lemma decomp_CircularShift_R : forall la lb,
  la ~°~ lb -> {' (la', lb') : _ & la' ++ lb' = la & lb' ++ la' = lb }.
Proof.
intros l1 l2 [f Hc [Hlen Heq]]; subst.
destruct (cond_circular_cfun Hc) as [(n,m) Heq]; subst.
exists (Id n ∘ l1, seq n m ∘ l1).
- rewrite <- app_nat_fun_app, <- seq_app.
  rewrite cfun_length in Hlen; rewrite Hlen.
  apply app_Id.
- symmetry; apply app_nat_fun_app.
Qed.

Lemma CircularShift_R_commu : forall la lb, la ++ lb ~°~ lb ++ la.
Proof.
intros l1 l2.
split with (cfun (length l1) (length l2)); [ | split ].
- apply cfun_cond_circular.
- length_lia.
- symmetry; apply app_cfun_eq.
Defined.

Lemma CircularShift_R_app : forall la lb lc, la ++ lb ~°~ lc -> lb ++ la ~°~ lc.
Proof. intros l1 l2 l3 HC; now transitivity (l1 ++ l2); [ apply CircularShift_R_commu | ]. Defined.

Lemma CircularShift_R_app_rot : forall la lb lc, la ++ lb ++ lc ~°~ lb ++ lc ++ la.
Proof. intros l1 l2 l3; rewrite (app_assoc l2); apply CircularShift_R_commu. Defined.

Lemma CircularShift_R_last : forall a la, a :: la ~°~ la ++ a :: nil.
Proof. intros a la; change (a :: la) with ((a :: nil) ++ la); apply CircularShift_R_commu. Defined.

Lemma CircularShift_R_swap : forall a b : A, a :: b :: nil ~°~ b :: a :: nil.
Proof. intros a b; change (b :: a :: nil) with ((b :: nil) ++ (a :: nil)); apply CircularShift_R_last. Defined.

Lemma CircularShift_R_cons : forall la a lb, la ++ a :: nil ~°~ lb -> a :: la ~°~ lb.
Proof. intros l1 a l2 HC; now apply (CircularShift_R_app l1 (a :: nil)). Defined.

Lemma CircularShift_R_morph_cons : forall P : list A -> Prop,
  (forall a l, P (l ++ a :: nil) -> P (a :: l)) ->  Proper (CircularShift_R ==> Basics.impl) P.
Proof.
enough (forall P : list A -> Prop,
         (forall a l, P (l ++ a :: nil) -> P (a :: l)) -> forall l1 l2, CircularShift_R l1 l2 -> P l1 -> P l2)
  as Himp by now intros P HP l1 l2 HC H; apply Himp with l1.
intros P HP l1 l2 HC.
apply decomp_CircularShift_R in HC as [[l0 l3] Heql1 Heql2]; subst.
revert l0 ; induction l3 using rev_ind ; intros l0 HPl.
- now rewrite app_nil_r in HPl.
- rewrite app_assoc in HPl.
  apply HP in HPl.
  rewrite <- app_assoc, <- app_comm_cons.
  now apply IHl3.
Qed.

Lemma CircularShift_R_nil : forall la, nil ~°~ la -> la = nil.
Proof. intros; now apply Perm_R_nil, CircularShift_Perm_R. Qed.

Lemma CircularShift_R_nil_cons : forall la a, nil ~°~ a :: la -> False.
Proof. intros l a HC; apply CircularShift_R_nil in HC; inversion HC. Qed.

Lemma CircularShift_R_one : forall a b : A, a :: nil ~°~ b :: nil -> a = b.
Proof. intros; now apply Perm_R_length_1, CircularShift_Perm_R. Qed.

Lemma CircularShift_R_two : forall a1 a2 b1 b2 : A,
  a1 :: a2 :: nil ~°~ b1 :: b2 :: nil -> { a1 = b1 /\ a2 = b2 } +  { a1 = b2 /\ a2 = b1 }.
Proof. intros; now apply Perm_R_length_2, CircularShift_Perm_R. Qed.

Lemma CircularShift_R_one_inv : forall la a, a :: nil ~°~ la -> la = a :: nil.
Proof. intros; now apply Perm_R_length_1_inv, CircularShift_Perm_R. Qed.

Lemma CircularShift_R_two_inv : forall a b la,
  a :: b :: nil ~°~ la -> { la = a :: b :: nil } + { la = b :: a :: nil }.
Proof. intros; now apply Perm_R_length_2_inv, CircularShift_Perm_R. Qed.

Lemma CircularShift_R_vs_elt_inv : forall a la lb lc,
  la ~°~ lb ++ a :: lc -> {'(l1', l2') | lc ++ lb = l2' ++ l1' & la = l1' ++ a :: l2' }.
Proof.
  intros a l l1 l2 HC.
  apply decomp_CircularShift_R in HC as [[l0 l3] H1 H2]; subst.
  symmetry in H2.
  dichot_elt_app_inf_exec H2 ; subst.
  - exists (l0 ++ l1, l) ; simpl ; now rewrite <- app_assoc.
  - exists (l4, l2 ++ l3) ; simpl ; now rewrite <- app_assoc.
Qed.

Lemma CircularShift_R_vs_cons_inv : forall a la lb,
  la ~°~ a :: lb -> {'(l1', l2') | lb = l2' ++ l1' & la = l1' ++ a :: l2' }.
Proof.
  intros a l l1 HC.
  rewrite <- (app_nil_l (a::_)) in HC.
  apply CircularShift_R_vs_elt_inv in HC; destruct HC as [(l' & l'') H1 H2].
  rewrite app_nil_r in H1 ; subst.
  now exists (l', l'').
Qed.

Lemma CircularShift_R_app_app_inv : forall la lb lc ld,
  la ++ lb ~°~ lc ++ ld ->
     {'(l1',l2',l3',l4') : _ & prod (la ~°~ l1' ++ l3') (lb ~°~ l2' ++ l4')
                             & prod (lc ~°~ l1' ++ l2') (ld ~°~ l3' ++ l4') }
   + {'(l1',l2') : _ & prod (la ~°~ ld ++ l1') (lc ~°~ lb ++ l2')
                     & l1' ~°~ l2' }
   + {'(l1',l2') : _ & prod (lb ~°~ ld ++ l1') (lc ~°~ la ++ l2')
                     & l1' ~°~ l2' }
   + {'(l1',l2') : _ & prod (la ~°~ lc ++ l1') (ld ~°~ lb ++ l2')
                     & l1' ~°~ l2' }
   + {'(l1',l2') : _ & prod (lb ~°~ lc ++ l1') (ld ~°~ la ++ l2')
                     & l1' ~°~ l2' }.
Proof.
intros l1 l2 l3 l4 HC.
apply decomp_CircularShift_R in HC as [[lx ly] Hx Hy].
dichot_app_inf_exec Hx ; dichot_app_inf_exec Hy ; subst.
- left ; left ; left ; right.
  exists (l ++ l0 , l0 ++ l).
  + split; rewrite <- ? app_assoc; apply CircularShift_R_app_rot.
  + apply CircularShift_R_commu.
- dichot_app_inf_exec Hy0 ; subst.
  + left ; left ; left ; left.
    exists (l, l0, lx, l5); split; try apply CircularShift_R_commu; reflexivity.
  + left ; right.
    exists (l1 ++ lx , lx ++ l1).
    * split; rewrite <- ? app_assoc; apply CircularShift_R_app_rot.
    * apply CircularShift_R_commu.
- dichot_app_inf_exec Hy1 ; subst.
  + left ; left ; right.
    exists (ly ++ l2, l2 ++ ly).
    * split; rewrite <- ? app_assoc; apply CircularShift_R_app_rot.
    * apply CircularShift_R_commu.
  + left ; left ; left ; left.
    exists (l, ly, l3, l0); split; try apply CircularShift_R_commu; reflexivity.
- right.
  exists (l5 ++ l0, l0 ++ l5).
  + split; rewrite <- ? app_assoc; apply CircularShift_R_app_rot.
  + apply CircularShift_R_commu.
Defined.

(** [rev], [in], [map], [Forall], [Exists], etc. *)
#[local]
Instance CircularShift_R_rev : Proper (CircularShift_R ==> CircularShift_R) (@rev A).
Proof.
intro l ; induction l ; intros l' HC.
- apply CircularShift_R_nil in HC ; subst ; apply CircularShift_R_refl.
- apply CircularShift_R_sym in HC.
  apply CircularShift_R_vs_cons_inv in HC.
  destruct HC as [(l1 & l2) Heq1 Heq2] ; subst.
  simpl ; rewrite ? rev_app_distr ; simpl.
  rewrite <- app_assoc.
  apply CircularShift_R_commu.
Defined.

#[local]
Instance CircularShift_R_in (a : A) : Proper (CircularShift_R ==> Basics.impl) (In a).
Proof. intros l l' HC Hin; now apply Perm_R_in with l; [ apply CircularShift_Perm_R | ]. Qed.

End Properties.

#[global]
Instance CircularShift_R_map {A B} (f : A -> B) : Proper (CircularShift_R ==> CircularShift_R) (map f).
Proof.
intros l l' HC.
apply decomp_CircularShift_R in HC as [[lx ly] Hx Hy]; subst ; rewrite ? map_app.
apply CircularShift_R_commu.
Defined.

Lemma CircularShift_R_map_inv {A B} : forall(f : A -> B) l1 l2,
  l1 ~°~ map f l2 -> { l : _ & l1 = map f l & l2 ~°~ l }.
Proof with try assumption.
induction l1 ; intros l2 HP.
- exists nil ; try reflexivity.
  simpl ; destruct l2...
  + apply CircularShift_R_refl.
  + apply CircularShift_R_nil in HP.
    inversion HP.
- apply CircularShift_R_sym in HP.
  assert (Heq := HP).
  apply CircularShift_R_vs_cons_inv in Heq.
  destruct Heq as [(l3 & l4) Heq1 Heq2].
  simpl in Heq1 ; simpl in Heq2.
  decomp_map_inf Heq2 ; subst ; simpl.
  exists (x :: l6 ++ l0).
  + simpl ; rewrite ? map_app ; reflexivity.
  + apply (CircularShift_R_commu l0).
Defined.

Lemma CircularShift_R_image {A B} : forall (f : A -> B) a l l',
  a :: l ~°~ map f l' -> { a' | a = f a' }.
Proof. now intros f a l l' HP; apply Perm_R_image with l l', CircularShift_Perm_R. Qed.

#[global]
Instance CircularShift_R_Forall {A} (P : A -> Prop) :
  Proper (CircularShift_R ==> Basics.impl) (Forall P).
Proof. intros l1 l2 HC HF; now apply Perm_R_Forall with l1 ; [ apply CircularShift_Perm_R | ]. Qed.

#[global]
Instance CircularShift_R_Exists {A} (P : A -> Prop) :
  Proper (CircularShift_R ==> Basics.impl) (Exists P).
Proof. intros l1 l2 HC HE; now apply Perm_R_Exists with l1; [ apply CircularShift_Perm_R | ]. Qed.

#[global]
Instance CircularShift_R_Forall_Type {A} (P : A -> Type) :
  Proper (CircularShift_R ==> Basics.arrow) (Forall_inf P).
Proof. intros l1 l2 HC HF; now apply Perm_R_Forall_Type with l1 ; [ apply CircularShift_Perm_R | ]. Qed.

#[global]
Instance CircularShift_R_Exists_Type {A} (P : A -> Type) :
  Proper (CircularShift_R ==> Basics.arrow) (Exists_inf P).
Proof. intros l1 l2 HC HF; now apply Perm_R_Exists_Type with l1 ; [ apply CircularShift_Perm_R | ]. Qed.

Lemma CircularShift_R_Forall2 {A B} (P : A -> B -> Type) : forall l1 l1' l2,
  l1 ~°~ l1' -> Forall2_inf P l1 l2 -> { l2' : _ & l2 ~°~ l2' & Forall2_inf P l1' l2' }.
Proof.
intros l1 l1' l2 HP; revert l2.
apply decomp_CircularShift_R in HP as [[lx ly] Hx Hy]; subst.
intros l2' HF ; inversion HF ; subst.
- exists nil ; auto.
  + reflexivity.
  + symmetry in H0 ; apply app_eq_nil in H0 as [Heq1 Heq2] ; subst.
    constructor.
- destruct lx ; inversion H0 ; subst.
  + rewrite app_nil_l in H0 ; subst.
    exists (y :: l').
    * reflexivity.
    * rewrite app_nil_l in HF ; simpl ; rewrite app_nil_r ; assumption.
  + apply Forall2_inf_app_inv_l in X0 as [(la, lb) [H1 H2] Heq].
    simpl in Heq ; rewrite Heq.
    exists (lb ++ y :: la).
    * rewrite app_comm_cons ; apply CircularShift_R_commu.
    * apply Forall2_inf_app ; auto.
Defined.

(* Canonicity *)
Lemma CircularShift_R_eq_as_perm {A} (HdecA : forall x y : A, {x = y} + {x <> y}) :
  forall (l1 l2 : list A) (HP1 HP2: CircularShift_R l1 l2),
    projT1 (sigT_of_sigT2 HP1) = projT1 (sigT_of_sigT2 HP2) -> HP1 = HP2.
Proof.
intros l1 l2 [p1 Hp1 [Heql1 Heqp1]] [p2 Hp2 [Heql2 Heqp2]] Heq; simpl in Heq; subst; repeat f_equal.
- destruct Hp1; destruct Hp2; f_equal.
  + destruct s as [[n1 m1] Hs1]; destruct s0 as [[n2 m2] Hs2]; subst.
    destruct (cfun_arg_inj_S _ _ _ _ Hs2) as [Heqn Heqm]; subst.
    f_equal; apply UIP_list_nat.
  + exfalso.
    destruct s as [[n m] Hs]; subst.
    rewrite <- cfun_0_n in e.
    apply cfun_arg_inj in e; lia.
  + exfalso.
    destruct s as [[n m] Hs]; subst.
    rewrite <- cfun_0_n in e.
    apply cfun_arg_inj in e; lia.
  + apply UIP_list_nat.
- apply UIP_nat.
- now apply Eqdep_dec.UIP_dec, list_eq_dec.
Qed.

(* Cyclic Permutations as Nat *)
Definition app_cshift_nat {A} n (l : list A) := skipn n l ++ firstn n l.

Lemma app_cshift_cfun {A} : forall i (l : list A), i <= length l ->
  app_cshift_nat i l = app_nat_fun (cfun i (length l - i)) l.
Proof.
  intros i l Hle.
  rewrite<- (firstn_skipn i l) at 3.
  rewrite<- (firstn_length_le l) at 2 by assumption.
  replace (length l - i) with (length (skipn i l)); [ symmetry; apply app_cfun_eq | ].
  rewrite<- (firstn_skipn i l) at 2.
  rewrite app_length, firstn_length_le by assumption; lia.
Qed.

Lemma app_cshift_iter {A} : forall i (l : list A), i <= length l ->
  app_cshift_nat i l = Nat.iter i (app_nat_fun (cfun 1 (length l - 1))) l.
Proof.
induction i; intros l Hlen; simpl.
- now unfold app_cshift_nat; rewrite app_nil_r.
- destruct l; simpl in Hlen; (try now lia).
  rewrite app_cshift_cfun; [ | simpl; lia ].
  change (length l - 0) with (length (a :: l) - 1); rewrite <- (IHi (a :: l)); [ | simpl; lia ].
  rewrite app_cshift_cfun; [ | simpl; lia ].
  rewrite <- asso_app_nat_fun.
  rewrite cfun_cfun_le; simpl length; try lia.
  f_equal; f_equal; lia.
Qed.

Lemma cond_circularShift_to_app_cshift : forall p, cond_circularShift p ->
  { n & n <? max 1 (length p) = true
          & forall A (l : list A), length p = length l -> app_nat_fun p l = app_cshift_nat n l}.
Proof.
intros p Hperm.
destruct (cond_circular_cfun_lt Hperm) as [(n, m) Heq Hz]; subst; rewrite cfun_length.
exists n; [ apply Nat.ltb_lt; lia | ].
intros A l Hlen.
replace m with (length l - n) by lia.
symmetry; apply app_cshift_cfun; lia.
Qed.

Lemma app_cshift_to_cond_circularShift : forall n len,
  {p & cond_circularShift p
         & prod (length p = len)
                (forall A (l : list A), length p = length l -> app_nat_fun p l = app_cshift_nat n l)}.
Proof.
  intros n len.
  destruct n; [ | case_eq ((S n) <? len); intros H ; [apply Nat.ltb_lt in H | apply Nat.ltb_nlt in H] ].
  - split with (Id len); [ | split].
    + right; now rewrite seq_length.
    + apply seq_length.
    + intros A l Hlen.
      rewrite seq_length in Hlen.
      rewrite Hlen.
      rewrite app_Id.
      unfold app_cshift_nat; simpl.
      symmetry; apply app_nil_r.
  - split with (cfun (S n) (S (pred (pred len) - n))); [ | split ].
    + left; now split with (n , pred (pred len) - n).
    + rewrite cfun_length; lia.
    + intros A l Hlen.
      rewrite cfun_length in Hlen.
      replace (S (Init.Nat.pred (Init.Nat.pred len) - n)) with (len - S n) by lia.
      unfold app_cshift_nat.
      rewrite <- (firstn_skipn (S n) l) at 1.
      rewrite<- (firstn_length_le l) at 1 by lia.
      replace (len - S n) with (length (skipn (S n) l)); [apply app_cfun_eq | ].
      rewrite skipn_length; lia.
  - split with (Id len);  [ | split].
    + right; now rewrite seq_length.
    + apply seq_length.
    + intros A l Hlen.
      rewrite seq_length in Hlen; rewrite Hlen.
      rewrite app_Id.
      unfold app_cshift_nat.
      rewrite skipn_all2 by lia.
      now rewrite firstn_all2 by lia.
Qed.

Definition CircularShift_nat_R {A} (l1 l2 : list A) :=
  { n : _ & n <? max 1 (length l1) = true & l2 = app_cshift_nat n l1 }.

(* Canonicity *)
Lemma CircularShift_nat_R_eq_as_nat {A} (HdecA : forall x y : A, {x = y} + {x <> y}) :
  forall (l1 l2 : list A) (HP1 HP2: CircularShift_nat_R l1 l2),
    projT1 (sigT_of_sigT2 HP1) = projT1 (sigT_of_sigT2 HP2) -> HP1 = HP2.
Proof.
intros l1 l2 [n1 Hp1 Heqp1] [n2 Hp2 Heqp2] Heq; simpl in Heq; subst; repeat f_equal.
- apply (Eqdep_dec.UIP_dec bool_dec).
- now apply Eqdep_dec.UIP_dec, list_eq_dec.
Qed.


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.


Load LFindLoad.
From lfind Require Import LFind.
From adtind Require Import goal21.

Set Printing Depth 1000.
Definition lfind_eval  (y : lst):=
y.

Compute lfind_eval  (Nil).

Compute lfind_eval  (Cons Zero (Cons (Succ Zero) Nil)).

Compute lfind_eval  (Cons (Succ (Succ Zero)) Nil).

Compute lfind_eval  (Cons (Succ Zero) Nil).

Compute lfind_eval  (Cons Zero Nil).

Compute lfind_eval  (Cons Zero (Cons Zero (Cons Zero (Cons (Succ Zero) Nil)))).

Compute lfind_eval  (Cons (Succ (Succ (Succ Zero))) Nil).

Compute lfind_eval  (Cons Zero (Cons (Succ (Succ Zero)) (Cons Zero Nil))).

Compute lfind_eval  (Cons (Succ Zero) (Cons Zero Nil)).

Compute lfind_eval  (Cons (Succ (Succ Zero)) (Cons Zero (Cons (Succ (Succ Zero)) (Cons Zero Nil)))).

Compute lfind_eval  (Cons (Succ (Succ Zero)) (Cons Zero Nil)).


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.