Require Import List.
Import ListNotations.
Require Import NArith.
Require Import PArith.
Require Import String.

Require Import Coqlib.
Require Import StructTact.StructTactics.
Require Export Maps.

Module ITree(X: INDEXED_TYPE) <: TREE.

  Definition elt := X.t.
  Definition elt_eq := X.eq.
  Definition t := PTree.t.
  Definition empty := PTree.empty.
  Definition get {A: Type} (i: X.t) (m: t A) := PTree.get (X.index i) m.
  Definition set {A: Type} (i: X.t) (v: A) (m: t A) := PTree.set (X.index i) v m.
  Definition remove {A: Type} (i: X.t) (m: t A) := PTree.remove (X.index i) m.

  Theorem gempty :
    forall (A: Type) (k: elt), get k (empty A) = None.
  Proof using.
    intros. unfold get. apply PTree.gempty.
  Qed.

  Theorem gss :
    forall (A: Type) (i: elt) (x: A) (m: t A), get i (set i x m) = Some x.
  Proof using.
    intros. unfold get, set. apply PTree.gss.
  Qed.

  Theorem gso:
    forall (A: Type) (i j: elt) (x: A) (m: t A),
    i <> j -> get i (set j x m) = get i m.
  Proof using.
    intros. unfold get, set. apply PTree.gso.
    unfold not in *. intros. find_apply_lem_hyp X.index_inj. contradiction.
  Qed.

  Theorem gsspec:
    forall (A: Type) (i j: elt) (x: A) (m: t A),
    get i (set j x m) = if elt_eq i j then Some x else get i m.
  Proof using.
    intros. unfold get, set.
    rewrite PTree.gsspec.
    repeat break_if; try find_apply_lem_hyp X.index_inj; congruence.
  Qed.

  Theorem grs:
    forall (A: Type) (i: elt) (m: t A), get i (remove i m) = None.
  Proof using.
    intros. unfold get. apply PTree.grs.
  Qed.

  Theorem gro:
    forall (A: Type) (i j: elt) (m: t A),
    i <> j -> get i (remove j m) = get i m.
  Proof using.
    intros. unfold get. apply PTree.gro.
    unfold not in *. intros. find_apply_lem_hyp X.index_inj. contradiction.
  Qed.

  Theorem grspec:
    forall (A: Type) (i j: elt) (m: t A),
    get i (remove j m) = if elt_eq i j then None else get i m.
  Proof using.
    intros. unfold get, remove. rewrite PTree.grspec.
    repeat break_if; try find_apply_lem_hyp X.index_inj; congruence.
  Qed.
End ITree.

Module IndexedString <: INDEXED_TYPE.
  Definition t := string.
  Definition eq := string_dec.

  Fixpoint encode_bools (l : list bool) (p : positive) : positive :=
    match l with
      | nil => p
      | b :: l' => if b then xI (encode_bools l' p) else xO (encode_bools l' p)
    end.
  Fixpoint index (s : string) : positive :=
    match s with
      | EmptyString => 1
      | String a s' => let (a0, a1, a2, a3, a4, a5, a6, a7) := a in
          encode_bools [a0; a1; a2; a3; a4; a5; a6; a7] (index s')
    end.

  Lemma encode_bools_inj :
    forall l l' p p',
      List.length l = List.length l' ->
      encode_bools l p = encode_bools l' p' ->
      l = l' /\ p = p'.
  Proof using.
    induction l; destruct l'; intros; try discriminate; auto.
    simpl in *. do 2 break_match; try discriminate;
      solve [ find_inversion; find_apply_hyp_hyp; break_and; subst; auto ].
  Qed.

  Theorem index_inj :
    forall (x y : t),
      index x = index y ->
      x = y.
  Proof using.
    induction x; destruct y; intros.
    - reflexivity.
    - simpl in *. repeat break_match; congruence.
    - simpl in *. repeat break_match; congruence.
    - unfold index in *. fold index in *. repeat break_let.
      find_apply_lem_hyp encode_bools_inj.
      + subst. break_and. do 8 (inv H). find_apply_hyp_hyp. subst. reflexivity.
      + reflexivity.
  Qed.
End IndexedString.

Module LogTimeStringMap := ITree(IndexedString).

Module EqString <: EQUALITY_TYPE.
  Definition t := string.
  Definition eq := string_dec.
End EqString.

Module LinearTimeStringMap := ETree(EqString).


Set Warnings "-extraction-opaque-accessed,-extraction".
Set Warnings "-notation-overridden,-parsing".

Require Import mathcomp.ssreflect.ssreflect.
From mathcomp Require Import ssrfun ssrbool ssrnat eqtype.
Require Import ZArith.

Require Import LazyList Tactics.
Set Bullet Behavior "Strict Subproofs".

(* We axiomatize a random number generator
   (currently written in OCaml only) *)
Axiom RandomSeed : Type.
Axiom randomSeed_inhabited : inhabited RandomSeed.

Axiom randomNext     : RandomSeed -> Z * RandomSeed.
Axiom randomGenRange : RandomSeed -> Z * Z.
Axiom mkRandomSeed   : Z          -> RandomSeed.
Axiom newRandomSeed  : RandomSeed.

(* begin randomSplitAssumption *)
Axiom randomSplit : RandomSeed -> RandomSeed * RandomSeed.
Axiom randomSplitAssumption :
  forall s1 s2 : RandomSeed, exists s, randomSplit s = (s1,s2).
(* end randomSplitAssumption *)

CoInductive RandomSeedTree :=
| RstNode : RandomSeed -> RandomSeedTree -> RandomSeedTree -> RandomSeedTree.

Definition root_rst (rst : RandomSeedTree) : RandomSeed :=
  match rst with
  | RstNode root _ _ => root
  end.

Definition left_rst (rst : RandomSeedTree) : RandomSeedTree :=
  match rst with
  | RstNode _ t1 _ => t1
  end.

Definition right_rst (rst : RandomSeedTree) : RandomSeedTree :=
  match rst with
  | RstNode _ _ t2 => t2
  end.

Lemma rst_eta : forall rst : RandomSeedTree,
  rst = RstNode (root_rst rst) (left_rst rst) (right_rst rst).
Proof. destruct rst. reflexivity. Qed.

CoFixpoint mkSeedTree (s : RandomSeed) : RandomSeedTree :=
  let (s1, s2) := randomSplit s in
  RstNode s (mkSeedTree s1) (mkSeedTree s2).

Lemma mkSeedTreeHelper r :
  mkSeedTree r = RstNode r (mkSeedTree (randomSplit r).1) (mkSeedTree (randomSplit r).2).
Proof. by rewrite [mkSeedTree _]rst_eta /=; case: (randomSplit r). Qed.

Inductive SplitDirection := Left | Right.

Definition SplitPath := list SplitDirection.

Require Import List. Import ListNotations.
Fixpoint varySeedAux (p : SplitPath) (rst : RandomSeedTree) : RandomSeed :=
  let '(RstNode s t1 t2) := rst in
  match p with
    | [] => s
    | Left  :: p' => varySeedAux p' t1
    | Right :: p' => varySeedAux p' t2
  end.

Definition varySeed (p : SplitPath) (s : RandomSeed) : RandomSeed :=
  varySeedAux p (mkSeedTree s).

Inductive SeedTree :=
| SeedTreeUndef : SeedTree
| SeedTreeLeaf : RandomSeed -> SeedTree
| SeedTreeNode : SeedTree -> SeedTree -> SeedTree.

Inductive SubSeedTree : SeedTree -> RandomSeedTree -> Prop :=
| SubUndef : forall (rst : RandomSeedTree), SubSeedTree SeedTreeUndef rst
| SubLeaf  : forall (s : RandomSeed) (rst1 rst2 : RandomSeedTree),
               SubSeedTree (SeedTreeLeaf s) (RstNode s rst1 rst2)
| SubNode  : forall (st1 st2 : SeedTree) (rst1 rst2 : RandomSeedTree) (s : RandomSeed),
               SubSeedTree st1 rst1 ->
               SubSeedTree st2 rst2 ->
               SubSeedTree (SeedTreeNode st1 st2) (RstNode s rst1 rst2).

Fixpoint varySeed' (st : SeedTree) (p : SplitPath) : option RandomSeed :=
  match st with
    | SeedTreeUndef => None
    | SeedTreeLeaf s =>
      match p with
        | [] => Some s
        | _  => None
      end
    | SeedTreeNode st1 st2 =>
      match p with
        | [] => None
        | Left  :: p' => varySeed' st1 p'
        | Right :: p' => varySeed' st2 p'
      end
  end.

Lemma pathAgreesOnSubTree : forall (st : SeedTree) (rst : RandomSeedTree) (p : SplitPath)
                                   (s : RandomSeed),
                              SubSeedTree st rst ->
                              varySeed' st p = Some s ->
                              varySeedAux p rst = s.
Proof.
induction st.
+ intros. simpl in H0. congruence.
+ intros. simpl in H0.
  destruct p eqn:P.
  - inversion H. simpl. inversion H0. reflexivity.
  - inversion H0.
+ intros. simpl in H0.
  destruct p eqn:P.
  - inversion H0.
  - inversion H; subst.
    destruct s0 eqn:S0.
    * simpl. apply IHst1; auto.
    * simpl. apply IHst2; auto.
Qed.

Lemma splitExpand st : exists s, SubSeedTree st (mkSeedTree s).
Proof.
elim: st => [|r|st1 [s1 st_s1] st2 [s2 st_s2]].
+ by case: randomSeed_inhabited=> seed; exists seed; apply: SubUndef.
+ by exists r; rewrite mkSeedTreeHelper; constructor.
+ have [s eq_s] := randomSplitAssumption s1 s2.
by exists s; rewrite mkSeedTreeHelper eq_s; constructor.
Qed.

Inductive PrefixFree : list SplitPath -> Prop :=
| FreeNil : PrefixFree []
| FreeCons : forall (p : SplitPath) (l : list SplitPath),
               PrefixFree l ->
               (forall (p' : SplitPath), In p' l ->
                                        (forall p1 p2, p' ++ p1 = p ++ p2-> False)) ->
                                        PrefixFree (p :: l).

Lemma prefixFreeSingleton : forall p, PrefixFree [p].
intro.
apply FreeCons.
+ apply FreeNil.
+ intros. inversion H.
Qed.

Lemma prefixFreeEmpty : forall l, PrefixFree ([] :: l) -> l = [].
intros.
destruct l; auto.
inversion H.
subst.
pose proof H3 l.
assert (In l (l :: l0)) by (left; auto).
eapply H0 in H1. inversion H1.
instantiate (2 := []). rewrite app_nil_r; simpl; eauto.
Qed.

Inductive correspondingSeedTree (l : list SplitPath) (f : SplitPath -> RandomSeed)
          (st : SeedTree) : Prop :=
| Corresponding : (forall (p : SplitPath) s, varySeed' st p = Some s -> In p l) ->
                  (forall (p : SplitPath), In p l -> varySeed' st p = Some (f p)) ->
                  PrefixFree l ->
                  correspondingSeedTree l f st.

Lemma corrEmptyUndef : forall f, correspondingSeedTree [] f SeedTreeUndef.
  intro f.
  apply Corresponding.
  + intros p s Contra.
    inversion Contra.
  + intros p InNil. inversion InNil.
  + apply FreeNil.
Qed.

Ltac fireInLeft name :=
  match goal with
    | [H : In ?X (?X :: ?XS) -> _ |- _ ] =>
      assert (In X (X :: XS)) as name by (left; auto); apply H in name; clear H
  end.

Lemma corrUndefEmpty : forall l f, correspondingSeedTree l f SeedTreeUndef -> l = [].
intros l f Corr.
inversion Corr as [Vary_In In_Vary Pref]; clear Corr.
destruct l as [ | p ps]; auto.
clear Vary_In Pref.
pose proof (In_Vary p) as Contra; clear In_Vary.
fireInLeft Hyp.
inversion Hyp.
Qed.

Lemma PrefixFreeWithNil : forall l, PrefixFree ([] :: l) -> l = [].
  intros.
  inversion H; subst.
  destruct l eqn:L; auto.
  pose proof (H3 l0).
  assert (In l0 (l0 :: l1)) by (left; auto).
  eapply H0 in H1.
  + inversion H1.
  + instantiate (1 := l0). instantiate (1 := []). rewrite app_nil_r. auto.
Qed.

Lemma corrEmptyLeaf : forall s l f, correspondingSeedTree l f (SeedTreeLeaf s) ->
                                    l = [[]] /\ s = f [].
  intros s l f Corr.
  inversion Corr as [Vary_In In_Vary Pref]; clear Corr.
  pose proof (Vary_In [] s) as Hyp; clear Vary_In.
  simpl in Hyp.
  assert (InNilL : In [] l) by (apply Hyp; auto); clear Hyp.
  split.
  + destruct l eqn:L.
    - inversion InNilL.
    - destruct s0 eqn : S0.
      * apply PrefixFreeWithNil in Pref; subst; auto.
      * pose proof (In_Vary (s1 :: s2)) as Hyp; clear In_Vary.

        inversion Pref.
        fireInLeft Hyp'. simpl in Hyp'. inversion Hyp'.

  + pose proof In_Vary [] as Hyp; clear In_Vary.
    apply Hyp in InNilL; clear Hyp.
    simpl in *.
    congruence.
Qed.

Lemma corrNodeNonEmpty : forall st1 st2 l p f,
                           correspondingSeedTree l f (SeedTreeNode st1 st2) ->
                           In p l -> p <> [].
unfold not; intros st1 st2 l p f Corr InPL PNil; subst.
inversion Corr as [_ In_Vary _]; clear Corr.
pose proof (In_Vary []) as Hyp; clear In_Vary.
apply Hyp in InPL; clear Hyp.
simpl in InPL.
inversion InPL.
Qed.

#[local]
Hint Resolve corrEmptyUndef corrNodeNonEmpty : core.

Definition Direction_eq_dec : forall (d1 d2 : SplitDirection),
                                {d1 = d2} + {d1 <> d2}.
decide equality.
Qed.

Definition eq_dir_b (d1 d2 : SplitDirection) : bool :=
  match d1,d2 with
    | Left, Left => true
    | Right, Right => true
    | _, _ => false
  end.

Lemma eq_dir_b_eq : forall d1 d2, eq_dir_b d1 d2 = true <-> d1 = d2.
intros.
unfold eq_dir_b.
destruct d1; destruct d2; split; auto; intro Contra; inversion Contra.
Qed.

Definition refineList (d : SplitDirection) (l : list SplitPath) : list SplitPath :=
  map (@tl SplitDirection) (filter (fun p => match hd_error p with
                             | Some d' => eq_dir_b d d'
                             | _       => false
                           end) l).

Lemma refineCorrect : forall d l p, In p (refineList d l) -> In (d :: p) l.
intros d l p.
unfold refineList.
rewrite in_map_iff.
intros.
inversion H; clear H.
inversion H0; clear H0.
generalize H1; clear H1.
rewrite filter_In.
intros H0.
inversion H0; clear H0.
unfold tl in H.
destruct x eqn:X.
+ simpl in H2. inversion H2.
+ simpl in H2. apply eq_dir_b_eq in H2. subst. auto.
Qed.

Lemma refineCorrect' : forall d l p, In (d :: p) l -> In p (refineList d l).
intros.
unfold refineList.
apply in_map_iff.
exists (d :: p).
split; auto.
apply filter_In.
split; simpl; auto.
unfold eq_dir_b; destruct d; auto.
Qed.

Lemma refinePreservesPrefixFree : forall d l, PrefixFree l -> PrefixFree (refineList d l).
  intros.
  induction l.
  - unfold refineList; constructor.
  - destruct a eqn:A; subst.
    * apply prefixFreeEmpty in H. subst. unfold refineList. simpl. constructor.
    * destruct s eqn:S; destruct d; subst.
      + unfold refineList; simpl.
        eapply FreeCons.
        -- apply IHl. inversion H; auto.
        -- intros. inversion H; subst; clear H.
           apply in_map_iff in H0.
           inversion H0; subst; clear H0.
           inversion H; subst; clear H.
           apply filter_In in H2. inversion H2; subst; clear H2.
           destruct x eqn:X; simpl in *. inversion H0.
           destruct s eqn:S; simpl in *.
           pose proof H5 (Left :: l0).
           eapply H2 in H; auto.
           simpl. instantiate (1 := p2). instantiate (1:= p1). rewrite H1. auto.
           inversion H0.
      + unfold refineList; simpl. apply IHl.
        inversion H. auto.
      + unfold refineList; simpl. apply IHl.
        inversion H. auto.
      + unfold refineList; simpl.
        eapply FreeCons.
        -- apply IHl. inversion H; auto.
        -- intros. inversion H; subst; clear H.
           apply in_map_iff in H0.
           inversion H0; subst; clear H0.
           inversion H; subst; clear H.
           apply filter_In in H2. inversion H2; subst; clear H2.
           destruct x eqn:X; simpl in *. inversion H0.
           destruct s eqn:S; simpl in *.
           inversion H0.
           pose proof H5 (Right :: l0).
           eapply H2 in H; auto.
           simpl. instantiate (1 := p2). instantiate (1:= p1). rewrite H1. auto.
Qed.

Definition refineFunction (f : SplitPath -> RandomSeed) (d : SplitDirection) (arg : SplitPath) :
RandomSeed :=
  f (d :: arg).

Lemma refineFunCorrect : forall f d p, f (d :: p) = (refineFunction f d) p.
auto.
Qed.

#[local]
Hint Rewrite refineFunCorrect : core.
#[local]
Hint Unfold  refineFunction   : core.

Program Fixpoint addToTree (st : SeedTree) (p : SplitPath) (f : SplitPath -> RandomSeed)
        (l : list SplitPath)
        (Corr : correspondingSeedTree l f st)
        (Pref : forall p', In p' l -> (forall p1 p2, p ++ p1 = p' ++ p2 -> False))
: SeedTree :=
  match st with
    | SeedTreeUndef =>
      match p with
        | [] => SeedTreeLeaf (f p)
        | Left  :: p' => SeedTreeNode (addToTree SeedTreeUndef p' (refineFunction f Left) [] _ _) SeedTreeUndef
        | Right :: p' => SeedTreeNode SeedTreeUndef (addToTree SeedTreeUndef p' (refineFunction f Right) [] _ _)
      end
    | SeedTreeLeaf s => _  (* Contradiction! *)
    | SeedTreeNode st1 st2 =>
      match p with
        | [] => SeedTreeLeaf (f p)
        | Left  :: p' => SeedTreeNode (addToTree st1 p' (refineFunction f Left) (refineList Left l) _ _) st2
        | Right :: p' => SeedTreeNode st1 (addToTree st2 p' (refineFunction f Right) (refineList Right l) _ _)
      end
  end.
Next Obligation.
apply corrEmptyLeaf in Corr. inversion Corr; clear Corr; subst.
pose proof (Pref []).
exfalso.
eapply H.
+ left; auto.
+ instantiate (2 := []). rewrite app_nil_r. simpl. eauto.
Qed.
Next Obligation.
eapply Corresponding; intros.
+ apply refineCorrect'.
  inversion Corr as [Vary_In _ _ ]; clear Corr.
  pose proof (Vary_In (Left :: p) s) as Hyp; clear Vary_In.
  auto.
+ apply refineCorrect in H.
  inversion Corr as [_ In_Vary _]; clear Corr.
  pose proof (In_Vary (Left :: p)) as Hyp; clear In_Vary.
  apply Hyp in H; clear Hyp.
  simpl in H.
  unfold refineFunction; auto.
+ inversion Corr.
  apply refinePreservesPrefixFree.
  auto.
Qed.
Next Obligation.
eapply Pref.
instantiate (1:= Left :: p'0).
apply refineCorrect; auto.
instantiate (1:= p2). instantiate (1:=p1). simpl. rewrite H0. auto.
Qed.
Next Obligation.
eapply Corresponding; intros.
+ apply refineCorrect'.
  inversion Corr as [Vary_In _ _ ]; clear Corr.
  pose proof (Vary_In (Right :: p) s) as Hyp; clear Vary_In.
  auto.
+ apply refineCorrect in H.
  inversion Corr as [_ In_Vary _]; clear Corr.
  pose proof (In_Vary (Right :: p)) as Hyp; clear In_Vary.
  apply Hyp in H; clear Hyp.
  simpl in H.
  unfold refineFunction; auto.
+ inversion Corr.
  apply refinePreservesPrefixFree.
  auto.
Qed.
Next Obligation.
eapply Pref.
instantiate (1:= Right :: p'0).
apply refineCorrect; auto.
instantiate (1:= p2). instantiate (1:=p1). simpl. rewrite H0. auto.
Qed.

Lemma addToTreeCorrect1 : forall (st : SeedTree) (p : SplitPath)
  (f : SplitPath -> RandomSeed)
  (l : list SplitPath) (Corr : correspondingSeedTree l f st)
  (Pref : forall p', In p' l -> (forall p1 p2, p ++ p1 = p' ++ p2 -> False)),
  varySeed' (addToTree st p f l Corr Pref) p = Some (f p).
intros st p.
generalize dependent st.
induction p.
+ intros st f l Corr Pref.
  unfold addToTree.
  destruct st.
  - auto.
  - exfalso.
    apply corrEmptyLeaf in Corr.
    inversion Corr; clear Corr.
    subst.
    pose proof Pref [] as Contra; clear Pref.
    eapply Contra; clear Contra.
    * left; auto.
    * instantiate (1 := []). instantiate (1 := []). auto.
  - simpl. auto.
+ intros.
  destruct st; destruct a; simpl.
  - rewrite refineFunCorrect.
    apply IHp.
  - rewrite refineFunCorrect; apply IHp.
  - exfalso. eapply corrEmptyLeaf in Corr; inversion Corr; subst; clear Corr.
    pose proof (Pref []).
    eapply H.
    -- subst; left; auto.
    -- simpl. instantiate (2:= []); rewrite app_nil_r. instantiate (1 := Left ::p); auto.
  - exfalso. eapply corrEmptyLeaf in Corr; inversion Corr; subst; clear Corr.
    pose proof (Pref []).
    eapply H.
    -- subst; left; auto.
    -- simpl. instantiate (2:= []); rewrite app_nil_r. instantiate (1 := Right ::p); auto.
  - rewrite refineFunCorrect; apply IHp.
  - rewrite refineFunCorrect; apply IHp.
Qed.

Lemma addToTreeCorrect2 : forall (st : SeedTree) (p : SplitPath)
  (f : SplitPath -> RandomSeed)
  (l : list SplitPath) (Corr : correspondingSeedTree l f st)
  (Pref : forall p', In p' l -> (forall p1 p2, p ++ p1 = p' ++ p2 -> False)),
  forall p' seed, varySeed' st p' = Some seed ->
             varySeed' (addToTree st p f l Corr Pref) p' = Some seed.
intros st p.
generalize dependent st.
induction p as [ | d ds].
+ intros.
  exfalso.
  eapply Pref.
  - inversion Corr as [Vary_In In_Vary Pref']; clear Corr.
    eapply Vary_In; eassumption.
  - instantiate (1 := []); instantiate (1 := p'); rewrite app_nil_r; auto.
+ intros st f l Corr Pref p' seed VarySome.
  destruct st; destruct d; simpl; auto.
  * exfalso. apply corrUndefEmpty in Corr. subst. inversion VarySome.
  * exfalso. apply corrUndefEmpty in Corr. subst. inversion VarySome.
  * exfalso.
    apply corrEmptyLeaf in Corr; inversion Corr; subst; clear Corr.
    eapply Pref.
    instantiate (1 := []); left; auto.
    instantiate (1:= Left :: ds). instantiate (1 := []). rewrite app_nil_r; simpl; auto.
  * exfalso.
    apply corrEmptyLeaf in Corr; inversion Corr; subst; clear Corr.
    eapply Pref.
    instantiate (1 := []); left; auto.
    instantiate (1:= Right :: ds). instantiate (1 := []). rewrite app_nil_r; simpl; auto.
  * destruct p'.
    - simpl in VarySome. inversion VarySome.
    - destruct s.
      ++ apply IHds; auto.
      ++ auto.
  * destruct p'.
    - simpl in VarySome; inversion VarySome.
    - destruct s.
      ++ auto.
      ++ apply IHds; auto.
Qed.

Lemma addToTreeCorrect3 : forall (st : SeedTree) (p : SplitPath)
  (f : SplitPath -> RandomSeed)
  (l : list SplitPath) (Corr : correspondingSeedTree l f st)
  (Pref : forall p', In p' l -> (forall p1 p2, p ++ p1 = p' ++ p2 -> False)),
  forall p' seed, varySeed' (addToTree st p f l Corr Pref) p' = Some seed ->
             p = p' \/ varySeed' st p' = Some seed.
intros st p. generalize dependent st.
induction p.
+ intros.
  destruct p'.
  - left; auto.
  - right.
    exfalso.
    unfold addToTree in H; simpl in H.
    destruct st; simpl in H.
    * inversion H.
    * clear H. apply corrEmptyLeaf in Corr; inversion Corr; subst; clear Corr.
      subst.
      eapply Pref.
      instantiate (1 := []). left; auto.
      instantiate (1 := []); instantiate (1 := []); auto.
    * inversion H.
+ intros.
  destruct p'; destruct st; destruct a; simpl in *;
  try solve [match goal with [ H : None = Some _ |- _ ] => inversion H end].
  ++ exfalso. clear H. apply corrEmptyLeaf in Corr; inversion Corr; subst; clear Corr.
    eapply Pref.
    subst.
    instantiate (1 := []) ; left; auto.
    instantiate (1 := (Left :: p)); instantiate (1 := []); rewrite app_nil_r; auto.
  ++ exfalso. clear H. apply corrEmptyLeaf in Corr; inversion Corr; subst; clear Corr.
    eapply Pref.
    subst.
    instantiate (1 := []) ; left; auto.
    instantiate (1 := (Right :: p)); instantiate (1 := []); rewrite app_nil_r; auto.
  ++ destruct s; simpl in *.
    - assert (p = p' \/ varySeed' SeedTreeUndef p' = Some seed)
             by (eapply IHp; eauto).
      inversion H0.
      * left; subst; auto.
      * simpl in H1. inversion H1.
    - inversion H.
  ++ destruct s; simpl in *.
    - inversion H.
    - assert (p = p' \/ varySeed' SeedTreeUndef p' = Some seed)
        by (eapply IHp; eauto).
      inversion H0.
      * left; subst; auto.
      * simpl in H1. inversion H1.
  ++ exfalso.
    clear H.
    apply corrEmptyLeaf in Corr; inversion Corr; subst; clear Corr.
    subst.
    eapply Pref.
    instantiate (1 := []).
    - left; auto.
    - instantiate (1 := Left :: p); instantiate (1 := []); rewrite app_nil_r; auto.
  ++ exfalso.
    clear H.
    apply corrEmptyLeaf in Corr; inversion Corr; subst; clear Corr.
    subst.
    eapply Pref.
    instantiate (1 := []).
    - left; auto.
    - instantiate (1 := Right :: p); instantiate (1 := []); rewrite app_nil_r; auto.
  ++ destruct s eqn:S; simpl in *.
    - assert (p = p' \/ varySeed' st1 p' = Some seed)
        by (eapply IHp; eauto).
      inversion H0.
      * left; subst; auto.
      * right; auto.
    - right; auto.
  ++ destruct s eqn:S; simpl in *.
    - right; auto.
    - assert (p = p' \/ varySeed' st2 p' = Some seed)
        by (eapply IHp; eauto).
      inversion H0.
      * left; subst; auto.
      * right; auto.
Qed.

Lemma addToTreeCorrect : forall (st : SeedTree) (p : SplitPath)
  (f : SplitPath -> RandomSeed)
  (l : list SplitPath) (Corr : correspondingSeedTree l f st)
  (Pref : forall p', In p' l -> (forall p1 p2, p ++ p1 = p' ++ p2 -> False)),
  correspondingSeedTree (p :: l) f (addToTree st p f l Corr Pref).
intros.
apply Corresponding.
+ intros p' s VarySome.
  inversion Corr as [Vary_In In_Vary Pref'].
  apply addToTreeCorrect3 in VarySome.
  inversion VarySome.
  - left; auto.
  - right. eapply Vary_In; eassumption.
+ intros p' InP'.
  inversion Corr as [Vary_In In_Vary Pref'].
  inversion InP'.
  - subst.
    apply addToTreeCorrect1.
  - apply addToTreeCorrect2. apply In_Vary. auto.
+ apply FreeCons.
  - inversion Corr; auto.
  - intros.
    eapply Pref.
    eassumption.
    instantiate (1 := p1); instantiate (1:= p2); subst; auto.
Qed.

Lemma PrefixFreeTail : forall a l, PrefixFree (a :: l) -> PrefixFree l.
intros.
inversion H.
auto.
Qed.

(* LL: Why was it easier to do it like this? :P *)
Fixpoint listToTree (l : list SplitPath) (f : SplitPath -> RandomSeed)
        ( Pref : PrefixFree l) : {s : SeedTree | correspondingSeedTree l f s}.
Proof.
induction l.
+ exists SeedTreeUndef. apply corrEmptyUndef.
+ remember Pref as Pref'. clear HeqPref'. apply PrefixFreeTail in Pref'.
  apply IHl in Pref'.
  inversion Pref'; clear Pref'.
  assert (forall p', In p' l -> forall p1 p2, a ++ p1 = p' ++ p2 -> False) by
      (inversion Pref; intros; subst; eapply H3; [eassumption |
    instantiate (1 := p1); instantiate (1 := p2); subst; auto]).
  exists (addToTree x a f l H H0).
  apply addToTreeCorrect.
Qed.

(* begin SplitPathCompleteness *)
Theorem SplitPathCompleteness (l : list SplitPath) (f : SplitPath -> RandomSeed) :
  PrefixFree l -> exists (s : RandomSeed), forall p, In p l -> varySeed p s = f p.
(* end SplitPathCompleteness *)
intros Pref.
pose proof (listToTree l f Pref) as ExSeedTree.
inversion ExSeedTree as [st Corr]; clear ExSeedTree.
inversion Corr as [Vary_In In_Vary Pref']; clear Corr.
pose proof (splitExpand st) as ExRst.
inversion ExRst as [rst Sub]; clear ExRst.
exists rst.
intros p InPL.
pose proof (pathAgreesOnSubTree st (mkSeedTree rst) p (f p)) as Hyp.
auto.
Qed.

(* Primitive generator combinators and some basic soundness
   assumptions about them *)
Axiom randomRBool : bool * bool -> RandomSeed -> bool * RandomSeed.
Axiom randomRBoolCorrect :
  forall b b1 b2, implb b1 b2 ->
    (implb b1 b && implb b b2 <->
    exists seed, (fst (randomRBool (b1, b2) seed)) = b).
Axiom randomRNat  : nat  * nat -> RandomSeed -> nat * RandomSeed.
Axiom randomRNatCorrect:
  forall n n1 n2, n1 <= n2 ->
    (n1 <= n <= n2 <->
    exists seed, (fst (randomRNat (n1, n2) seed)) = n).
Axiom randomRInt  : Z * Z    -> RandomSeed -> Z * RandomSeed.
Axiom randomRIntCorrect:
  forall z z1 z2, Z.leb z1 z2 ->
    (Z.leb z1 z && Z.leb z z2 <->
    exists seed, (fst (randomRInt (z1, z2) seed)) = z).
Axiom randomRN    : N * N    -> RandomSeed -> N * RandomSeed.
Axiom randomRNCorrect:
  forall n n1 n2,
    N.leb n1 n2 ->
    N.leb n1 n && N.leb n n2 <->
    exists seed, fst (randomRN (n1, n2) seed) = n.

(* A small experiment showing that infinite random trees
   are a potential model of the randomSplitAssumption *)

Module InfiniteTrees.
  CoInductive RandomSeed : Type :=
  | Node : bool -> RandomSeed -> RandomSeed -> RandomSeed.

  Definition randomSplit (s : RandomSeed) :=
    match s with
    | Node b s1 s2 => (s1,s2)
    end.

  Lemma randomSplitAssumption :
    forall s1 s2 : RandomSeed, exists s, randomSplit s = (s1,s2).
  Proof.
    move => s1 s2. by exists (Node true s1 s2).
  Qed.
End InfiniteTrees.

(* Type class machinery for generating things in intervals *)

Class OrdType (A: Type) :=
  {
    leq     : A -> A -> bool;
    refl    : reflexive leq;
    trans   : transitive leq;
    antisym : antisymmetric leq
  }.

#[global]
Program Instance OrdBool : OrdType bool :=
  {
    leq b1 b2 := implb b1 b2
  }.
Next Obligation.
  by case.
Qed.
Next Obligation.
  by do 3! case.
Qed.
Next Obligation.
  by do 2! case.
Qed.

#[global]
Program Instance OrdNat : OrdType nat :=
  {
    leq := ssrnat.leq;
    refl := leqnn;
    trans := leq_trans;
    antisym := anti_leq
  }.

#[global]
Program Instance OrdZ : OrdType Z :=
  {
    leq := Z.leb;
    refl := Z.leb_refl
  }.
Next Obligation.
move=> x y z le_yx le_xz.
exact: (Zle_bool_trans y x z).
Qed.
Next Obligation.
move=> x y /andP[].
exact: Zle_bool_antisym.
Qed.

#[global]
Program Instance OrdN : OrdType N :=
  {
    leq := N.leb;
    refl := N.leb_refl
  }.
Next Obligation.
  move=> x y z le_yx le_xz.
  unfold is_true in *.
  apply N.leb_le in le_yx.
  apply N.leb_le in le_xz.
  apply N.leb_le.
  eapply N.le_trans; eauto.
Qed.
Next Obligation.
  move=> x y /andP[].
  unfold is_true.
  repeat rewrite N.leb_le.
  intros.
  apply N.le_antisymm; auto.
Qed.

Class ChoosableFromInterval (A : Type)  :=
  {
    super : OrdType A;
    randomR : A * A -> RandomSeed -> A * RandomSeed;
    randomRCorrect :
      forall (a a1 a2 : A), leq a1 a2 ->
      (leq a1 a && leq a a2 <->
       exists seed, fst (randomR (a1, a2) seed) = a);
    enumR : A * A -> LazyList A;
    enumRCorrect :
      forall (a a1 a2 : A), leq a1 a2 ->
      (leq a1 a && leq a a2 <->
       In_ll a (enumR (a1,a2)))
  }.
#[global]
Existing Instance super.

(* This is false.
#[global]
Program Instance ChooseBool : ChoosableFromInterval bool :=
  {
    randomR := randomRBool;
    randomRCorrect := randomRBoolCorrect
  }.
 *)

Definition enumRNat (p : nat * nat) :=
  lazy_seq S (fst p) (S (snd p - fst p)).

Lemma enumRNatCorrect :
  forall (a a1 a2 : nat),
    a1 <= a2 ->
    (a1 <= a  <= a2 <->
     In_ll a (enumRNat (a1,a2))).
Proof.
  unfold enumRNat. intros a a1 a2.
  replace (a1, a2).1  with a1 by reflexivity.
  replace ((a1, a2).2 - a1).+1 with ((a2 - a1).+1) by reflexivity.
  intros Hleq1. simpl in Hleq1.

  assert ((a2 - a1).+1 > 0) by ssromega.
  assert (a2 = ((a2 - a1).+1 - 1) + a1) by ssromega.
  revert H H0.
  generalize ((a2 - a1).+1) as n. intros n Hlt Heq.
  rewrite Heq. clear Heq Hleq1 a2.
  simpl. revert a1 a. induction n; intros a1 a.
  - ssromega.
  - simpl in *. split.
    + intros Hleq.
      destruct (Nat.eq_dec a1 a); eauto.
      right. eapply IHn; ssromega.
    + intros Hin. destruct Hin. subst. ssromega.
      destruct n.
      simpl in *. contradiction.
      simpl in *. eapply IHn in H; now ssromega.
Qed.

#[global]
Instance ChooseNat : ChoosableFromInterval nat :=
  {
    randomR := randomRNat;
    randomRCorrect := randomRNatCorrect;
    enumR := enumRNat;
    enumRCorrect := enumRNatCorrect
  }.

Definition enumRZ (p : Z * Z) :=
  lazy_seq (Z.add 1%Z) (fst p) (S (Z.to_nat (snd p - fst p))).

Lemma enumRZCorrect :
      forall (a a1 a2 : Z), leq a1 a2 ->
      (leq a1 a && leq a a2 <->
       In_ll a (enumRZ (a1,a2))).
Proof.
Admitted.

#[global]
Instance ChooseZ : ChoosableFromInterval Z :=
  {
    randomR := randomRInt;
    randomRCorrect := randomRIntCorrect;
    enumR := enumRZ;
    enumRCorrect := enumRZCorrect
  }.

Definition enumRN (p : N * N) :=
  lazy_seq N.succ N.one (S (N.to_nat (snd p - fst p))).

Lemma enumRNCorrect :
      forall (a a1 a2 : N), leq a1 a2 ->
      (leq a1 a && leq a a2 <->
       In_ll a (enumRN (a1,a2))).
Admitted.

#[global]
Instance ChooseN : ChoosableFromInterval N :=
  {
    randomR := randomRN;
    randomRCorrect := randomRNCorrect;
    enumR := enumRN;
    enumRCorrect := enumRNCorrect
  }.


Require Import include_frm.
Require Import base_tac.
Require Import Coq.Logic.Classical_Pred_Type.

Require Import mem_join_lemmas.
Require Import aux_map_lib.

Open Scope Z_scope.
(* Lemmas *)
(* get *)
Lemma allocb_get_some :
    forall m b n i off,
      (off<n)%nat->
        exists v,
          get (allocb m b i n) (b, (i + Z_of_nat off)) = Some (true,v).
Proof.
  intros.
  gen m i off.
  induction n.
  intros.
  omega.
  intros.
  destruct off.
  simpl.
  exists Undef.
  rewrite Z.add_0_r.
  rewrite set_a_get_a; auto.

  rewrite Nat2Z.inj_succ.
  assert (Z.succ (Z.of_nat off) = 1 + (Z.of_nat off))%Z.
  omega.
  rewrite H0.
  rewrite Z.add_assoc.
  simpl.
  rewrite set_a_get_a'.
  apply IHn.
  omega.

  intro; inverts H1.
  assert (Z.of_nat off >=0)%Z.
  omega.
  assert (i + 1 + Z.of_nat off >i)%Z.
  omega.
  rewrite<-H3 in H2.
  omega.
Qed.

Lemma allocb_get_none :
  forall m b i off n,
    (off>0)->
    fresh m b ->
    get (allocb m b (BinInt.Z.add i off) n) (b, i) = None.
Proof.
  intros.
  gen m i off.
  induction n.
  intros.
  simpl.
  apply nindom_get.
  unfold fresh in H0.
  eapply H0;eauto.
  intros.
  simpl.
  rewrite set_a_get_a'.
  rewrite<-Z.add_assoc.
  apply IHn;eauto.
  omega.
  intro.
  inversion H1.
  assert (i + off > i).
  omega.
  rewrite H3 in H2.
  omega.
Qed.

Lemma freeb_get_same :
    forall m m' b i off n,
      (off>0)%Z->
      freeb m b (BinInt.Z.add i off) n = Some m' ->
        get m' (b, i) = get m (b, i).
Proof.
  intros.
  gen m m' i off H.
  induction n.
  intros.
  simpl in H0.
  injection H0;intros;subst.
  auto.
  intros.
  simpl in H0.
  remember (get m (b, (i + off))) as v1.
  destruct v1;tryfalse.
  destruct p; destruct b0; tryfalse.
  remember (freeb m b (i + off + 1) n) as m1.
  destruct m1;tryfalse.
  injection H0;intros.
  rewrite<-H1.

  rewrite mem_del_get_neq.
  rewrite<-Z.add_assoc in Heqm1.
  erewrite IHn;eauto.
  omega.
  intro.
  inversion H2.
  assert (i + off > i)%Z.
  omega.
  rewrite <- H4 in H3.
  omega.
Qed.

Lemma storebytes_get_same :
    forall m m' b i off vl,
      (off>0)->
        storebytes m (b, (BinInt.Z.add i off)) vl = Some m' ->
        get m' (b, i) = get m (b, i).
Proof.
  intros.
  gen m m' i off H.
  induction vl.
  intros.
  simpl in H0.
  injection H0;intros;subst.
  auto.
  intros.
  simpl in H0.
  unfold get in H0; simpl in H0.
  remember (HalfPermMap.get m (b, i + off)) as v1.
  destruct v1; tryfalse.
  destruct b0.
  destruct b0; tryfalse.
  remember (storebytes m (b, (i + off + 1)) vl) as m1.
  destruct m1;tryfalse.
  injection H0;intros.
  rewrite<-H1.

  rewrite set_a_get_a'.
  eapply IHvl.
  erewrite<-BinInt.Z.add_assoc in Heqm1.
  eauto.
  omega.

  intro.
  inversion H2.
  assert (i + off > i).
  omega.
  rewrite H4 in H3.
  omega.
Qed.

(* memory existential *)
Lemma allocb_storebytes_mem_ex :
  forall vl n m b i,
    ((length vl) + i = n)%nat ->
      (exists m', storebytes (allocb m b 0 n) (b, Z_of_nat i) vl = Some m').
Proof.
  intros.
  gen i.
  induction vl.
  simpl.
  eexists;eauto.
  simpl.
  intros.
  generalize allocb_get_some.
  intros.
  generalize (H0 m b n 0 i).
  intros.
  assert (i<n)%nat.
  omega.
  apply H1 in H2.
  destruct H2.
  simpl in H2.

  change (
      (fun x =>
         exists m',
           match x with
             | Some (true, _) =>
               match storebytes (allocb m b 0 n) (b, Z.of_nat i + 1) vl with
                 | Some m'0 => Some (set m'0 (b, Z.of_nat i) (true, a))
                 | None => None
               end
             | Some (false, _) => None
             | None => None
           end = Some m') (get (allocb m b 0 n) (b, Z.of_nat i))).
  rewrite H2.

  generalize (IHvl (i+1)%nat).
  intros.
  assert ((length vl + (i + 1))%nat = n).
  omega.
  apply H3 in H4.
  destruct H4.
  rewrite Nat2Z.inj_add in H4.
  simpl in H4.
  rewrite H4.
  eexists;eauto.
Qed.

Lemma allocb_store_mem_ex :
  forall t m b v,
    (exists m', store t (allocb m b 0 (typelen t)) (b, BinNums.Z0) v = Some m').
Proof.
  intros.
  unfold store.
  generalize encode_val_length.
  intros.
  generalize (H t v).
  intros.
  remember (typelen t) as n.
  remember (encode_val t v) as vl.
  assert (0 = Z_of_nat 0).
  auto.
  rewrite H1.
  eapply allocb_storebytes_mem_ex.
  omega.
Qed.

(* join *)
Lemma join_allocb :
  forall m1 M m2 m1' m2' b i n, join m1 M m2 ->
    m1' = allocb m1 b i n ->
    m2' = allocb m2 b i n ->
    fresh m2 b ->
    join m1' M m2'.
Proof.
  introv. gen m1 M m2 m1' m2' i.
  induction n.
  intros.
  simpl in H0,H1.
  subst;auto.
  intros.
  rewrite H0,H1.
  simpl.
  eapply join_set_nindom_l.
  eapply IHn;eauto.
  eauto.
  eauto.
  gen H2.
  clear.
  intro.
  assert (get (allocb m2 b (BinInt.Z.add i 1) n) (b, i) = None).
  apply allocb_get_none.
  omega.
  auto.
  red.
  intros.
  apply indom_get in H0.
  destruct H0.
  unfold get in *; simpl in *.
  rewrite H in H0.
  inversion H0.
Qed.

Lemma join_freeb :
  forall m1 M m2 m1' m2' b i n, join m1 M m2 ->
    freeb m1 b i n = Some m1' ->
    freeb m2 b i n = Some m2' ->
    join m1' M m2'.
Proof.
  introv.
  gen m1 M m2 m1' m2' i.
  induction n.
  simpl.
  intros.
  injection H0;intros;subst.
  injection H1;intros;subst.
  auto.
  simpl.
  intros.
  remember (get m1 (b, i)) as v1.
  remember (get m2 (b, i)) as v2.
  destruct v1,v2;tryfalse.
  destruct p.
  destruct b0; tryfalse.
  destruct p0.
  destruct b0; tryfalse.
  rename m into b0.
  rename m0 into b1.
  remember (freeb m1 b (i + 1) n) as m1''.
  remember (freeb m2 b (i + 1) n) as m2''.
  destruct m1'',m2'';tryfalse.
  injection H0; intros; subst.
  injection H1; intros; subst.

  assert (join m M m0).
  eapply IHn;eauto.
  assert (get m2 (b,i) = Some (true, b0)).
  eapply mem_join_get_get_l_true;eauto.
  assert (b1 = b0).
  rewrite H3 in Heqv2.
  injection Heqv2.
  intros;auto.

  subst b1.
  symmetry in Heqv1, Heqm1''.
  assert(get m (b,i) = get m1 (b,i)).
  eapply freeb_get_same; eauto.
  omega.
  rewrite Heqv1 in H4.

  eapply mem_join_del; eauto.
Qed.

Lemma join_free :
  forall m1 M m2 m1' m2' t b, join m1 M m2 ->
    free t b m1 = Some m1' ->
    free t b m2 = Some m2' ->
    join m1' M m2'.
Proof.
  intros.
  unfold free in H0,H1.
  eapply join_freeb;eauto.
Qed.

Lemma join_storebytes :
  forall m1 M m2 m1' m2' b o vl,
    join m1 M m2 ->
    storebytes m1 (b, o) vl = Some m1' ->
    storebytes m2 (b, o) vl = Some m2' ->
    join m1' M m2'.
Proof.
  intros.
  gen m1 M m2 m1' m2' o.
  induction vl.
  intros.
  simpl in H0,H1.
  injection H0;intros;subst.
  injection H1;intros;subst.
  auto.
  intros.
  simpl in H0,H1.

  unfold get in *; simpl in *.
  remember (HalfPermMap.get m1 (b, o)) as v1.
  remember (HalfPermMap.get m2 (b, o)) as v2.
  destruct v1,v2;tryfalse.
  destruct b0, b1.
  destruct b0, b1; tryfalse.
  remember (storebytes m1 (b, (o + 1)%Z) vl) as m1''.
  remember (storebytes m2 (b, (o + 1)%Z) vl) as m2''.
  destruct m1'',m2'';tryfalse.
  injection H0;intros;subst.
  injection H1;intros;subst.

  symmetry in Heqv1, Heqm1''.
  assert (get m (b,o) = get m1 (b,o)).
  erewrite storebytes_get_same with (off:=1); eauto.
  omega.

  eapply mem_join_set_true_join; eauto.
  unfold get in *; simpl in *.
  rewrite Heqv1 in H2.
  eauto.
Qed.

Lemma join_store :
  forall m1 M m2 m1' m2' t a v,
    join m1 M m2 ->
    store t m1 a v = Some m1' ->
    store t m2 a v = Some m2' ->
    join m1' M m2'.
Proof.
  intros.
  unfold store in H0,H1.
  destruct a.
  destruct (encode_val t v);tryfalse.
  eapply join_storebytes;eauto.
  eapply join_storebytes;eauto.
Qed.

Lemma join_allocb_emp :
  forall M b i n,
    fresh M b ->
    join M (allocb emp b i n) (allocb M b i n).
Proof.
  intros.
  gen i.
  induction n.
  intros.
  simpl.
  apply join_comm.
  eapply join_emp;eauto.
  intros.
  simpl.
  lets IHni : IHn (i+1).
  eapply join_set_nindom_r;eauto.
  red. intros.
  apply indom_get in H0.
  destruct H0.
  rewrite allocb_get_none in H0.
  false.
  omega.
  auto.
Qed.

Lemma join_allocb' :
  forall M1 M2 M b i n,
    join M2 M (allocb M2 b i n)  ->
    fresh M2 b ->
    fresh M1 b ->
    join M1 M (allocb M1 b i n).
Proof.
  intros.
  eapply join_unique_r in H.
  2:eapply join_allocb_emp;eauto.
  rewrite<-H.
  eapply join_allocb_emp;eauto.
Qed.

Lemma join_store_allocb :
  forall M1 M2 M M'' M1' M2' b t v,
    join M1 M M2 ->
    join M2 M'' M2' ->
    fresh M2 b ->
    store t (allocb M1 b 0 (typelen t)) (b, 0%Z) v = Some M1' ->
    store t (allocb M2 b 0 (typelen t)) (b, 0%Z) v = Some M2' ->
    join M1 M'' M1'.
Proof.
  intros.
  lets Hs: join_store H2 H3.
  eapply join_allocb;auto.
  apply H.

  assert(join (merge M1 M'') M M2').
  eapply mem_join_join_merge13_join; eauto.
  apply join_comm in Hs; apply join_comm in H4.
  lets Hx: join_unique_r Hs H4; substs.
  eapply mem_join_join_merge; eauto.
Qed.

(* fresh *)
Lemma fresh_mono :
  forall m1 M m2 b, join m1 M m2 ->
    fresh m2 b -> fresh m1 b.
Proof.
  unfold fresh.
  intros.
  apply H0 in H1.
  intro.
  apply H1.
  unfolds.
  unfold indom in H2; destruct H2.
  destruct x.
  lets Hx: mem_join_get_get_l H2; eauto.
  destruct Hx.
  eauto.
Qed.

Lemma fresh_exist : forall m, (exists b,fresh m b).
Proof.
  intros.
  generalize MemoryNotFull.
  intros.
  generalize (H m).
  intros.
  unfold FullMemory in H0.
  apply not_all_ex_not in H0.
  destruct H0. exists x.
  unfold fresh.
  intros.
  red. intros. apply H0.
  exists i. subst. eauto.
Qed.

(* memory update *)
Lemma alloc_false : forall x t le M M', ~alloc x t le M le M'.
Proof.
  intros.
  red.
  intros.
  unfold alloc in H.
  destruct H.
  destruct H.
  destruct H0.
  destruct H1.
  apply H1.
  apply EnvMod.get_indom.
  rewrite H2.
  rewrite EnvMod.set_a_get_a;eauto.
  eapply identspec.eq_beq_true;eauto.
Qed.

Lemma free_false : forall t b M,(typelen t <> 0)%nat -> ~free t b M = Some M.
Proof.
  intros.
  remember (typelen t) as tlen.
  red.
  intros.
  destruct tlen.
  apply  H.
  auto.
  unfold free in H0.
  rewrite<-Heqtlen in H0.
  simpl in H0.
  remember (get M (b, BinNums.Z0)) as v.
  destruct v;tryfalse.
  remember (freeb M b 1 tlen) as M'.
  destruct p.
  destruct b0; tryfalse.
  destruct M';tryfalse.
  injection H0;intros.
  subst M.

  rewrite mem_del_get in Heqv; tryfalse.
Qed.

Lemma storebytes_mono' :
  forall M1 M1' M M2 M2' a l,
    storebytes M1 a l = Some M1' ->
    join M1 M M2 ->
    join M1' M M2' ->
    storebytes M2 a l = Some M2'.
Proof.
  intros.
  gen H H0 H1.
  gen M1 M1' M M2 M2' a.
  induction l; intros; simpl in *.

  inv H.
  lets H100 : join_unique H1 H0.
  rewrite H100; auto.

  destruct a0.
  unfold get in H; simpl in H.
  remember (HalfPermMap.get M1 (b, o)) as v1; destruct v1.
  2 : tryfalse.
  destruct b0.
  destruct b0; tryfalse.
  symmetry in Heqv1.
  lets H100 : mem_join_get_get_l_true H0 Heqv1.
  rewrite H100; clear H100.
  clear Heqv1.
  remember (storebytes M1 (b, o + 1) l) as v2; destruct v2.
  2 : tryfalse.
  symmetry in Heqv2.
  inversion H; clear H.

  cut (exists m', join m M m' /\ set m' (b, o) (true, a) = M2'); intros.
  do 2 destruct H.
  eapply IHl in Heqv2; eauto.
  rewrite Heqv2.
  unfold set in *; simpl in *.
  rewrite H2; auto.

  gen H1 H3; clear; intros.
  rewrite <- H3 in H1; clear H3.
  lets H100 : mem_join_set_l_rev H1.
  auto.
  destruct H100; eexists; intuition eauto.
Qed.

Lemma store_mono' :
  forall t M1 M1' M M2 M2' a v,
    store t M1 a v = Some M1' ->
    join M1 M M2 ->
    join M1' M M2' ->
    store t M2 a v = Some M2'.
Proof.
  intros.
  unfold store in *.
  destruct a.

  destruct v; simpl in *.

  eapply storebytes_mono'; eauto.
  eapply storebytes_mono'; eauto.

  destruct t; eapply storebytes_mono'; eauto.
  destruct a; destruct t; eapply storebytes_mono'; eauto.
Qed.

Lemma store_same_mono :
  forall t M M1 M2 a v,
    join M M1 M2 ->
    store t M a v = Some M ->
    store t M2 a v = Some M2.
Proof.
  intros; eapply store_mono'; eauto.
Qed.

Lemma join_storebytes_storebytes : forall vl b i M1 M1' M2 M,
                                     join M1 M2 M ->
                                     storebytes M1 (b, i) vl = Some M1' ->
                                     exists M', storebytes M (b, i) vl = Some M'.
Proof.
  inductions vl; intros.
  simpl; eauto.
  simpl in H0.
  unfold get in H0; simpl in H0.
  destruct (HalfPermMap.get M1 (b, i)) eqn : eq1; tryfalse.
  destruct b0.
  destruct b0; tryfalse.
  destruct (storebytes M1 (b, (i + 1)%Z) vl) eqn : eq2; tryfalse.
  simpl.
  assert (get M (b, i) = Some (true, c)).
  eapply mem_join_get_get_l_true; eauto.
  unfold get in *; simpl in *.
  rewrite H1.
  pose proof IHvl b (i + 1)%Z M1 m M2 M H eq2; clear IHvl.
  destruct H2.
  change offset with Z in H2.
  rewrite H2.
  eauto.
Qed.

Lemma join_store_general : forall Mc Mc' Ml M tp l v,
                             join Ml Mc M ->
                             store tp Mc l v = Some Mc' ->
                             exists M', store tp M l v = Some M'.
Proof.
  intros.
  unfold store in H0.
  destruct l.
  unfold store.
  apply join_comm in H.
  eapply join_storebytes_storebytes; eauto.
Qed.

Lemma join_store':forall Mc Mc' Ml M tp b t,
                   join Ml Mc M ->
                   store tp Mc (b,0%Z) (Vptr t) = Some Mc' ->
                   exists M',
                     store tp M (b,0%Z) (Vptr t) = Some M'.
Proof.
  intros.
  unfold store in H0.
  eapply join_store_general; eauto.
Qed.

Lemma join_store_join:
  forall Ml Mc M t l v Mc' M',
    join Ml Mc M ->
    store t Mc l v = Some Mc' ->
    store t M l v = Some M' ->
    join Ml Mc' M'.
Proof.
  unfold store.
  destruct l.
  intro.
  gen Ml Mc M b o.
  induction (encode_val t v); intros.
  simpl in H0; simpl in H1; inv H0; inv H1; auto.

  simpl in H0.
  unfold get in H0; simpl in H0.
  destruct (HalfPermMap.get Mc (b, o)) eqn : eq1; tryfalse.
  destruct b0.
  destruct b0; tryfalse.
  destruct (storebytes Mc (b, (o + 1)%Z) l) eqn : eq2; tryfalse.
  simpl in H1.
  unfold get in H1; simpl in H1.
  destruct (HalfPermMap.get M (b, o)) eqn : eq3; tryfalse.
  destruct b0.
  destruct b0; tryfalse.
  destruct (storebytes M (b, (o + 1)%Z) l) eqn : eq4; tryfalse.
  pose proof IHl Ml Mc M b (o+1)%Z m m0 H eq2 eq4; clear IHl.

  inv H0.
  inv H1.
  apply join_comm.
  apply join_comm in H2.
  eapply mem_join_set_true_join; auto.
  lets Hx: storebytes_get_same eq2.
  omega.
  unfold get in *; simpl in *.
  change ((fun x => (HalfPermMap.get m (b, o) = x))(HalfPermMap.get Mc (b, o))) in Hx.
  rewrite eq1 in Hx.
  eauto.
Qed.

Lemma disj_storebytes_disj : forall vl M1 M2 M1' b o, disjoint M1 M2 -> storebytes M1 (b, o) vl = Some M1' -> disjoint M1' M2.
Proof.
  inductions vl; intros.
  simpl in H0.
  inv H0; auto.

  simpl in H0.
  unfold get in H0; simpl in H0.
  destruct (HalfPermMap.get M1 (b, o)) eqn : eq1; tryfalse.
  destruct b0.
  destruct b0; tryfalse.
  destruct (storebytes M1 (b, (o + 1)%Z) vl) eqn : eq2; tryfalse.
  pose proof IHvl M1 M2 m b (o+1)%Z H eq2; clear IHvl.
  inv H0.

  assert (get m (b, o) = get M1 (b,o)).
  erewrite storebytes_get_same; eauto.
  omega.
  eapply mem_disjoint_set_l; eauto.
  unfold get in *; simpl in *.
  rewrite eq1 in H0; eauto.
Qed.

Lemma disj_store_disj:forall M1 M2 M1' t l v ,disjoint M1 M2 -> store t M1 l v = Some M1' -> disjoint M1' M2.
Proof.
  intros.
  unfold store in H0.
  destruct l.
  eapply disj_storebytes_disj; eauto.
Qed.

Lemma merge_store_merge:
  forall M1 M2 m t l v M1' m',
    merge M1 M2 = m ->
    store t M1 l v = Some M1' ->
    store t m l v  = Some m' ->
    merge M1' M2 = m'.
Proof.
  unfold store.
  destruct l.
  intros.
  gen m M1 M2 b o M1' m' H H0 H1.
  induction (encode_val t v); intros.
  simpl in H0.
  simpl in H1.
  inv H0.
  inv H1.
  auto.
  simpl in H0.
  unfold get in H0; simpl in H0.
  destruct (HalfPermMap.get M1 (b, o)) eqn : eq1; tryfalse.
  destruct b0.
  destruct b0; tryfalse.
  destruct (storebytes M1 (b, (o + 1)%Z) l) eqn : eq2; tryfalse.
  simpl in H1.
  unfold get in H1; simpl in H1.
  destruct (HalfPermMap.get m (b, o)) eqn : eq3; tryfalse.
  destruct b0.
  destruct b0; tryfalse.
  destruct (storebytes m (b, (o + 1)%Z) l) eqn : eq4; tryfalse.
  pose proof IHl m M1 M2 b (o+1)%Z m0 m1 H eq2 eq4; clear IHl.
  inv H0.
  inv H1.

  eapply mem_get_set_merge_eq; eauto.
  lets Hx: storebytes_get_same eq2; eauto.
  omega.
  unfold get in *; simpl in *.
  instantiate (1:=c).
  change ((fun x =>(x = Some (true, c)))(HalfPermMap.get m0 (b, o))).
  rewrite Hx.
  auto.
Qed.

Lemma mem_set_a_set_a : forall (M:mem) a val1 val2, set (set M a val1) a val2 = set M a val2.
Proof.
  intros.
  eapply extensionality.
  intro.
  pose proof addr_eq_dec a a0.
  destruct H as [eq1 | eq1].
  substs.
  rewrite set_a_get_a.
  rewrite set_a_get_a.
  auto.

  rewrite set_a_get_a'.
  rewrite set_a_get_a'.
  rewrite set_a_get_a'.
  auto.
  auto.
  auto.
  auto.
Qed.

Lemma mem_set_a_set_a' : forall (M:mem) a v a' v', a <> a' ->
                                             set (set M a v) a' v' = set (set M a' v') a v.
Proof.
  intros.
  eapply extensionality.
  intro.
  pose proof addr_eq_dec a a0 as eq1; destruct eq1 as [eq1|eq1];
    pose proof addr_eq_dec a' a0 as eq2; destruct eq2 as [eq2|eq2].
  subst.
  tryfalse.

  rewrite set_a_get_a'.
  substs.
  rewrite set_a_get_a.
  rewrite set_a_get_a.
  auto.
  auto.
  auto.
  auto.
  substs.
  rewrite set_a_get_a.
  rewrite set_a_get_a'.
  rewrite set_a_get_a.
  auto.
  auto.
  rewrite set_a_get_a'.
  rewrite set_a_get_a'.
  rewrite set_a_get_a'.
  rewrite set_a_get_a'.
  auto.
  auto.
  auto.
  auto.
  auto.
Qed.

Lemma storebytes_set : forall l M M' b o o' a, storebytes M (b, o) l = Some M' -> (o' < o)%Z -> storebytes (set M (b, o') a) (b, o) l = Some (set M' (b, o') a).
Proof.
  inductions l; intros.
  simpl in H; simpl; inv H; auto.
  simpl in H.
  destruct (get M (b, o)) eqn : eq1; tryfalse.
  destruct (storebytes M (b, (o + 1)%Z) l) eqn : eq2; tryfalse.
  assert (o'<o+1)%Z.
  omega.
  pose proof IHl M m b (o+1)%Z o' a0 eq2 H1; clear IHl.
  simpl.
  rewrite set_a_get_a'.
  unfold get;simpl.
  unfold get in eq1;simpl in eq1.
  rewrite eq1.
  destruct p.
  change offset with Z in H2.
  rewrite H2.
  inv H.
  unfold get in H4;simpl in H4.
  rewrite eq1 in H4.
  destruct b0;auto.
  inverts H4.
  rewrite mem_set_a_set_a'.
  auto.
  intro.
  inversion H.
  assert (o' <> o).
  clear eq1 eq2 H1 H2 H H4; clears.
  omega.
  apply H3 in H4.
  false.
  tryfalse.
  intro.
  inversion H3.
  assert (o' <> o).
  omega.
  apply H4 in H5.
  false.
  unfold get in *;simpl in *.
  rewrite eq1 in H.
  destruct p.
  destruct b0;tryfalse.
  unfold get in *;simpl in *.
  rewrite eq1 in H.
  tryfalse.
Qed.

Lemma mem_disj_merge_minus_disj'
     : forall Ml Mc' Ms Ms' Mc'0 Mcc tp l v ,
       store tp Mc' l v = Some Mcc ->
       disjoint Mc'0 Ms' ->
       merge Mc'0 Ms' = merge Mcc Ms ->
       disjoint Ml Ms ->
       Maps.sub Mc' Ml ->
       disjoint (merge (minus Ml Mc') Mc'0) Ms'.
Proof.
  unfold store.
  destruct l.
  intro.
  gen Ml Mc' Ms Ms' Mc'0 Mcc b o.
  induction (encode_val tp v); intros.
  simpl in H.
  inv H.

  eapply memory_prop_map1; eauto.

  (* eapply disj_merge_intro_l. *)
  (* split; auto. *)

  (* assert(disjoint (minus Ml Mcc) (merge Mcc Ms)). *)
  (* Check mem_disjoint_disjoint_sub_disjoint_merge. *)
  (* eapply mem_disjoint_disjoint_sub_disjoint_merge; eauto. *)

  (* rewrite <- H1 in H. *)
  (* eapply mem_disjoint_disjoint_merge_disjoint; eauto. *)

  simpl in H.
  unfold get in H; simpl in H.
  destruct (HalfPermMap.get Mc' (b, o)) eqn : e1; tryfalse.
  destruct b0.
  destruct b0; tryfalse.
  destruct (storebytes Mc' (b, (o + 1)%Z) l) eqn : e2; tryfalse.
  assert (storebytes (set Mc' (b, o) (true, a)) (b, (o + 1)%Z) l = Some Mcc).
  clear IHl e1 H0 H1 H2 H3; clears.
  inv H.
  apply storebytes_set; auto.
  omega.

  assert (Maps.sub (set Mc' (b, o) (true, a)) (set Ml (b, o) (true,a))).
  clear IHl e2 H H0 H1 H2 H4; clears.
  eapply mem_sub_get_true_sub_set; eauto.
  assert (disjoint (set Ml (b, o) (true, a)) Ms).
  clear IHl e2 H H1 H4 H5; clears.
  eapply mem_disjoint_get_true_set_disjoint; eauto.

  eapply memory_prop_get_sub_get; eauto.

  pose proof IHl (set Ml (b, o) (true, a)) (set Mc' (b, o) (true,a)) Ms Ms' Mc'0 Mcc b (o+1)%Z H4 H0 H1 H6 H5.

  eapply mem_disjoint_merge_minus_get_true_set; eauto.
Qed.

Lemma mem_disj_merge_minus_merge'
     : forall Ml Mc Ms Ms' Mc' m Mcc m' v l tp,
         store tp Mc l v = Some Mcc ->
         store tp m l v= Some m' ->
         disjoint Mc' Ms' ->
         merge Mc' Ms' = merge Mcc Ms ->
         disjoint Ml Ms ->
         Maps.sub Mc Ml ->
         merge Ml Ms =m ->
         merge (merge (minus Ml Mc) Mc') Ms' = m'.
Proof.
  intros.
  unfold store in *.
  destruct l.
  gen Ml Mc Ms Ms' Mc' m Mcc m' b o.
  induction (encode_val tp v); intros.
  simpl in H; simpl in H0.
  inv H; inv H0.

  lets Hx: mem_disjoint_merge_eq_merge_merge H2; eauto.
  eapply mem_sub_disjoint; eauto.
  instantiate (TEMP3:=(minus Ml Mcc)).
  assert(disjoint (minus Ml Mcc) (merge Mcc Ms)).
  eapply mem_disjoint_sub_disjoint_merge; eauto.
  apply Hx in H.
  rewrite H.
  eapply mem_merge_merge_minus_merge; eauto.

  simpl in H.
  unfold get in H; simpl in H.
  destruct (HalfPermMap.get Mc (b, o)) eqn : eq1; tryfalse.
  destruct b0.
  destruct b0; tryfalse.
  destruct (storebytes Mc (b, (o + 1)%Z) l) eqn : eq2; tryfalse.
  simpl in H0.
  unfold get in H0; simpl in H0.
  destruct (HalfPermMap.get m (b, o)) eqn : eq3; tryfalse.
  destruct b0.
  destruct b0; tryfalse.
  destruct (storebytes m (b, (o + 1)%Z) l) eqn : eq4; tryfalse.
  pose proof IHl (set Ml (b, o) (true, a)) (set Mc (b, o) (true, a)); clear IHl.
  assert (Maps.sub (set Mc (b, o) (true, a)) (set Ml (b, o) (true, a))).
  clear H6 H3 H1 H5 H2 eq2 H eq3 eq4 H0; clears.
  eapply mem_sub_get_true_sub_set; eauto.

  pose proof H6 H7; clear H6 H7.
  assert (disjoint (set Ml (b, o) (true, a)) Ms).
  clear H1 H5 H2 eq2 H eq3 eq4 H0 H8; clears.
  eapply mem_disjoint_get_true_set_disjoint; eauto.
  eapply memory_prop_get_sub_get; eauto.

  pose proof H8 Ms H6; clear H6 H8.
  pose proof H7 Ms' Mc' H1; clear H7.
  assert (merge (set Ml (b, o) (true, a)) Ms = (set m (b, o) (true, a))).
  clear H3 H1 H2 eq2 eq3 eq4 H0 H6 H; clears.
  inv H5.
  eapply mem_get_set_merge_eq; eauto.
  eapply memory_prop_get_sub_get; eauto.

  pose proof H6 (set m (b, o) (true, a)) H7; clear H6 H7.
  pose proof H8 Mcc H2; clear H8.
  pose proof H6 m' b (o+1)%Z; clear H6.
  assert (storebytes (set Mc (b, o) (true, a)) (b, (o + 1)%Z) l = Some Mcc).
  inversion H.
  apply storebytes_set; auto.
  omega.

  assert (storebytes (set m (b, o) (true, a)) (b, (o + 1)%Z) l = Some m').
  inversion H0.
  apply storebytes_set; auto.
  omega.

  pose proof H7 H6 H8; clear H7 H6 H8.

  eapply mem_merge_merge_minus_get_true_set_eq; eauto.
Qed.

Lemma store_sub_minus_eq:forall Ml M Ml' tp l v, Maps.sub Ml M -> store tp Ml l v = Some Ml' -> minus M Ml = minus M Ml'.
Proof.
  intros.
  unfold store in H0.
  destruct l.
  gen Ml M Ml' b o.
  induction (encode_val tp v); intros.
  simpl in H0; simpl; inv H0; auto.

  simpl in H0.
  unfold get in H0; simpl in H0.
  destruct (HalfPermMap.get Ml (b, o)) eqn : eq1; tryfalse.
  destruct b0.
  destruct b0; tryfalse.
  destruct (storebytes Ml (b, (o + 1)%Z) l) eqn : eq2; tryfalse.

  assert (Maps.sub (set Ml (b, o) (true, a)) (set M (b, o) (true, a))).

  eapply mem_sub_get_true_set_sub; eauto.

  pose proof IHl (set Ml (b, o) (true, a)) (set M (b, o) (true, a)) H1; clear IHl.
  assert (storebytes (set Ml (b, o) (true,a)) (b, (o+1)%Z) l = Some Ml').
  inversion H0.
  apply storebytes_set; auto.
  omega.

  pose proof H2 Ml' b (o+1)%Z H3; clear H2.
  clear eq2 H3; clears.
  inverts H0.

  Lemma memory_prop_map2:
    forall (A B T : Type) (MC : PermMap A B T) m Ml M a b c,
      usePerm = true ->
      Maps.sub Ml M ->
      isRw c = true ->
      get Ml a = Some c ->
      isRw b = true ->
      minus (set M a b) (set Ml a b) =
      minus (set M a b) (set m a b) ->
      minus M Ml = minus M (set m a b).
    intros.
    Ltac infer ::= infer'.
    hy_eql (pnil, Ml, M, Maps.sub Ml M,
            set M a b, set Ml a b,
            minus (set M a b) (set Ml a b),
            m, set m a b,
            minus (set M a b) (set m a b),
            minus M Ml, minus M (set m a b)) t;
    crush.
    Ltac infer ::= infer_q.
    generalize (@map_flip_eql' _ _ _ _ _ _ H H19); intro.
    subst b0.
    auto.
  Qed.

  eapply memory_prop_map2; ica.
Qed.
  (* assert (forall a0, get ( minus (set M (b, o) (true, a)) (set Ml (b, o) (true, a))) a0 = get (minus (set M (b, o) (true, a)) Ml') a0). *)
  (* rewrite H4; auto. *)
  (* clear H4. *)
  (* eapply extensionality. *)
  (* intro. *)
  (* pose proof H0 a0; clear H0.  *)

  (* eapply memory_prop_map2; eauto. *)
  (* unfold isRw; simpl; auto. *)
  (* unfold isRw; simpl; auto. *)
  (* rewrite minus_sem. *)
  (* rewrite minus_sem. *)
  (* rewrite minus_sem in H1. *)
  (* rewrite minus_sem in H1. *)
  (* assert ((b, o) = a0 \/ (b,o) <> a0) as Hxx by tauto. *)
  (* destruct Hxx. *)
  (* substs. *)
  (* rewrite set_a_get_a in H1. *)
  (* rewrite set_a_get_a in H1. *)
  (* unfold get in *; simpl in *. *)
  (* rewrite eq1. *)
  (* destruct (HalfPermMap.get Ml' (b, o)) eqn : eq2; tryfalse. *)
  (* auto. *)

  (* rewrite set_a_get_a' in H1; auto. *)
  (* rewrite set_a_get_a' in H1; auto. *)

Lemma store_disj_merge:forall M M1 Ms M2 tp l v, disjoint M (merge M1 Ms) -> store tp M1 l v = Some M2 -> disjoint M (merge M2 Ms).
Proof.
  intros.
  unfold store in H0.
  destruct l.
  gen M M1 Ms M2 b o.
  induction (encode_val tp v); intros.
  simpl in H0; inv H0; auto.

  simpl in H0.
  unfold get in *; simpl in *.
  destruct (HalfPermMap.get M1 (b, o) ) eqn : eq1; tryfalse.
  destruct b0.
  destruct b0; tryfalse.
  destruct (storebytes M1 (b, (o + 1)%Z) l) eqn : eq2; tryfalse.
  pose proof IHl M M1 Ms H m b (o+1)%Z eq2; clear IHl.
  inv H0.

  assert(get m (b, o) = get M1 (b, o)).
  eapply storebytes_get_same; eauto.
  omega.
  unfold get in *; simpl in *.
  rewrite eq1 in H0.

  erewrite mem_get_set_merge_eq; eauto.
  apply disjoint_sym.
  apply disjoint_sym in H1.
  eapply mem_disjoint_get_true_set_disjoint; eauto.
  instantiate (1:=c).

  eapply memory_prop_map3; eauto.
Qed.

Lemma store_sub_disj_disj:
  forall M1 M2 Ms Ml M2' tp l v,
    store tp M2 l v = Some M2' ->
    disjoint Ml Ms ->
    Maps.sub M2 Ml ->
    Maps.sub M1 (merge M2' Ms) ->
    disjoint (minus Ml M2') M1.
Proof.
  intros.
  assert (disjoint (minus Ml M2) (merge M2 Ms)).
  eapply mem_disjoint_disjoint_sub_disjoint_merge; auto.
  assert (disjoint (minus Ml M2) (merge M2' Ms)).
  eapply store_disj_merge;  eauto.
  lets Hx: store_sub_minus_eq H1 H.
  rewrite Hx in H4.
  clear - H2 H4.
  apply disjoint_sym.
  apply disjoint_sym in H4.
  eapply mem_sub_disjoint; eauto.
Qed.

Lemma mem_join_merge_minus_join_store'
(*can be derived by lemma " mem_disj_merge_minus_disj' " and  "mem_disj_merge_minus_merge'"*)
: forall Ml Mc Ms Ms' Mc' m Mcc m' v l tp,
    store tp Mc l v = Some Mcc ->
    store tp m l v= Some m' ->
    disjoint Mc' Ms' ->
    merge Mc' Ms' = merge Mcc Ms ->
    Maps.sub Mc Ml ->
    join Ml Ms m ->
    join (merge (minus Ml Mc) Mc') Ms' m'.
Proof.
  intros.
  lets Hx1: mem_disj_merge_minus_disj' H H1 H2 H3.
  eapply my_join_disj; eauto.
  lets Hx2: mem_disj_merge_minus_merge' H H0 H1 H2 H3.
  eapply my_join_disj; eauto.
  assert (merge Ml Ms = m).
  eapply mem_join_disjoint_eq_merge in H4; simpljoin.
  unfold merge in *; simpl in *.
  change ((fun x => (x ->
                     HalfPermMap.merge (HalfPermMap.merge (minus Ml Mc) Mc') Ms' = m'))(HalfPermMap.merge Ml Ms = m)) in Hx2.
  rewrite H5 in Hx2.
  assert (m=m) by auto.
  apply Hx2 in H6.
  rewrite <- H6.

  eapply join_merge_disj; eauto.
Qed.

Close Scope Z_scope.


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

(*i Due to L.Thery i*)

(************************************************************)
(* Definitions of log and Rpower : R->R->R; main properties *)
(************************************************************)

Require Import Rbase.
Require Import Rfunctions.
Require Import SeqSeries.
Require Import Rtrigo1.
Require Import Ranalysis1.
Require Import Exp_prop.
Require Import Rsqrt_def.
Require Import R_sqrt.
Require Import Sqrt_reg.
Require Import MVT.
Require Import Ranalysis4.
Require Import Fourier.
Local Open Scope R_scope.

Lemma P_Rmin : forall (P:R -> Prop) (x y:R), P x -> P y -> P (Rmin x y).
Proof.
  intros P x y H1 H2; unfold Rmin; case (Rle_dec x y); intro;
    assumption.
Qed.

Lemma exp_le_3 : exp 1 <= 3.
Proof.
  assert (exp_1 : exp 1 <> 0).
  assert (H0 := exp_pos 1); red; intro; rewrite H in H0;
    elim (Rlt_irrefl _ H0).
  apply Rmult_le_reg_l with (/ exp 1).
  apply Rinv_0_lt_compat; apply exp_pos.
  rewrite <- Rinv_l_sym.
  apply Rmult_le_reg_l with (/ 3).
  apply Rinv_0_lt_compat; prove_sup0.
  rewrite Rmult_1_r; rewrite <- (Rmult_comm 3); rewrite <- Rmult_assoc;
    rewrite <- Rinv_l_sym.
  rewrite Rmult_1_l; replace (/ exp 1) with (exp (-1)).
  unfold exp; case (exist_exp (-1)) as (?,e); simpl in |- *;
    unfold exp_in in e;
      assert (H := alternated_series_ineq (fun i:nat => / INR (fact i)) x 1).
  cut
    (sum_f_R0 (tg_alt (fun i:nat => / INR (fact i))) (S (2 * 1)) <= x <=
      sum_f_R0 (tg_alt (fun i:nat => / INR (fact i))) (2 * 1)).
  intro; elim H0; clear H0; intros H0 _; simpl in H0; unfold tg_alt in H0;
    simpl in H0.
  replace (/ 3) with
  (1 * / 1 + -1 * 1 * / 1 + -1 * (-1 * 1) * / 2 +
    -1 * (-1 * (-1 * 1)) * / (2 + 1 + 1 + 1 + 1)) by field.
  apply H0.
  apply H.
  unfold Un_decreasing; intros;
    apply Rmult_le_reg_l with (INR (fact n)).
  apply INR_fact_lt_0.
  apply Rmult_le_reg_l with (INR (fact (S n))).
  apply INR_fact_lt_0.
  rewrite <- Rinv_r_sym.
  rewrite Rmult_1_r; rewrite Rmult_comm; rewrite Rmult_assoc;
    rewrite <- Rinv_l_sym.
  rewrite Rmult_1_r; apply le_INR; apply fact_le; apply le_n_Sn.
  apply INR_fact_neq_0.
  apply INR_fact_neq_0.
  assert (H0 := cv_speed_pow_fact 1); unfold Un_cv; unfold Un_cv in H0;
    intros; elim (H0 _ H1); intros; exists x0; intros;
      unfold R_dist in H2; unfold R_dist;
        replace (/ INR (fact n)) with (1 ^ n / INR (fact n)).
  apply (H2 _ H3).
  unfold Rdiv; rewrite pow1; rewrite Rmult_1_l; reflexivity.
  unfold infinite_sum in e; unfold Un_cv, tg_alt; intros; elim (e _ H0);
    intros; exists x0; intros;
      replace (sum_f_R0 (fun i:nat => (-1) ^ i * / INR (fact i)) n) with
      (sum_f_R0 (fun i:nat => / INR (fact i) * (-1) ^ i) n).
  apply (H1 _ H2).
  apply sum_eq; intros; apply Rmult_comm.
  apply Rmult_eq_reg_l with (exp 1).
  rewrite <- exp_plus; rewrite Rplus_opp_r; rewrite exp_0;
    rewrite <- Rinv_r_sym.
  reflexivity.
  assumption.
  assumption.
  discrR.
  assumption.
Qed.

(******************************************************************)
(** *                     Properties of  Exp                      *)
(******************************************************************)

Theorem exp_increasing : forall x y:R, x < y -> exp x < exp y.
Proof.
  intros x y H.
  assert (H0 : derivable exp).
  apply derivable_exp.
  assert (H1 := positive_derivative _ H0).
  unfold strict_increasing in H1.
  apply H1.
  intro.
  replace (derive_pt exp x0 (H0 x0)) with (exp x0).
  apply exp_pos.
  symmetry ; apply derive_pt_eq_0.
  apply (derivable_pt_lim_exp x0).
  apply H.
Qed.

Theorem exp_lt_inv : forall x y:R, exp x < exp y -> x < y.
Proof.
  intros x y H; case (Rtotal_order x y); [ intros H1 | intros [H1| H1] ].
  assumption.
  rewrite H1 in H; elim (Rlt_irrefl _ H).
  assert (H2 := exp_increasing _ _ H1).
  elim (Rlt_irrefl _ (Rlt_trans _ _ _ H H2)).
Qed.

Lemma exp_ineq1 : forall x:R, 0 < x -> 1 + x < exp x.
Proof.
  intros; apply Rplus_lt_reg_l with (- exp 0); rewrite <- (Rplus_comm (exp x));
    assert (H0 := MVT_cor1 exp 0 x derivable_exp H); elim H0;
      intros; elim H1; intros; unfold Rminus in H2; rewrite H2;
        rewrite Ropp_0; rewrite Rplus_0_r;
          replace (derive_pt exp x0 (derivable_exp x0)) with (exp x0).
  rewrite exp_0; rewrite <- Rplus_assoc; rewrite Rplus_opp_l; rewrite Rplus_0_l;
    pattern x at 1; rewrite <- Rmult_1_r; rewrite (Rmult_comm (exp x0));
      apply Rmult_lt_compat_l.
  apply H.
  rewrite <- exp_0; apply exp_increasing; elim H3; intros; assumption.
  symmetry ; apply derive_pt_eq_0; apply derivable_pt_lim_exp.
Qed.

Lemma ln_exists1 : forall y:R, 1 <= y -> { z:R | y = exp z }.
Proof.
  intros; set (f := fun x:R => exp x - y).
  assert (H0 : 0 < y) by (apply Rlt_le_trans with 1; auto with real).
  cut (f 0 <= 0); [intro H1|].
  cut (continuity f); [intro H2|].
  cut (0 <= f y); [intro H3|].
  cut (f 0 * f y <= 0); [intro H4|].
  pose proof (IVT_cor f 0 y H2 (Rlt_le _ _ H0) H4) as (t,(_,H7));
    exists t; unfold f in H7; apply Rminus_diag_uniq_sym; exact H7.
  pattern 0 at 2; rewrite <- (Rmult_0_r (f y));
    rewrite (Rmult_comm (f 0)); apply Rmult_le_compat_l;
      assumption.
  unfold f; apply Rplus_le_reg_l with y; left;
    apply Rlt_trans with (1 + y).
  rewrite <- (Rplus_comm y); apply Rplus_lt_compat_l; apply Rlt_0_1.
  replace (y + (exp y - y)) with (exp y); [ apply (exp_ineq1 y H0) | ring ].
  unfold f; change (continuity (exp - fct_cte y));
    apply continuity_minus;
      [ apply derivable_continuous; apply derivable_exp
        | apply derivable_continuous; apply derivable_const ].
  unfold f; rewrite exp_0; apply Rplus_le_reg_l with y;
    rewrite Rplus_0_r; replace (y + (1 - y)) with 1; [ apply H | ring ].
Qed.

(**********)
Lemma ln_exists : forall y:R, 0 < y -> { z:R | y = exp z }.
Proof.
  intros; destruct (Rle_dec 1 y) as [Hle|Hnle].
  apply (ln_exists1 _ Hle).
  assert (H0 : 1 <= / y).
  apply Rmult_le_reg_l with y.
  apply H.
  rewrite <- Rinv_r_sym.
  rewrite Rmult_1_r; left; apply (Rnot_le_lt _ _ Hnle).
  red; intro; rewrite H0 in H; elim (Rlt_irrefl _ H).
  destruct (ln_exists1 _ H0) as (x,p); exists (- x);
    apply Rmult_eq_reg_l with (exp x / y).
  unfold Rdiv; rewrite Rmult_assoc; rewrite <- Rinv_l_sym.
  rewrite Rmult_1_r; rewrite <- (Rmult_comm (/ y)); rewrite Rmult_assoc;
    rewrite <- exp_plus; rewrite Rplus_opp_r; rewrite exp_0;
      rewrite Rmult_1_r; symmetry ; apply p.
  red; intro H3; rewrite H3 in H; elim (Rlt_irrefl _ H).
  unfold Rdiv; apply prod_neq_R0.
  assert (H3 := exp_pos x); red; intro H4; rewrite H4 in H3;
    elim (Rlt_irrefl _ H3).
  apply Rinv_neq_0_compat; red; intro H3; rewrite H3 in H;
    elim (Rlt_irrefl _ H).
Qed.

(* Definition of log R+* -> R *)
Definition Rln (y:posreal) : R :=
  let (a,_) := ln_exists (pos y) (cond_pos y) in a.

(* Extension on R *)
Definition ln (x:R) : R :=
  match Rlt_dec 0 x with
    | left a => Rln (mkposreal x a)
    | right a => 0
  end.

Lemma exp_ln : forall x:R, 0 < x -> exp (ln x) = x.
Proof.
  intros; unfold ln; decide (Rlt_dec 0 x) with H.
  unfold Rln;
    case (ln_exists (mkposreal x H) (cond_pos (mkposreal x H))) as (?,Hex).
  symmetry; apply Hex.
Qed.

Theorem exp_inv : forall x y:R, exp x = exp y -> x = y.
Proof.
  intros x y H; case (Rtotal_order x y); [ intros H1 | intros [H1| H1] ]; auto;
    assert (H2 := exp_increasing _ _ H1); rewrite H in H2;
      elim (Rlt_irrefl _ H2).
Qed.

Theorem exp_Ropp : forall x:R, exp (- x) = / exp x.
Proof.
  intros x; assert (H : exp x <> 0).
  assert (H := exp_pos x); red; intro; rewrite H0 in H;
    elim (Rlt_irrefl _ H).
  apply Rmult_eq_reg_l with (r := exp x).
  rewrite <- exp_plus; rewrite Rplus_opp_r; rewrite exp_0.
  apply Rinv_r_sym.
  apply H.
  apply H.
Qed.

(******************************************************************)
(** *                     Properties of  Ln                       *)
(******************************************************************)

Theorem ln_increasing : forall x y:R, 0 < x -> x < y -> ln x < ln y.
Proof.
  intros x y H H0; apply exp_lt_inv.
  repeat rewrite exp_ln.
  apply H0.
  apply Rlt_trans with x; assumption.
  apply H.
Qed.

Theorem ln_exp : forall x:R, ln (exp x) = x.
Proof.
  intros x; apply exp_inv.
  apply exp_ln.
  apply exp_pos.
Qed.

Theorem ln_1 : ln 1 = 0.
Proof.
  rewrite <- exp_0; rewrite ln_exp; reflexivity.
Qed.

Theorem ln_lt_inv : forall x y:R, 0 < x -> 0 < y -> ln x < ln y -> x < y.
Proof.
  intros x y H H0 H1; rewrite <- (exp_ln x); try rewrite <- (exp_ln y).
  apply exp_increasing; apply H1.
  assumption.
  assumption.
Qed.

Theorem ln_inv : forall x y:R, 0 < x -> 0 < y -> ln x = ln y -> x = y.
Proof.
  intros x y H H0 H'0; case (Rtotal_order x y); [ intros H1 | intros [H1| H1] ];
    auto.
  assert (H2 := ln_increasing _ _ H H1); rewrite H'0 in H2;
    elim (Rlt_irrefl _ H2).
  assert (H2 := ln_increasing _ _ H0 H1); rewrite H'0 in H2;
    elim (Rlt_irrefl _ H2).
Qed.

Theorem ln_mult : forall x y:R, 0 < x -> 0 < y -> ln (x * y) = ln x + ln y.
Proof.
  intros x y H H0; apply exp_inv.
  rewrite exp_plus.
  repeat rewrite exp_ln.
  reflexivity.
  assumption.
  assumption.
  apply Rmult_lt_0_compat; assumption.
Qed.

Theorem ln_Rinv : forall x:R, 0 < x -> ln (/ x) = - ln x.
Proof.
  intros x H; apply exp_inv; repeat rewrite exp_ln || rewrite exp_Ropp.
  reflexivity.
  assumption.
  apply Rinv_0_lt_compat; assumption.
Qed.

Theorem ln_continue :
  forall y:R, 0 < y -> continue_in ln (fun x:R => 0 < x) y.
Proof.
  intros y H.
  unfold continue_in, limit1_in, limit_in; intros eps Heps.
  cut (1 < exp eps); [ intros H1 | idtac ].
  cut (exp (- eps) < 1); [ intros H2 | idtac ].
  exists (Rmin (y * (exp eps - 1)) (y * (1 - exp (- eps)))); split.
  red; apply P_Rmin.
  apply Rmult_lt_0_compat.
  assumption.
  apply Rplus_lt_reg_l with 1.
  rewrite Rplus_0_r; replace (1 + (exp eps - 1)) with (exp eps);
    [ apply H1 | ring ].
  apply Rmult_lt_0_compat.
  assumption.
  apply Rplus_lt_reg_l with (exp (- eps)).
  rewrite Rplus_0_r; replace (exp (- eps) + (1 - exp (- eps))) with 1;
    [ apply H2 | ring ].
  unfold dist, R_met, R_dist; simpl.
  intros x [[H3 H4] H5].
  cut (y * (x * / y) = x).
  intro Hxyy.
  replace (ln x - ln y) with (ln (x * / y)).
  case (Rtotal_order x y); [ intros Hxy | intros [Hxy| Hxy] ].
  rewrite Rabs_left.
  apply Ropp_lt_cancel; rewrite Ropp_involutive.
  apply exp_lt_inv.
  rewrite exp_ln.
  apply Rmult_lt_reg_l with (r := y).
  apply H.
  rewrite Hxyy.
  apply Ropp_lt_cancel.
  apply Rplus_lt_reg_l with (r := y).
  replace (y + - (y * exp (- eps))) with (y * (1 - exp (- eps)));
  [ idtac | ring ].
  replace (y + - x) with (Rabs (x - y)).
  apply Rlt_le_trans with (1 := H5); apply Rmin_r.
  rewrite Rabs_left; [ ring | idtac ].
  apply (Rlt_minus _ _ Hxy).
  apply Rmult_lt_0_compat; [ apply H3 | apply (Rinv_0_lt_compat _ H) ].
  rewrite <- ln_1.
  apply ln_increasing.
  apply Rmult_lt_0_compat; [ apply H3 | apply (Rinv_0_lt_compat _ H) ].
  apply Rmult_lt_reg_l with (r := y).
  apply H.
  rewrite Hxyy; rewrite Rmult_1_r; apply Hxy.
  rewrite Hxy; rewrite Rinv_r.
  rewrite ln_1; rewrite Rabs_R0; apply Heps.
  red; intro; rewrite H0 in H; elim (Rlt_irrefl _ H).
  rewrite Rabs_right.
  apply exp_lt_inv.
  rewrite exp_ln.
  apply Rmult_lt_reg_l with (r := y).
  apply H.
  rewrite Hxyy.
  apply Rplus_lt_reg_l with (r := - y).
  replace (- y + y * exp eps) with (y * (exp eps - 1)); [ idtac | ring ].
  replace (- y + x) with (Rabs (x - y)).
  apply Rlt_le_trans with (1 := H5); apply Rmin_l.
  rewrite Rabs_right; [ ring | idtac ].
  left; apply (Rgt_minus _ _ Hxy).
  apply Rmult_lt_0_compat; [ apply H3 | apply (Rinv_0_lt_compat _ H) ].
  rewrite <- ln_1.
  apply Rgt_ge; red; apply ln_increasing.
  apply Rlt_0_1.
  apply Rmult_lt_reg_l with (r := y).
  apply H.
  rewrite Hxyy; rewrite Rmult_1_r; apply Hxy.
  rewrite ln_mult.
  rewrite ln_Rinv.
  ring.
  assumption.
  assumption.
  apply Rinv_0_lt_compat; assumption.
  rewrite (Rmult_comm x); rewrite <- Rmult_assoc; rewrite <- Rinv_r_sym.
  ring.
  red; intro; rewrite H0 in H; elim (Rlt_irrefl _ H).
  apply Rmult_lt_reg_l with (exp eps).
  apply exp_pos.
  rewrite <- exp_plus; rewrite Rmult_1_r; rewrite Rplus_opp_r; rewrite exp_0;
    apply H1.
  rewrite <- exp_0.
  apply exp_increasing; apply Heps.
Qed.

(******************************************************************)
(** *                     Definition of  Rpower                   *)
(******************************************************************)

Definition Rpower (x y:R) := exp (y * ln x).

Local Infix "^R" := Rpower (at level 30, right associativity) : R_scope.

(******************************************************************)
(** *                     Properties of  Rpower                   *)
(******************************************************************)

(** Note: [Rpower] is prolongated to [1] on negative real numbers and
    it thus does not extend integer power. The next two lemmas, which
    hold for integer power, accidentally hold on negative real numbers
    as a side effect of the default value taken on negative real
    numbers. Contrastingly, the lemmas that do not hold for the
    integer power of a negative number are stated for [Rpower] on the
    positive numbers only (even if they accidentally hold due to the
    default value of [Rpower] on the negative side, as it is the case
    for [Rpower_O]). *)

Theorem Rpower_plus : forall x y z:R, z ^R (x + y) = z ^R x * z ^R y.
Proof.
  intros x y z; unfold Rpower.
  rewrite Rmult_plus_distr_r; rewrite exp_plus; auto.
Qed.

Theorem Rpower_mult : forall x y z:R, (x ^R y) ^R z = x ^R (y * z).
Proof.
  intros x y z; unfold Rpower.
  rewrite ln_exp.
  replace (z * (y * ln x)) with (y * z * ln x).
  reflexivity.
  ring.
Qed.

Theorem Rpower_O : forall x:R, 0 < x -> x ^R 0 = 1.
Proof.
  intros x _; unfold Rpower.
  rewrite Rmult_0_l; apply exp_0.
Qed.

Theorem Rpower_1 : forall x:R, 0 < x -> x ^R 1 = x.
Proof.
  intros x H; unfold Rpower.
  rewrite Rmult_1_l; apply exp_ln; apply H.
Qed.

Theorem Rpower_pow : forall (n:nat) (x:R), 0 < x -> x ^R INR n = x ^ n.
Proof.
  intros n; elim n; simpl; auto; fold INR.
  intros x H; apply Rpower_O; auto.
  intros n1; case n1.
  intros H x H0; simpl; rewrite Rmult_1_r; apply Rpower_1; auto.
  intros n0 H x H0; rewrite Rpower_plus; rewrite H; try rewrite Rpower_1;
    try apply Rmult_comm || assumption.
Qed.

Theorem Rpower_lt :
  forall x y z:R, 1 < x -> y < z -> x ^R y < x ^R z.
Proof.
  intros x y z H H1.
  unfold Rpower.
  apply exp_increasing.
  apply Rmult_lt_compat_r.
  rewrite <- ln_1; apply ln_increasing.
  apply Rlt_0_1.
  apply H.
  apply H1.
Qed.

Theorem Rpower_sqrt : forall x:R, 0 < x -> x ^R (/ 2) = sqrt x.
Proof.
  intros x H.
  apply ln_inv.
  unfold Rpower; apply exp_pos.
  apply sqrt_lt_R0; apply H.
  apply Rmult_eq_reg_l with (INR 2).
  apply exp_inv.
  fold Rpower.
  cut ((x ^R (/ INR 2)) ^R INR 2 = sqrt x ^R INR 2).
  unfold Rpower; auto.
  rewrite Rpower_mult.
  rewrite Rinv_l.
  change 1 with (INR 1).
  repeat rewrite Rpower_pow; simpl.
  pattern x at 1; rewrite <- (sqrt_sqrt x (Rlt_le _ _ H)).
  ring.
  apply sqrt_lt_R0; apply H.
  apply H.
  apply not_O_INR; discriminate.
  apply not_O_INR; discriminate.
Qed.

Theorem Rpower_Ropp : forall x y:R, x ^R (- y) = / x ^R y.
Proof.
  unfold Rpower.
  intros x y; rewrite Ropp_mult_distr_l_reverse.
  apply exp_Ropp.
Qed.

Lemma powerRZ_Rpower x z : (0 < x)%R -> powerRZ x z = Rpower x (IZR z).
Proof.
  intros Hx.
  assert (x <> 0)%R
    by now intros Habs; rewrite Habs in Hx; apply (Rlt_irrefl 0).
  destruct (intP z).
  - now rewrite Rpower_O.
  - rewrite <- pow_powerRZ, <- Rpower_pow by assumption.
    now rewrite INR_IZR_INZ.
  - rewrite opp_IZR, Rpower_Ropp.
    rewrite powerRZ_neg, powerRZ_inv by assumption.
    now rewrite <- pow_powerRZ, <- INR_IZR_INZ, Rpower_pow.
Qed.

Theorem Rle_Rpower :
  forall e n m:R, 1 <= e -> n <= m -> e ^R n <= e ^R m.
Proof.
  intros e n m [H | H]; intros H1.
  case H1.
    intros H2; left; apply Rpower_lt; assumption.
    intros H2; rewrite H2; right; reflexivity.
  now rewrite <- H; unfold Rpower; rewrite ln_1, !Rmult_0_r; apply Rle_refl.
Qed.

Theorem ln_lt_2 : / 2 < ln 2.
Proof.
  apply Rmult_lt_reg_l with (r := 2).
  prove_sup0.
  rewrite Rinv_r.
  apply exp_lt_inv.
  apply Rle_lt_trans with (1 := exp_le_3).
  change (3 < 2 ^R (1 + 1)).
  repeat rewrite Rpower_plus; repeat rewrite Rpower_1.
  now apply (IZR_lt 3 4).
  prove_sup0.
  discrR.
Qed.

(*****************************************)
(** * Differentiability of Ln and Rpower *)
(*****************************************)

Theorem limit1_ext :
  forall (f g:R -> R) (D:R -> Prop) (l x:R),
    (forall x:R, D x -> f x = g x) -> limit1_in f D l x -> limit1_in g D l x.
Proof.
  intros f g D l x H; unfold limit1_in, limit_in.
  intros H0 eps H1; case (H0 eps); auto.
  intros x0 [H2 H3]; exists x0; split; auto.
  intros x1 [H4 H5]; rewrite <- H; auto.
Qed.

Theorem limit1_imp :
  forall (f:R -> R) (D D1:R -> Prop) (l x:R),
    (forall x:R, D1 x -> D x) -> limit1_in f D l x -> limit1_in f D1 l x.
Proof.
  intros f D D1 l x H; unfold limit1_in, limit_in.
  intros H0 eps H1; case (H0 eps H1); auto.
  intros alpha [H2 H3]; exists alpha; split; auto.
  intros d [H4 H5]; apply H3; split; auto.
Qed.

Theorem Rinv_Rdiv : forall x y:R, x <> 0 -> y <> 0 -> / (x / y) = y / x.
Proof.
  intros x y H1 H2; unfold Rdiv; rewrite Rinv_mult_distr.
  rewrite Rinv_involutive.
  apply Rmult_comm.
  assumption.
  assumption.
  apply Rinv_neq_0_compat; assumption.
Qed.

Theorem Dln : forall y:R, 0 < y -> D_in ln Rinv (fun x:R => 0 < x) y.
Proof.
  intros y Hy; unfold D_in.
  apply limit1_ext with
    (f := fun x:R => / ((exp (ln x) - exp (ln y)) / (ln x - ln y))).
  intros x [HD1 HD2]; repeat rewrite exp_ln.
  unfold Rdiv; rewrite Rinv_mult_distr.
  rewrite Rinv_involutive.
  apply Rmult_comm.
  apply Rminus_eq_contra.
  red; intros H2; case HD2.
  symmetry ; apply (ln_inv _ _ HD1 Hy H2).
  apply Rminus_eq_contra; apply (not_eq_sym HD2).
  apply Rinv_neq_0_compat; apply Rminus_eq_contra; red; intros H2;
    case HD2; apply ln_inv; auto.
  assumption.
  assumption.
  apply limit_inv with
    (f := fun x:R => (exp (ln x) - exp (ln y)) / (ln x - ln y)).
  apply limit1_imp with
    (f := fun x:R => (fun x:R => (exp x - exp (ln y)) / (x - ln y)) (ln x))
    (D := Dgf (D_x (fun x:R => 0 < x) y) (D_x (fun x:R => True) (ln y)) ln).
  intros x [H1 H2]; split.
  split; auto.
  split; auto.
  red; intros H3; case H2; apply ln_inv; auto.
  apply limit_comp with
    (l := ln y) (g := fun x:R => (exp x - exp (ln y)) / (x - ln y)) (f := ln).
  apply ln_continue; auto.
  assert (H0 := derivable_pt_lim_exp (ln y)); unfold derivable_pt_lim in H0;
    unfold limit1_in; unfold limit_in;
      simpl; unfold R_dist; intros; elim (H0 _ H);
        intros; exists (pos x); split.
  apply (cond_pos x).
  intros; pattern y at 3; rewrite <- exp_ln.
  pattern x0 at 1; replace x0 with (ln y + (x0 - ln y));
    [ idtac | ring ].
  apply H1.
  elim H2; intros H3 _; unfold D_x in H3; elim H3; clear H3; intros _ H3;
    apply Rminus_eq_contra; apply (not_eq_sym (A:=R));
      apply H3.
  elim H2; clear H2; intros _ H2; apply H2.
  assumption.
  red; intro; rewrite H in Hy; elim (Rlt_irrefl _ Hy).
Qed.

Lemma derivable_pt_lim_ln : forall x:R, 0 < x -> derivable_pt_lim ln x (/ x).
Proof.
  intros; assert (H0 := Dln x H); unfold D_in in H0; unfold limit1_in in H0;
    unfold limit_in in H0; simpl in H0; unfold R_dist in H0;
      unfold derivable_pt_lim; intros; elim (H0 _ H1);
        intros; elim H2; clear H2; intros; set (alp := Rmin x0 (x / 2));
          assert (H4 : 0 < alp).
  unfold alp; unfold Rmin; case (Rle_dec x0 (x / 2)); intro.
  apply H2.
  unfold Rdiv; apply Rmult_lt_0_compat;
    [ assumption | apply Rinv_0_lt_compat; prove_sup0 ].
  exists (mkposreal _ H4); intros; pattern h at 2;
    replace h with (x + h - x); [ idtac | ring ].
  apply H3; split.
  unfold D_x; split.
  destruct (Rcase_abs h) as [Hlt|Hgt].
  assert (H7 : Rabs h < x / 2).
  apply Rlt_le_trans with alp.
  apply H6.
  unfold alp; apply Rmin_r.
  apply Rlt_trans with (x / 2).
  unfold Rdiv; apply Rmult_lt_0_compat;
    [ assumption | apply Rinv_0_lt_compat; prove_sup0 ].
  rewrite Rabs_left in H7.
  apply Rplus_lt_reg_l with (- h - x / 2).
  replace (- h - x / 2 + x / 2) with (- h); [ idtac | ring ].
  pattern x at 2; rewrite double_var.
  replace (- h - x / 2 + (x / 2 + x / 2 + h)) with (x / 2); [ apply H7 | ring ].
  apply Hlt.
  apply Rplus_lt_le_0_compat; [ assumption | apply Rge_le; apply Hgt ].
  apply (sym_not_eq (A:=R)); apply Rminus_not_eq; replace (x + h - x) with h;
    [ apply H5 | ring ].
  replace (x + h - x) with h;
  [ apply Rlt_le_trans with alp;
    [ apply H6 | unfold alp; apply Rmin_l ]
    | ring ].
Qed.

Theorem D_in_imp :
  forall (f g:R -> R) (D D1:R -> Prop) (x:R),
    (forall x:R, D1 x -> D x) -> D_in f g D x -> D_in f g D1 x.
Proof.
  intros f g D D1 x H; unfold D_in.
  intros H0; apply limit1_imp with (D := D_x D x); auto.
  intros x1 [H1 H2]; split; auto.
Qed.

Theorem D_in_ext :
  forall (f g h:R -> R) (D:R -> Prop) (x:R),
    f x = g x -> D_in h f D x -> D_in h g D x.
Proof.
  intros f g h D x H; unfold D_in.
  rewrite H; auto.
Qed.

Theorem Dpower :
  forall y z:R,
    0 < y ->
    D_in (fun x:R => x ^R z) (fun x:R => z * x ^R (z - 1)) (
      fun x:R => 0 < x) y.
Proof.
  intros y z H;
    apply D_in_imp with (D := Dgf (fun x:R => 0 < x) (fun x:R => True) ln).
  intros x H0; repeat split.
  assumption.
  apply D_in_ext with (f := fun x:R => / x * (z * exp (z * ln x))).
  unfold Rminus; rewrite Rpower_plus; rewrite Rpower_Ropp;
    rewrite (Rpower_1 _ H); unfold Rpower; ring.
  apply Dcomp with
    (f := ln)
    (g := fun x:R => exp (z * x))
    (df := Rinv)
    (dg := fun x:R => z * exp (z * x)).
  apply (Dln _ H).
  apply D_in_imp with
    (D := Dgf (fun x:R => True) (fun x:R => True) (fun x:R => z * x)).
  intros x H1; repeat split; auto.
  apply
    (Dcomp (fun _:R => True) (fun _:R => True) (fun x => z) exp
      (fun x:R => z * x) exp); simpl.
  apply D_in_ext with (f := fun x:R => z * 1).
  apply Rmult_1_r.
  apply (Dmult_const (fun x => True) (fun x => x) (fun x => 1)); apply Dx.
  assert (H0 := derivable_pt_lim_D_in exp exp (z * ln y)); elim H0; clear H0;
    intros _ H0; apply H0; apply derivable_pt_lim_exp.
Qed.

Theorem derivable_pt_lim_power :
  forall x y:R,
    0 < x -> derivable_pt_lim (fun x => x ^R y) x (y * x ^R (y - 1)).
Proof.
  intros x y H.
  unfold Rminus; rewrite Rpower_plus.
  rewrite Rpower_Ropp.
  rewrite Rpower_1; auto.
  rewrite <- Rmult_assoc.
  unfold Rpower.
  apply derivable_pt_lim_comp with (f1 := ln) (f2 := fun x => exp (y * x)).
  apply derivable_pt_lim_ln; assumption.
  rewrite (Rmult_comm y).
  apply derivable_pt_lim_comp with (f1 := fun x => y * x) (f2 := exp).
  pattern y at 2; replace y with (0 * ln x + y * 1).
  apply derivable_pt_lim_mult with (f1 := fun x:R => y) (f2 := fun x:R => x).
  apply derivable_pt_lim_const with (a := y).
  apply derivable_pt_lim_id.
  ring.
  apply derivable_pt_lim_exp.
Qed.

(* added later. *)

Lemma Rpower_mult_distr :
  forall x y z, 0 < x -> 0 < y ->
   Rpower x z * Rpower y z = Rpower (x * y) z.
intros x y z x0 y0; unfold Rpower.
rewrite <- exp_plus, ln_mult, Rmult_plus_distr_l; auto.
Qed.

Lemma Rlt_Rpower_l a b c: 0 < c -> 0 < a < b -> a ^R c < b ^R c.
Proof.
intros c0 [a0 ab]; apply exp_increasing.
now apply Rmult_lt_compat_l; auto; apply ln_increasing; fourier.
Qed.

Lemma Rle_Rpower_l a b c: 0 <= c -> 0 < a <= b -> a ^R c <= b ^R c.
Proof.
intros [c0 | c0];
 [ | intros; rewrite <- c0, !Rpower_O; [apply Rle_refl | |] ].
  intros [a0 [ab|ab]].
  now apply Rlt_le, Rlt_Rpower_l;[ | split]; fourier.
  rewrite ab; apply Rle_refl.
 apply Rlt_le_trans with a; tauto.
tauto.
Qed.

(* arcsinh function *)

Definition arcsinh x := ln (x + sqrt (x ^ 2 + 1)).

Lemma arcsinh_sinh : forall x, arcsinh (sinh x) = x.
intros x; unfold sinh, arcsinh.
assert (Rminus_eq_0 : forall r, r - r = 0) by (intros; ring).
rewrite <- exp_0, <- (Rminus_eq_0 x); unfold Rminus.
rewrite exp_plus.
match goal with |- context[sqrt ?a] =>
  replace a with (((exp x + exp(-x))/2)^2) by field
end.
rewrite sqrt_pow2;
 [|apply Rlt_le, Rmult_lt_0_compat;[apply Rplus_lt_0_compat; apply exp_pos |
                            apply Rinv_0_lt_compat, Rlt_0_2]].
match goal with |- context[ln ?a] => replace a with (exp x) by field end.
rewrite ln_exp; reflexivity.
Qed.

Lemma sinh_arcsinh x : sinh (arcsinh x) = x.
unfold sinh, arcsinh.
assert (cmp : 0 < x + sqrt (x ^ 2 + 1)).
 destruct (Rle_dec x 0).
  replace (x ^ 2) with ((-x) ^ 2) by ring.
  assert (sqrt ((- x) ^ 2) < sqrt ((-x)^2+1)).
   apply sqrt_lt_1_alt.
   split;[apply pow_le | ]; fourier.
  pattern x at 1; replace x with (- (sqrt ((- x) ^ 2))).
   assert (t:= sqrt_pos ((-x)^2)); fourier.
  simpl; rewrite Rmult_1_r, sqrt_square, Ropp_involutive;[reflexivity | fourier].
  apply Rplus_lt_le_0_compat;[apply Rnot_le_gt; assumption | apply sqrt_pos].
rewrite exp_ln;[ | assumption].
rewrite exp_Ropp, exp_ln;[ | assumption].
assert (Rmult_minus_distr_r :
         forall x y z, (x - y) * z = x * z - y * z) by (intros; ring).
apply Rminus_diag_uniq; unfold Rdiv; rewrite Rmult_minus_distr_r.
assert (t: forall x y z, x - z = y -> x - y - z = 0);[ | apply t; clear t].
 intros a b c H; rewrite <- H; ring.
apply Rmult_eq_reg_l with (2 * (x + sqrt (x ^ 2 + 1)));[ |
 apply Rgt_not_eq, Rmult_lt_0_compat;[apply Rlt_0_2 | assumption]].
assert (pow2_sqrt : forall x, 0 <= x -> sqrt x ^ 2 = x) by
 (intros; simpl; rewrite Rmult_1_r, sqrt_sqrt; auto).
field_simplify;[rewrite pow2_sqrt;[field | ] | apply Rgt_not_eq; fourier].
apply Rplus_le_le_0_compat;[simpl; rewrite Rmult_1_r; apply (Rle_0_sqr x)|apply Rlt_le, Rlt_0_1].
Qed.

Lemma derivable_pt_lim_arcsinh :
  forall x, derivable_pt_lim arcsinh x (/sqrt (x ^ 2 + 1)).
intros x; unfold arcsinh.
assert (0 < x + sqrt (x ^ 2 + 1)).
 destruct (Rle_dec x 0);
  [ | assert (0 < x) by (apply Rnot_le_gt; assumption);
    apply Rplus_lt_le_0_compat; auto; apply sqrt_pos].
 replace (x ^ 2) with ((-x) ^ 2) by ring.
 assert (sqrt ((- x) ^ 2) < sqrt ((-x)^2+1)).
  apply sqrt_lt_1_alt.
  split;[apply pow_le|]; fourier.
 pattern x at 1; replace x with (- (sqrt ((- x) ^ 2))).
  assert (t:= sqrt_pos ((-x)^2)); fourier.
 simpl; rewrite Rmult_1_r, sqrt_square, Ropp_involutive; auto; fourier.
assert (0 < x ^ 2 + 1).
 apply Rplus_le_lt_0_compat;[simpl; rewrite Rmult_1_r; apply Rle_0_sqr|fourier].
replace (/sqrt (x ^ 2 + 1)) with
 (/(x + sqrt (x ^ 2 + 1)) *
    (1 + (/(2 * sqrt (x ^ 2 + 1)) * (INR 2 * x ^ 1 + 0)))).
apply (derivable_pt_lim_comp (fun x => x + sqrt (x ^ 2 + 1)) ln).
 apply (derivable_pt_lim_plus).
  apply derivable_pt_lim_id.
   apply (derivable_pt_lim_comp (fun x => x ^ 2 + 1) sqrt x).
    apply derivable_pt_lim_plus.
     apply derivable_pt_lim_pow.
    apply derivable_pt_lim_const.
   apply derivable_pt_lim_sqrt; assumption.
  apply derivable_pt_lim_ln; assumption.
 replace (INR 2 * x ^ 1 + 0) with (2 * x) by (simpl; ring).
replace (1 + / (2 * sqrt (x ^ 2 + 1)) * (2 * x)) with
 (((sqrt (x ^ 2 + 1) + x))/sqrt (x ^ 2 + 1));
 [ | field; apply Rgt_not_eq, sqrt_lt_R0; assumption].
apply Rmult_eq_reg_l with (x + sqrt (x ^ 2 + 1));
  [ | apply Rgt_not_eq; assumption].
rewrite <- Rmult_assoc, Rinv_r;[field | ]; apply Rgt_not_eq; auto;
  apply sqrt_lt_R0; assumption.
Qed.

Lemma arcsinh_lt : forall x y, x < y -> arcsinh x < arcsinh y.
intros x y xy.
case (Rle_dec (arcsinh y) (arcsinh x));[ | apply Rnot_le_lt ].
intros abs; case (Rlt_not_le _ _ xy).
rewrite <- (sinh_arcsinh y), <- (sinh_arcsinh x).
destruct abs as [lt | q];[| rewrite q; fourier].
apply Rlt_le, sinh_lt; assumption.
Qed.

Lemma arcsinh_le : forall x y, x <= y -> arcsinh x <= arcsinh y.
intros x y [xy | xqy].
 apply Rlt_le, arcsinh_lt; assumption.
rewrite xqy; apply Rle_refl.
Qed.

Lemma arcsinh_0 : arcsinh 0 = 0.
 unfold arcsinh; rewrite pow_ne_zero, !Rplus_0_l, sqrt_1, ln_1;
  [reflexivity | discriminate].
Qed.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas32_2e243m9_10limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition mul :
  { mul : feBW_loose -> feBW_loose -> feBW_tight
  | forall a b, phiBW_tight (mul a b) = F.mul (phiBW_loose a) (phiBW_loose b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_mul ().
  Show Ltac Profile.
Time Defined.

Print Assumptions mul.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e336m17_7limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition mul :
  { mul : feBW_loose -> feBW_loose -> feBW_tight
  | forall a b, phiBW_tight (mul a b) = F.mul (phiBW_loose a) (phiBW_loose b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_mul ().
  Show Ltac Profile.
Time Defined.

Print Assumptions mul.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas32_2e285m9_12limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition mul :
  { mul : feBW_loose -> feBW_loose -> feBW_tight
  | forall a b, phiBW_tight (mul a b) = F.mul (phiBW_loose a) (phiBW_loose b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_mul ().
  Show Ltac Profile.
Time Defined.

Print Assumptions mul.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas32_2e321m9_13limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition mul :
  { mul : feBW_loose -> feBW_loose -> feBW_tight
  | forall a b, phiBW_tight (mul a b) = F.mul (phiBW_loose a) (phiBW_loose b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_mul ().
  Show Ltac Profile.
Time Defined.

Print Assumptions mul.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas32_2e191m19_8limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition mul :
  { mul : feBW_loose -> feBW_loose -> feBW_tight
  | forall a b, phiBW_tight (mul a b) = F.mul (phiBW_loose a) (phiBW_loose b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_mul ().
  Show Ltac Profile.
Time Defined.

Print Assumptions mul.


Require Import Mtac2.Mtac2.

Inductive my_enum_type :=
  one | two | three.

Require Import Vector.

Import Fin.

Require Import Lia.

Lemma lt_0_S n : 0 < S n. Proof. lia. Qed.

Fixpoint prove_leq n m : M (n < m) :=
  match n, m with
  | 0, S _ => M.ret (lt_0_S _)
  | S n', S m' =>
    H <- prove_leq n' m';
    M.ret (Lt.lt_n_S _ _ H)
  | _, _ => M.failwith "n not < m"
  end.

Definition to_fin_MP : T.selector unit := (fun l=>
  let n := mlength l in
  M.mapi (fun i '(m: _, g) =>
    H <- prove_leq i n;
    let v := rcbv (of_nat_lt H) in
    T.open_and_apply (T.exact v) g) l;;
  M.ret [m:])%MC.

Goal my_enum_type -> Fin.t 3.
MProof.
  intro H.
  T.destruct H &> to_fin_MP : gtactic unit. (* HACK: why do we need to specify the return type? *)
Qed.

Goal my_enum_type.
MProof.
  pose (H := FS (FS F1) : Fin.t 3).
  let p := proj1_sig (to_nat H) in
  T.nconstructor (S p).
Qed.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e321m9_7limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition add :
  { add : feBW_tight -> feBW_tight -> feBW_loose
  | forall a b, phiBW_loose (add a b) = F.add (phiBW_tight a) (phiBW_tight b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_add ().
  Show Ltac Profile.
Time Defined.

Print Assumptions add.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e521m1_9limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition add :
  { add : feBW_tight -> feBW_tight -> feBW_loose
  | forall a b, phiBW_loose (add a b) = F.add (phiBW_tight a) (phiBW_tight b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_add ().
  Show Ltac Profile.
Time Defined.

Print Assumptions add.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e321m9_6limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition add :
  { add : feBW_tight -> feBW_tight -> feBW_loose
  | forall a b, phiBW_loose (add a b) = F.add (phiBW_tight a) (phiBW_tight b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_add ().
  Show Ltac Profile.
Time Defined.

Print Assumptions add.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e190m11_4limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition add :
  { add : feBW_tight -> feBW_tight -> feBW_loose
  | forall a b, phiBW_loose (add a b) = F.add (phiBW_tight a) (phiBW_tight b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_add ().
  Show Ltac Profile.
Time Defined.

Print Assumptions add.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e413m21_8limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition add :
  { add : feBW_tight -> feBW_tight -> feBW_loose
  | forall a b, phiBW_loose (add a b) = F.add (phiBW_tight a) (phiBW_tight b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_add ().
  Show Ltac Profile.
Time Defined.

Print Assumptions add.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas32_2e213m3_8limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition add :
  { add : feBW_tight -> feBW_tight -> feBW_loose
  | forall a b, phiBW_loose (add a b) = F.add (phiBW_tight a) (phiBW_tight b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_add ().
  Show Ltac Profile.
Time Defined.

Print Assumptions add.


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

(** Basic operations on floats: alignment, addition, multiplication *)
Require Import Fcore_Raux.
Require Import Fcore_defs.
Require Import Fcore_float_prop.

Section Float_ops.

Variable beta : radix.

Notation bpow e := (bpow beta e).

Definition Falign (f1 f2 : float beta) :=
  let '(Float _ m1 e1) := f1 in
  let '(Float _ m2 e2) := f2 in
  if Zle_bool e1 e2
  then (m1, (m2 * Zpower beta (e2 - e1))%Z, e1)
  else ((m1 * Zpower beta (e1 - e2))%Z, m2, e2).

Theorem Falign_spec :
  forall f1 f2 : float beta,
  let '(m1, m2, e) := Falign f1 f2 in
  F2R f1 = F2R (Float beta m1 e) /\ F2R f2 = F2R (Float beta m2 e).
Proof.
unfold Falign.
intros (m1, e1) (m2, e2).
generalize (Zle_cases e1 e2).
case (Zle_bool e1 e2) ; intros He ; split ; trivial.
now rewrite <- F2R_change_exp.
rewrite <- F2R_change_exp.
apply refl_equal.
omega.
Qed.

Theorem Falign_spec_exp:
  forall f1 f2 : float beta,
  snd (Falign f1 f2) = Zmin (Fexp f1) (Fexp f2).
Proof.
intros (m1,e1) (m2,e2).
unfold Falign; simpl.
generalize (Zle_cases e1 e2);case (Zle_bool e1 e2); intros He.
case (Zmin_spec e1 e2); intros (H1,H2); easy.
case (Zmin_spec e1 e2); intros (H1,H2); easy.
Qed.

Definition Fopp (f1: float beta) :=
  let '(Float _ m1 e1) := f1 in
  Float beta (-m1)%Z e1.

Theorem F2R_opp :
  forall f1 : float beta,
  (F2R (Fopp f1) = -F2R f1)%R.
intros (m1,e1).
apply F2R_Zopp.
Qed.

Definition Fabs (f1: float beta) :=
  let '(Float _ m1 e1) := f1 in
  Float beta (Zabs m1)%Z e1.

Theorem F2R_abs :
  forall f1 : float beta,
  (F2R (Fabs f1) = Rabs (F2R f1))%R.
intros (m1,e1).
apply F2R_Zabs.
Qed.

Definition Fplus (f1 f2 : float beta) :=
  let '(m1, m2 ,e) := Falign f1 f2 in
  Float beta (m1 + m2) e.

Theorem F2R_plus :
  forall f1 f2 : float beta,
  F2R (Fplus f1 f2) = (F2R f1 + F2R f2)%R.
Proof.
intros f1 f2.
unfold Fplus.
generalize (Falign_spec f1 f2).
destruct (Falign f1 f2) as ((m1, m2), e).
intros (H1, H2).
rewrite H1, H2.
unfold F2R. simpl.
rewrite Z2R_plus.
apply Rmult_plus_distr_r.
Qed.

Theorem Fplus_same_exp :
  forall m1 m2 e,
  Fplus (Float beta m1 e) (Float beta m2 e) = Float beta (m1 + m2) e.
Proof.
intros m1 m2 e.
unfold Fplus.
simpl.
now rewrite Zle_bool_refl, Zminus_diag, Zmult_1_r.
Qed.

Theorem Fexp_Fplus :
  forall f1 f2 : float beta,
  Fexp (Fplus f1 f2) = Zmin (Fexp f1) (Fexp f2).
Proof.
intros f1 f2.
unfold Fplus.
rewrite <- Falign_spec_exp.
now destruct (Falign f1 f2) as ((p,q),e).
Qed.

Definition Fminus (f1 f2 : float beta) :=
  Fplus f1 (Fopp f2).

Theorem F2R_minus :
  forall f1 f2 : float beta,
  F2R (Fminus f1 f2) = (F2R f1 - F2R f2)%R.
Proof.
intros f1 f2; unfold Fminus.
rewrite F2R_plus, F2R_opp.
ring.
Qed.

Theorem Fminus_same_exp :
  forall m1 m2 e,
  Fminus (Float beta m1 e) (Float beta m2 e) = Float beta (m1 - m2) e.
Proof.
intros m1 m2 e.
unfold Fminus.
apply Fplus_same_exp.
Qed.

Definition Fmult (f1 f2 : float beta) :=
  let '(Float _ m1 e1) := f1 in
  let '(Float _ m2 e2) := f2 in
  Float beta (m1 * m2) (e1 + e2).

Theorem F2R_mult :
  forall f1 f2 : float beta,
  F2R (Fmult f1 f2) = (F2R f1 * F2R f2)%R.
Proof.
intros (m1, e1) (m2, e2).
unfold Fmult, F2R. simpl.
rewrite Z2R_mult, bpow_plus.
ring.
Qed.

End Float_ops.