(*
 * Copyright (c) 2017-present,
 * Programming Research Laboratory (ROPAS), Seoul National University, Korea
 * This software is distributed under the term of the BSD-3 clause license.
 *)
(** Lattice constructor: map.  *)

Set Implicit Arguments.

Require Import ZArith.
Require Import Morphisms Setoid.
Require Import hpattern vgtac.
Require Import TStr VocabA DLat DFMapAVL DPow.

Axiom map_narrow_msg : string_t.

Extract Constant map_narrow_msg => """narrow small big""".

Module Map (A : KEY) (B : LAT) <: LAT.

Module M := FMapAVL'.Make A.

Definition t := M.t B.t.

(** * Lattice operations *)

Definition find (k : A.t) (m : t) : B.t :=
  match M.find k m with
    | Some v => v
    | None => B.bot
  end.

Definition le_than (y : t) (k : A.t) (v :B.t) : bool :=
  if B.le_dec v (find k y) then true else false.

Definition le (x y : t) : Prop := forall k, B.le (find k x) (find k y).

Definition eq (x y : t) : Prop := forall k, B.eq (find k x) (find k y).

Lemma le_refl : forall (x y : t) (Heq : eq x y), le x y.
Proof. unfold le, eq. by auto using B.le_refl. Qed.

Lemma le_antisym : forall (x y : t) (le1 : le x y) (le2 : le y x), eq x y.
Proof. unfold le, eq. by auto using B.le_antisym. Qed.

Lemma le_trans : forall (x y z : t) (le1 : le x y) (le2 : le y z), le x z.
Proof. unfold le. by eauto using B.le_trans. Qed.

Lemma eq_refl : forall (x : t), eq x x.
Proof. unfold eq. by auto using B.eq_refl. Qed.

Lemma eq_sym : forall (x y : t) (Heq : eq x y), eq y x.
Proof. unfold eq. by auto using B.eq_sym. Qed.

Lemma eq_trans : forall (x y z : t) (eq1 : eq x y) (eq2 : eq y z), eq x z.
Proof. unfold eq. by eauto using B.eq_trans. Qed.

Lemma find_mor' : Proper (A.eq ==> le ==> B.le) find.
Proof.
intros k1 k2 Hk m1 m2 Hm; unfold eq in Hm.
apply B.le_trans with (find k1 m2); [by apply Hm|].
apply B.le_refl.
unfold find.
rewrite (M.P.F.find_m Hk (M.P.F.Equal_refl m2)); by apply B.eq_refl.
Qed.

Lemma find_mor : Proper (A.eq ==> eq ==> B.eq) find.
Proof.
intros k1 k2 Hk m1 m2 Hm.
apply B.le_antisym.
- apply le_refl in Hm; by apply find_mor'.
- apply eq_sym in Hm; apply le_refl in Hm. apply A.eq_sym in Hk.
  by apply find_mor'.
Qed.

Lemma find_mor2 : Proper (A.eq ==> Logic.eq ==> Logic.eq) find.
Proof.
intros k1 k2 Hk m1 m2 Hm. subst.
unfold find; rewrite M.P.F.find_m_Proper
; [|by apply Hk|by apply M.P.F.Equal_refl].
reflexivity.
Qed.

Lemma le_than_mor :
  Proper (eq ==> A.eq ==> B.eq ==> Logic.eq) le_than.
Proof.
intros m1 m2 Hm k1 k2 Hk v1 v2 Hv; unfold le_than.
destruct (B.le_dec v1 (find k1 m1)); destruct (B.le_dec v2 (find k2 m2)).
- by auto.
- elim f.
  apply B.le_trans with v1; [by auto using B.le_refl, B.eq_sym|].
  eapply B.le_trans; [by apply l|].
  apply B.le_refl; by apply find_mor.
- elim f.
  apply B.le_trans with v2; [by auto using B.le_refl, B.eq_sym|].
  eapply B.le_trans; [by apply l|].
  apply B.le_refl; apply B.eq_sym; by apply find_mor.
- by auto.
Qed.

Definition for_all print cond m := M.for_all (elt := B.t) print cond m.

Lemma for_all_1 :
  forall m cond (Hcond : forall k v (Hmaps : find k m = v), cond k v = true),
    for_all print2 cond m = true.
Proof.
  unfold find, for_all; i; apply M.for_all_1; i.
  apply Hcond; apply M.P.F.find_mapsto_iff in Hmaps; by rewrite Hmaps.
Qed.

Lemma for_all_2 :
  forall m cond
         (Hmor : Proper (A.eq ==> B.eq ==> Logic.eq) cond)
         (Hbot : forall k, cond k B.bot = true)
         (Hforall : for_all print2 cond m = true),
  forall k v (Hmaps : find k m = v), cond k v.
Proof.
  unfold find, for_all; i.
  remember (M.find (elt:=B.t) k m) as o; destruct o; subst.
  + symmetry in Heqo; apply M.P.F.find_mapsto_iff in Heqo.
    eapply M.for_all_2; [|apply Hforall|apply Heqo]; i.
    apply Hmor; by auto using B.eq_refl.
  + apply Hbot.
Qed.

Lemma simple_le_dec :
  forall x y (Hdec : for_all print2 (le_than y) x = true), le x y.
Proof.
unfold le; intros x y Hb k.
apply for_all_2 with (k := k) (v := find k x) in Hb; try done.
- unfold le_than in Hb; by destruct (B.le_dec (find k x) (find k y)).
- apply le_than_mor; by apply eq_refl.
- unfold le_than; i; destruct (B.le_dec B.bot (find k0 y)); try done.
  elim f; by apply B.bot_prop.
Defined.

Lemma simple_le_dec_prop :
  forall x y (Hdec : for_all print2 (le_than y) x = false),
  exists k, M.In k x /\ ~(B.le (find k x) (find k y)).
Proof.
unfold for_all; i; eapply M.for_all_2' in Hdec
; [|i; apply le_than_mor; auto using eq_refl, B.eq_refl].
destruct Hdec as [k [v [Hmaps Hfalse]]]; exists k.
split; [eapply M.mapsto_in; by eauto|].
unfold le_than in Hfalse.
match goal with [H:(if ?c then _ else _) = _ |- _] => destruct c end
; [discriminate|].
intro; elim f.
eapply B.le_trans; [|by apply FH].
unfold find; apply M.P.F.find_mapsto_iff in Hmaps.
rewrite Hmaps; apply B.le_refl; by apply B.eq_refl.
Qed.

Definition le_dec (x y : t) : {le x y} + {~ le x y}.
refine ((if physical_eq x y as c return
           physical_eq x y = c -> {le x y} + {~ le x y}
         then fun Hc => left _ else
           fun _ =>
             match for_all print2 (le_than y) x as b return
                   for_all print2 (le_than y) x = b
                   -> {le x y} + {~ le x y} with
               | true => fun Hb => left _
               | false => fun Hb => right _
             end Logic.eq_refl) Logic.eq_refl); unfold le; i.
+ apply physical_eq_prop in Hc; subst; apply le_refl; by apply eq_refl.
+ by apply simple_le_dec.
+ by destruct (simple_le_dec_prop _ _ Hb) as [k [Hin Hle]].
Qed.

Definition eq_dec (x y : t) : {eq x y} + {~ eq x y}.
refine (match le_dec x y, le_dec y x with
          | left H1, left H2 => left _
          | _, _ => right _
        end).
- auto using le_antisym.
- intro; elim f. auto using le_refl, eq_sym.
- intro; elim f. auto using le_refl.
Qed.

Definition empty : t := M.empty B.t.

Definition bot : t := empty.

Lemma bot_prop : forall (x : t), le bot x.
Proof. destruct x; unfold le; i; by apply B.bot_prop. Qed.

Definition join' (opt_v1 opt_v2 : option B.t) : option B.t :=
  match opt_v1, opt_v2 with
    | None, None => None
    | None, Some v
    | Some v, None => if B.eq_dec v B.bot then None else Some v
    | Some v1, Some v2 =>
      let joined_v := B.join v1 v2 in
      if B.eq_dec joined_v B.bot then None else Some joined_v
  end.

Lemma join'_prop : forall x y v (Hjoin : join' x y = Some v), ~ B.eq v B.bot.
Proof.
unfold join'; i; destruct x, y; try done
; match goal with _ : context [if ?x then _ else _] |- _ => destruct x end
; try done; elim f; by inv Hjoin.
Qed.

Definition join (x y : t) : t := M.map2 join' x y.

Lemma join_left : forall (x y : t), le x (join x y).
Proof.
  unfold join, le, find; i.
  rewrite M.P.F.map2_1bis; [|eauto].
  destruct (M.find (elt:=B.t) k x); [|apply B.bot_prop].
  unfold join'.
  destruct (M.find (elt:=B.t) k y); repeat dest_if_dec
  ; by eauto using B.le_trans, B.le_refl, B.eq_refl, B.join_left.
Qed.

Lemma join_right : forall (x y : t), le y (join x y).
Proof.
  unfold join, le, find; i.
  rewrite M.P.F.map2_1bis; [|eauto].
  destruct (M.find (elt:=B.t) k y); [|apply B.bot_prop].
  unfold join'.
  destruct (M.find (elt:=B.t) k x); repeat dest_if_dec
  ; by eauto using B.le_trans, B.le_refl, B.eq_refl, B.join_right.
Qed.

Lemma map2_join' : forall k x y,
  B.eq (find k (M.map2 join' x y)) (B.join (find k x) (find k y)).
Proof.
i; unfold find.
rewrite M.P.F.map2_1bis; [|done].
destruct (M.find (elt:=B.t) k x)
; destruct (M.find (elt:=B.t) k y); s
; try dest_if_dec
; auto using B.join_lub, B.le_refl, B.eq_refl,
  B.bot_prop, B.le_antisym, B.join_left, B.join_right.
Qed.

Lemma join_lub : forall (x y u : t) (Hx : le x u) (Hy : le y u), le (join x y) u.
Proof.
unfold join, le; i.
eapply B.le_trans; [apply B.le_refl; apply map2_join'|].
by apply B.join_lub.
Qed.

Lemma join_find : forall k x y,
  B.eq (find k (join x y)) (B.join (find k x) (find k y)).
Proof.
unfold join, find; i; rewrite M.P.F.map2_1bis; [|reflexivity].
destruct (M.find (elt:=B.t) k x), (M.find (elt:=B.t) k y)
; unfold join'; try dest_if_dec
; auto using B.eq_sym, B.eq_refl, B.le_refl, B.le_antisym, B.bot_prop,
  B.le_refl, B.join_lub, B.join_left, B.join_right.
Qed.

Definition meet' (opt_v1 opt_v2 : option B.t) : option B.t :=
  match opt_v1, opt_v2 with
    | None, _
    | _, None => None
    | Some v1, Some v2 =>
      let meeted_v := B.meet v1 v2 in
      if B.eq_dec meeted_v B.bot then None else Some meeted_v
  end.

Lemma meet'_1 : forall x y v (Hmeet : meet' x y = Some v), ~ B.eq v B.bot.
Proof.
unfold meet'; i; destruct x, y; try done
; match goal with _ : context [if ?x then _ else _] |- _ => destruct x end
; try done; elim f; by inv Hmeet.
Qed.

Definition meet (x y : t) : t := M.map2 meet' x y.

Lemma meet_left : forall (x y : t), le (meet x y) x.
Proof.
  unfold meet, le, find; i.
  rewrite M.P.F.map2_1bis; [|eauto].
  destruct (M.find (elt:=B.t) k x);
  simpl; destruct (M.find (elt:=B.t) k y);
  try apply B.bot_prop.
  dest_if_dec; auto using B.bot_prop, B.meet_left.
Qed.

Lemma meet_right : forall (x y : t), le (meet x y) y.
Proof.
  unfold meet, le, find; i.
  rewrite M.P.F.map2_1bis; [|eauto].
  destruct (M.find (elt:=B.t) k x);
  simpl; destruct (M.find (elt:=B.t) k y);
  try (apply B.bot_prop).
  dest_if_dec; auto using B.bot_prop, B.meet_right.
Qed.

Lemma map2_meet' : forall k x y,
  B.eq (find k (M.map2 meet' x y)) (B.meet (find k x) (find k y)).
Proof.
i; unfold find.
rewrite M.P.F.map2_1bis; [|done].
destruct (M.find (elt:=B.t) k x)
; destruct (M.find (elt:=B.t) k y); s; try dest_if_dec
; auto using B.meet_glb, B.le_refl, B.eq_refl,
  B.bot_prop, B.le_antisym, B.meet_left, B.meet_right.
Qed.

Lemma meet_glb : forall (x y l : t) (Hx : le l x) (Hy : le l y), le l (meet x y).
Proof.
unfold meet, le; i.
eapply B.le_trans
; [|apply B.le_refl; apply B.eq_sym; apply map2_meet'].
by apply B.meet_glb.
Qed.

Lemma meet_find : forall k x y,
  B.eq (find k (meet x y)) (B.meet (find k x) (find k y)).
Proof.
unfold meet, find; i; rewrite M.P.F.map2_1bis; [|reflexivity].
destruct (M.find (elt:=B.t) k x), (M.find (elt:=B.t) k y)
; unfold meet'; try dest_if_dec
; auto using B.eq_sym, B.eq_refl, B.le_refl, B.le_antisym, B.bot_prop,
  B.le_refl, B.meet_glb, B.meet_left, B.meet_right.
Qed.

Definition widen' (opt_v1 opt_v2 : option B.t) : option B.t :=
  match opt_v1, opt_v2 with
    | None, None => None
    | None, Some v
    | Some v, None => if B.eq_dec v B.bot then None else Some v
    | Some v1, Some v2 =>
      let widened_v := B.widen v1 v2 in
      if B.eq_dec widened_v B.bot then None else Some widened_v
  end.

Definition widen (x y : t) : t := M.map2 widen' x y.

Definition narrow' (opt_v1 opt_v2 : option B.t) : option B.t :=
  match opt_v1, opt_v2 with
    | _, None => None
    | None, Some v =>
      if B.eq_dec v B.bot then None else invalid_arg map_narrow_msg
    | Some v1, Some v2 =>
      let narrowed_v := B.narrow v1 v2 in
      if B.eq_dec narrowed_v B.bot then None else Some narrowed_v
  end.

Definition narrow (x y : t) : t := M.map2 narrow' x y.

Include JoinMeetProp.

(** * Map operations *)

Definition is_empty (x : t) : bool := M.is_empty x.

Lemma find_mapsto : forall k m (Hin : M.In k m), M.MapsTo k (find k m) m.
Proof.
unfold find; i.
apply M.P.F.find_mapsto_iff.
apply M.P.F.in_find_iff in Hin.
destruct (M.find k m); by auto.
Qed.

Lemma empty_prop : forall (k : A.t), B.eq (find k empty) B.bot.
Proof. unfold find, empty; i; rewrite M.P.F.empty_o; apply B.eq_refl. Qed.

Definition add (k : A.t) (v : B.t) (m : t) : t := M.add k v m.

Lemma add_same : forall k1 k2 (Hk : A.eq k1 k2) v m, B.eq (find k1 (add k2 v m)) v.
Proof.
i. unfold find, add.
rewrite (M.P.F.find_o _ Hk).
rewrite M.P.F.add_eq_o; auto using B.eq_refl.
Qed.

Lemma add_diff : forall k1 k2 (Hk : ~ A.eq k1 k2) v m, (find k1 (add k2 v m)) = (find k1 m).
Proof. i; unfold find, add; rewrite (M.P.F.add_neq_o); auto. Qed.

Definition add_mor' : Proper (A.eq ==> B.le ==> le ==> le) add.
Proof.
intros k1 k2 Hk v1 v2 Hv m1 m2 Hm k. destruct (A.eq_dec k k1).
- eapply B.le_trans; [eapply B.le_trans; [|apply Hv]|].
  + apply B.le_refl. by apply add_same.
  + apply B.le_refl. apply B.eq_sym, add_same. by eauto using A.eq_trans.
- apply B.le_trans with (find k m1).
  + apply B.le_refl. rewrite add_diff; [by apply B.eq_refl|by auto].
  + eapply B.le_trans; [by apply Hm|].
    apply B.le_refl; apply B.eq_sym. rewrite add_diff; [by apply B.eq_refl|].
    by eauto using A.eq_trans.
Qed.

Lemma add_mor : Proper (A.eq ==> B.eq ==> eq ==> eq) add.
Proof.
intros ? ? ? ? ? ? ? ? ?. apply le_antisym.
- apply add_mor'; [by auto|by apply B.le_refl|by apply le_refl].
- apply add_mor'
  ; [by auto|by apply B.le_refl, B.eq_sym|by apply le_refl, eq_sym].
Qed.

Definition weak_add (k : A.t) (v : B.t) (m : t) : t :=
  let orig_v := find k m in
  if B.le_dec v orig_v then m else
  M.add k (B.join orig_v v) m.

Lemma weak_add_prop :
  forall k1 k2 (Hk : A.eq k1 k2) v m,
    B.eq (B.join v (find k2 m)) (find k1 (weak_add k2 v m)).
Proof.
i; unfold weak_add; dest_if_dec.
- apply B.eq_trans with (find k2 m).
  + apply B.eq_sym. by apply B.join_le_idem.
  + apply find_mor; by auto using A.eq_sym, eq_refl.
- eapply B.eq_trans; [|apply B.eq_sym; by apply add_same].
  by apply B.join_comm_eq.
Qed.

Lemma weak_add_diff : forall k1 k2 (Hk : ~ A.eq k1 k2) v m, (find k1 (weak_add k2 v m)) = (find k1 m).
Proof.
  i; unfold find, weak_add; repeat dest_if_dec
  ; rewrite M.P.F.add_neq_o; auto.
Qed.

Definition weak_add_mor' : Proper (A.eq ==> B.le ==> le ==> le) weak_add.
Proof.
intros k1 k2 Hk v1 v2 Hv m1 m2 Hm k.
destruct (A.eq_dec k k1).
- apply B.le_trans with (find k1 (weak_add k1 v1 m1))
  ; [apply find_mor'; [by auto|apply le_refl; by apply eq_refl]|].
  apply B.le_trans with (B.join v1 (find k1 m1))
  ; [ apply B.le_refl; apply B.eq_sym; apply weak_add_prop
      ; by apply A.eq_refl |].
  apply B.le_trans with (B.join v2 (find k2 m2))
  ; [apply B.join_le; [by auto|apply find_mor'; by auto]|].
  apply B.le_trans with (find k2 (weak_add k2 v2 m2))
  ; [apply B.le_refl; apply weak_add_prop; by apply A.eq_refl|].
  apply find_mor'
  ; [ apply A.eq_sym; apply A.eq_trans with k1; by auto
    | apply le_refl; by apply eq_refl ].
- apply B.le_trans with (find k m1).
  + apply B.le_refl. rewrite weak_add_diff; [by apply B.eq_refl|by auto].
  + eapply B.le_trans; [by apply Hm|].
    apply B.le_refl; apply B.eq_sym. rewrite weak_add_diff; [by apply B.eq_refl|].
    by eauto using A.eq_trans.
Qed.

Definition weak_add_mor : Proper (A.eq ==> B.eq ==> eq ==> eq) weak_add.
Proof.
intros k1 k2 Hk v1 v2 Hv m1 m2 Hm.
apply le_antisym.
- apply B.le_refl in Hv; apply le_refl in Hm. by apply weak_add_mor'.
- apply A.eq_sym in Hk; apply B.eq_sym in Hv; apply eq_sym in Hm.
  apply B.le_refl in Hv; apply le_refl in Hm.
  by apply weak_add_mor'.
Qed.

Definition fast_weak_add (k : A.t) (v : B.t) (m : t) : t :=
  let orig_v := find k m in
  M.add k (B.join orig_v v) m.

Definition remove (k : A.t) (m : t) : t := M.remove k m.

Lemma remove_same : forall k1 k2 (Hk : A.eq k1 k2) m, (find k1 (remove k2 m)) = B.bot.
Proof. i; unfold find, remove; rewrite M.P.F.remove_eq_o; auto. Qed.

Lemma remove_diff : forall k1 k2 (Hk : ~ A.eq k1 k2) m, (find k1 (remove k2 m)) = (find k1 m).
Proof. i; unfold find, remove; rewrite M.P.F.remove_neq_o; auto. Qed.

(* The input function of map ([f]) should preserve non-bottom
values. *)

Definition map (f : B.t -> B.t) (m : t) : t :=
  M.map (fun k => f k) m.

Lemma map_1 :
  forall f l v m (Hf : f B.bot = B.bot) (Hfind : find l m = v),
    find l (map f m) = f v.
Proof.
unfold find, map; i. rewrite M.P.F.map_o.
remember (M.find (elt:=B.t) l m) as v'; destruct v' as [v'|]; subst; by auto.
Qed.

Definition mapi (f : A.t -> B.t -> B.t) (m : t) : t :=
  M.mapi (fun k v => f k v) m.

Definition fold {T : Type} (f : B.t -> T -> T) (m : t) (acc : T) : T :=
  let f' (_ : A.t) (v : B.t) (acc : T) : T := f v acc in
  M.fold f' m acc.

Definition foldi {T : Type} (f : A.t -> B.t -> T -> T) (m : t) (acc : T) : T :=
  M.fold f m acc.

Lemma not_InA_findA_none :
  forall l k k' v (Hnot_InA : ~ (SetoidList.InA (M.eq_key (elt:=B.t)) (k, v) l))
     (Heq : M.E.eq k' k),
    SetoidList.findA (M.P.F.eqb k') l = None.
Proof.
induction l; [by auto|].
i; s. destruct a as [ak av].
unfold M.P.F.eqb. destruct (M.E.eq_dec k' ak).
- elim Hnot_InA. apply SetoidList.InA_cons_hd.
  unfold M.eq_key, M.Raw.Proofs.PX.eqk; s.
  eapply A.eq_trans; [apply A.eq_sym; by apply Heq|by apply e].
- eapply IHl; [|by apply Heq].
  intro. elim Hnot_InA. apply SetoidList.InA_cons_tl.
  by apply FH.
Qed.

Lemma foldi_3 :
  forall {T : Type} (teq : relation T) (teq_equiv : equivalence _ teq)
     (P : T -> Prop) (P_mor : Proper (teq ==> iff) P)
     (f : A.t -> B.t -> T -> T) (Hf : forall k v x (Hv : B.eq B.bot v), teq (f k v x) x)
     (m : t) (i : T)
     (Hinit : P i)
     (Hind : forall k v (Hkv : B.eq (find k m) v) x (Hx : P x), P (f k v x)),
    P (foldi f m i).
Proof.
unfold foldi, find; i. rewrite M.fold_1.
assert
  ( forall (k : A.t) (v : B.t),
      B.eq
        match SetoidList.findA (M.P.F.eqb k) (M.elements m) with
        | Some v0 => v0
        | None => B.bot
        end v -> forall x : T, P x -> P (f k v x)
  ) as Hind'
; [i; apply Hind; [by rewrite M.P.F.elements_o|by auto]|clear Hind].
assert (Hnodup := M.elements_3w m).
generalize dependent i; induction (M.elements m); [by auto|].
destruct a as [ak av].
s; i; eapply IHl; clear IHl.
- i. destruct (M.E.eq_dec k ak).
  + inversion Hnodup; subst.
    apply not_InA_findA_none with (k':=k) in H3; [rewrite H3 in H|by auto].
    eapply P_mor; [|by apply H0]. by apply Hf.
  + apply Hind'; [|by auto].
    s. unfold M.P.F.eqb.
    destruct (M.E.eq_dec k ak); [congruence|by auto].
- by inversion Hnodup.
- apply Hind'; [|by auto]; s.
  unfold M.P.F.eqb; destruct (M.E.eq_dec ak ak)
  ; [by apply B.eq_refl|elim n; by apply M.E.eq_refl].
Qed.

Lemma foldi_2 :
  forall {T : Type} (teq : relation T) (teq_equiv : equivalence _ teq)
     (P : T -> Prop) (P_mor : Proper (teq ==> iff) P)
     (Q : T -> Prop) (Q_mor : Proper (teq ==> iff) Q)
     (f : A.t -> B.t -> T -> T)
     k v m (Hkv : B.eq (find k m) v) (He : forall x (Hx : P x), Q (f k v x))
     (Hf : forall k v x (Hv : B.eq B.bot v), teq (f k v x) x)
     i (Hinit : P i)
     (HP : forall k v x (Hx : P x), P (f k v x))
     (HQ : forall k v x (Hx : Q x), Q (f k v x))
     (Hf_eq :
        forall k1 k2 (Hk : A.eq k1 k2) v1 v2 (Hv : B.eq v1 v2)
           x (Hf : Q (f k1 v1 x)),
          Q (f k2 v2 x)),
    Q (foldi f m i).
Proof.
unfold foldi, find; i. rewrite M.fold_1.
rewrite M.P.F.elements_o in Hkv.
assert (Hnodup := M.elements_3w m).
generalize dependent i; induction (M.elements m) as [|[ak av]]; s; i.
- erewrite <- Hf; [by apply He|by apply Hkv].
- unfold SetoidList.findA, M.P.F.eqb in Hkv; destruct (M.E.eq_dec k ak).
  + assert (Q (f ak av i)) as Hind
    ; [eapply Hf_eq; [by apply e|apply B.eq_sym; by apply Hkv|by apply He]|].
    clear IHl. generalize dependent (f ak av i); induction l.
    * by auto.
    * i; s. eapply IHl; [|by apply HQ].
      inversion Hnodup; inversion H2; subst.
      apply SetoidList.NoDupA_cons; [|by auto].
      intro. elim H1.
      by apply SetoidList.InA_cons_tl.
  + apply IHl; [by apply Hkv|by inversion Hnodup|by apply HP].
Qed.

Lemma foldi_1 :
  forall {T : Type} (teq : relation T) (teq_equiv : equivalence _ teq)
     (P : T -> Prop) (P_mor : Proper (teq ==> iff) P)
     (f : A.t -> B.t -> T -> T)
     k v m (Hkv : B.eq (find k m) v) (He : forall x, P (f k v x))
     (Hf : forall k v x (Hv : B.eq B.bot v), teq (f k v x) x)
     i (HP : forall k v x (Hx : P x), P (f k v x))
     (Hf_eq :
        forall k1 k2 (Hk : A.eq k1 k2) v1 v2 (Hv : B.eq v1 v2)
           x (Hf : P (f k1 v1 x)),
          P (f k2 v2 x)),
    P (foldi f m i).
Proof.
i. eapply foldi_2 with (P0:=fun (x:T)=>True)
; [ by apply teq_equiv | by auto | by apply P_mor | by apply Hkv
  | i; by apply He | by apply Hf | by auto | by auto | by apply HP
  | by apply Hf_eq ].
Qed.

Inductive assoc_eq : relation (list (A.t * B.t)) :=
| assoc_eq_nil : assoc_eq nil nil
| assoc_eq_bot1 :
    forall m1 m2 (Hm : assoc_eq m1 m2) k v (Hv : B.eq B.bot v),
      assoc_eq m1 (cons (k, v) m2)
| assoc_eq_bot2 :
    forall m1 m2 (Hm : assoc_eq m1 m2) k v (Hv : B.eq B.bot v),
      assoc_eq (cons (k, v) m1) m2
| assoc_eq_cons :
    forall m1 m2 (Hm : assoc_eq m1 m2) k1 k2 (Hk : A.eq k1 k2)
       v1 v2 (Hv : B.eq v1 v2)
       (Hv1 : not (B.eq B.bot v1)) (Hv2 : not (B.eq B.bot v2)),
      assoc_eq (cons (k1, v1) m1) (cons (k2, v2) m2).

Lemma assoc_eq_refl : forall x, assoc_eq x x.
Proof.
induction x; [by apply assoc_eq_nil|].
destruct a as [k v]. destruct (B.eq_dec B.bot v).
- apply assoc_eq_bot1; [|by auto].
  apply assoc_eq_bot2; by auto.
- apply assoc_eq_cons
  ; [by auto|by apply A.eq_refl|by apply B.eq_refl|by auto|by auto].
Qed.

Lemma assoc_eq_sym : forall x y (Heq : assoc_eq x y), assoc_eq y x.
Proof.
induction 1.
- by apply assoc_eq_nil.
- by apply assoc_eq_bot2.
- by apply assoc_eq_bot1.
- apply assoc_eq_cons
  ; [by auto|by apply A.eq_sym|by apply B.eq_sym|by auto|by auto].
Qed.

Lemma assoc_eq_trans :
  forall x y z (Heq1 : assoc_eq x y) (Heq2 : assoc_eq y z), assoc_eq x z.
Proof. {
intros x y z Heq1. revert z. induction Heq1.
- by auto.
- intro z. remember ((k, v) :: m2) as m2'.
  induction 1.
  + by inversion Heqm2'.
  + apply assoc_eq_bot1; [by apply IHHeq2|by auto].
  + inversion Heqm2'; subst. by apply IHHeq1.
  + inversion Heqm2'; by subst.
- i. apply assoc_eq_bot2; [by apply IHHeq1|by auto].
- induction z.
  + inversion 1; subst; tauto.
  + inversion 1; subst.
    * apply assoc_eq_bot1; [by apply IHz|by auto].
    * tauto.
    * apply assoc_eq_cons
      ; [ by apply IHHeq1
        | eapply A.eq_trans; [by apply Hk|by apply Hk0]
        | eapply B.eq_trans; [by apply Hv|by apply Hv0]
        | by auto | by auto ].
} Qed.

Lemma assoc_eq_nil_cond :
  forall l (Hl : forall k : A.t,
           B.eq B.bot
                match SetoidList.findA (M.P.F.eqb k) l with
                | Some v => v
                | None => B.bot
                end)
     (Hnodup : SetoidList.NoDupA (M.eq_key (elt:=B.t)) l),
    assoc_eq nil l.
Proof.
induction l.
- s; i. by apply assoc_eq_nil.
- s; i.
  inversion Hnodup; subst.
  destruct a as [k v]. apply assoc_eq_bot1.
  + apply IHl; [|by auto].
    intro j. specialize (Hl j). unfold M.P.F.eqb in Hl.
    destruct (M.E.eq_dec j k); [|by auto].
    erewrite not_InA_findA_none; [by apply B.eq_refl|by apply H1|by apply e].
  + specialize (Hl k). unfold M.P.F.eqb in Hl.
    destruct (M.E.eq_dec k k); [by auto|elim n; by apply A.eq_refl].
Qed.

Lemma findA_head :
  forall k k' v x (Heq : A.eq k k'),
    SetoidList.findA (B:=B.t) (M.P.F.eqb k) ((k', v) :: x) = Some v.
Proof.
i. unfold SetoidList.findA at 1, M.P.F.eqb at 1.
destruct (A.eq_dec k k'); [reflexivity|tauto].
Qed.

Lemma findA_tail :
  forall k k' v x (Heq : not (A.eq k k')),
    SetoidList.findA (B:=B.t) (M.P.F.eqb k) ((k', v) :: x)
    = SetoidList.findA (B:=B.t) (M.P.F.eqb k) x.
Proof.
i. unfold SetoidList.findA at 1, M.P.F.eqb at 1.
destruct (A.eq_dec k k'); [tauto|reflexivity].
Qed.

Lemma lt_findA_None :
  forall l k1 k2 v (Hlt : A.lt k1 k2)
     (Hsort : Sorted.Sorted (M.lt_key (elt:=B.t)) ((k2, v) :: l)),
    SetoidList.findA (M.P.F.eqb k1) ((k2, v) :: l) = None.
Proof.
induction l; i.
- s. unfold M.P.F.eqb.
  destruct (A.eq_dec k1 k2); [by apply A.lt_not_eq in Hlt|by auto].
- unfold SetoidList.findA.
  unfold M.P.F.eqb at 1.
  destruct (A.eq_dec k1 k2); [by apply A.lt_not_eq in Hlt|].
  destruct a as [ka va]; apply IHl; [|by inversion Hsort].
  inversion Hsort; inversion H2; subst.
  unfold M.lt_key, M.Raw.Proofs.PX.ltk in H4; simpl in H4.
  eapply A.lt_trans; [by apply Hlt|by apply H4].
Qed.

Lemma noDup_findA_None :
  forall k k' (Hk : M.E.eq k k')
     v x (Hnodup : SetoidList.NoDupA (M.eq_key (elt:=B.t)) ((k, v) :: x)),
    SetoidList.findA (M.P.F.eqb k') x = None.
Proof.
i. inversion Hnodup; subst.
eapply not_InA_findA_none; [by apply H1|by apply M.E.eq_sym].
Qed.

Lemma key_eqb_refl : forall k, M.P.F.eqb k k = true.
Proof.
i. unfold M.P.F.eqb.
destruct (M.P.F.eq_dec k k); [by auto|elim n; by apply M.E.eq_refl].
Qed.

Lemma key_eqb_true :
  forall k1 k2 (Heq : M.E.eq k1 k2), M.P.F.eqb k1 k2 = true.
Proof. unfold M.P.F.eqb. i. dest_if_dec. Qed.

Lemma key_eqb_false :
  forall k1 k2 (Hneq : ~ M.E.eq k1 k2), M.P.F.eqb k1 k2 = false.
Proof. unfold M.P.F.eqb. i. dest_if_dec. Qed.

Lemma key_neq_sym : forall k1 k2 (Hneq : ~ A.eq k1 k2), ~ A.eq k2 k1.
Proof. i. elim Hneq. by apply A.eq_sym. Qed.

Lemma eq_assoc_eq :
  forall x y (Heq : eq x y),
    assoc_eq (M.elements (elt:=B.t) x) (M.elements (elt:=B.t) y).
Proof. {
unfold eq, find; i.
assert
  ( forall k,
      B.eq
        match SetoidList.findA (M.P.F.eqb k) (M.elements x) with
        | Some v => v
        | None => B.bot
        end
        match SetoidList.findA (M.P.F.eqb k) (M.elements y) with
        | Some v => v
        | None => B.bot
        end ) as Heq'
; [i; by do 2 rewrite <- M.P.F.elements_o; by apply Heq|clear Heq].
assert (Hnodupx := M.elements_3w x); assert (Hnodupy := M.elements_3w y).
assert (Hsortx := M.elements_3 x); assert (Hsorty := M.elements_3 y).
Local Ltac apply_inv H :=
  apply H; [| by inversion Hnodupx | by inversion Hnodupy
            | by inversion Hsortx | by inversion Hsorty ].
revert Heq' Hnodupx Hnodupy Hsortx Hsorty
; generalize (M.elements (elt:=B.t) x) as x', (M.elements (elt:=B.t) y) as y'.
induction x'; [i; apply assoc_eq_nil_cond; by auto|].
induction y'
; [ i; apply assoc_eq_sym, assoc_eq_nil_cond
    ; [i; apply B.eq_sym; by apply Heq'|by auto] |].
i; destruct a as [k1 v1], a0 as [k2 v2].
destruct (B.eq_dec B.bot v2) as [Hv2|Hv2].
{ apply assoc_eq_bot1; [apply_inv IHy'|by auto].
  s; intros k0. specialize (Heq' k0); s in Heq'.
  destruct (A.eq_dec k0 k2); [|by rewrite (key_eqb_false n) in Heq'].
  rewrite (key_eqb_true e) in Heq'.
  rewrite noDup_findA_None with (k:=k2) (v:=v2) (x:=y')
  ; [|by apply A.eq_sym|by inversion Hnodupy].
  eapply B.eq_trans; [by apply Heq'|by apply B.eq_sym]. }
destruct (B.eq_dec B.bot v1) as [Hv1|Hv1].
{ apply assoc_eq_bot2; [apply_inv IHx'|by auto].
  s; intros k0. specialize (Heq' k0); s in Heq'.
  destruct (A.eq_dec k0 k1); [|by rewrite (key_eqb_false n) in Heq'].
  rewrite (key_eqb_true e) in Heq'.
  rewrite noDup_findA_None with (k:=k1) (v:=v1) (x:=x')
  ; [|by apply A.eq_sym|by inversion Hnodupy].
  eapply B.eq_trans; [by apply Hv1|by apply Heq']. }
{ destruct (A.compare k1 k2).
  - specialize (Heq' k1).
    rewrite findA_head in Heq'; [|by apply A.eq_refl].
    rewrite lt_findA_None in Heq'; [|by auto|by auto].
    elim Hv1; by apply B.eq_sym.
  - apply assoc_eq_cons; [|by auto| |by auto|by auto].
    + apply_inv IHx'.
      s; intros k0. specialize (Heq' k0); s in Heq'.
      destruct (A.eq_dec k0 k1).
      * rewrite noDup_findA_None with (k:=k1) (v:=v1) (x:=x')
        ; [|by apply A.eq_sym|by auto].
        rewrite noDup_findA_None with (k:=k2) (v:=v2) (x:=y')
        ; [|by apply A.eq_sym, A.eq_trans with k1|by auto].
        by apply B.eq_refl.
      * rewrite key_eqb_false in Heq'; [|by auto].
        rewrite key_eqb_false in Heq'; [by auto|].
        i; elim n. apply A.eq_trans with k2; [by auto|by apply A.eq_sym].
    + specialize (Heq' k1); s in Heq'.
      rewrite key_eqb_refl in Heq'.
      rewrite (key_eqb_true (k1:=k1) (k2:=k2)) in Heq'; [by auto|by auto].
  - specialize (Heq' k2).
    rewrite findA_head with (k':=k2) in Heq'; [|by apply A.eq_refl].
    rewrite lt_findA_None in Heq'; [|by auto|by auto].
    elim Hv2; by apply B.eq_sym. }
} Qed.

Lemma foldi2_2 :
  forall {T U : Type} (P : T -> U -> Prop)
     (f1 : A.t -> B.t -> T -> T) (f2 : A.t -> B.t -> U -> U)
     (Hf1 :
        forall k v acc1 acc2 (Hv : B.eq B.bot v) (Hacc : P acc1 acc2),
          P (f1 k v acc1) acc2)
     (Hf2 :
        forall k v acc1 acc2 (Hv : B.eq B.bot v) (Hacc : P acc1 acc2),
          P acc1 (f2 k v acc2))
     (Hf :
        forall k1 k2 v1 v2 acc1 acc2 (Hk : A.eq k1 k2) (Hv : B.eq v1 v2)
           (Hacc : P acc1 acc2),
          P (f1 k1 v1 acc1) (f2 k2 v2 acc2))
     i1 i2 (Hi : P i1 i2) m1 m2 (Heq : eq m1 m2),
    P (foldi f1 m1 i1) (foldi f2 m2 i2).
Proof.
unfold foldi; i. do 2 rewrite M.fold_1.
generalize i1, i2, Hi; clear i1 i2 Hi.
apply eq_assoc_eq in Heq. induction Heq.
- by auto.
- s; i. apply IHHeq. by apply Hf2.
- s; i. apply IHHeq. by apply Hf1.
- s; i. apply IHHeq. by apply Hf.
Qed.

Lemma foldi2_1 :
  forall {T : Type} (P : relation T) (f1 f2 : A.t -> B.t -> T -> T)
     (Hf1 :
        forall k v acc1 acc2 (Hv : B.eq B.bot v) (Hacc : P acc1 acc2),
          P (f1 k v acc1) acc2)
     (Hf2 :
        forall k v acc1 acc2 (Hv : B.eq B.bot v) (Hacc : P acc1 acc2),
          P acc1 (f2 k v acc2))
     (Hf :
        forall k1 k2 v1 v2 acc1 acc2 (Hk : A.eq k1 k2) (Hv : B.eq v1 v2)
           (Hacc : P acc1 acc2),
          P (f1 k1 v1 acc1) (f2 k2 v2 acc2))
     i1 i2 (Hi : P i1 i2) m1 m2 (Heq : eq m1 m2),
    P (foldi f1 m1 i1) (foldi f2 m2 i2).
Proof. i; by apply foldi2_2. Qed.

Lemma foldi2_3 T Q :
  forall (P : T -> Q -> Prop) f1 f2
     (Hf1 :
        forall k v acc1 acc2 (Hv : B.eq B.bot v) (Hacc : P acc1 acc2),
          P (f1 k v acc1) acc2)
     (Hf2 :
        forall k v acc1 acc2 (Hv : B.eq B.bot v) (Hacc : P acc1 acc2),
          P acc1 (f2 k v acc2))
     (Hf : forall k v acc1 acc2 (Hacc : P acc1 acc2), P (f1 k v acc1) (f2 k v acc2))
     m (i1 : T) (i2 : Q) (Hi : P i1 i2),
    P (foldi f1 m i1) (foldi f2 m i2).
Proof.
unfold foldi; i. do 2 rewrite M.fold_1.
generalize i1, i2, Hi; clear i1 i2 Hi.
induction (M.elements (elt:=B.t) m).
- by auto.
- s; i; apply IHl. by apply Hf.
Qed.

Lemma foldi_mor :
  forall {T : Type} (teq : relation T) (teq_equiv : equivalence T teq)
     (f : A.t -> B.t -> T -> T) (Hf : Proper (A.eq ==> B.eq ==> teq ==> teq) f)
     (Hf_bot : forall k v (Hv : B.eq B.bot v) acc, teq (f k v acc) acc),
    Proper (eq ==> teq ==> teq) (foldi f).
Proof.
i. intros m1 m2 Hm acc1 acc2 Hacc.
apply foldi2_1; [| | |by auto|by auto].
- i. eapply (equiv_trans _ _ teq_equiv); [by apply Hf_bot|by apply Hacc0].
- i. eapply (equiv_trans _ _ teq_equiv); [by apply Hacc0|].
  apply (equiv_sym _ _ teq_equiv). by apply Hf_bot.
- i. by apply Hf.
Qed.

Definition filter (f : A.t -> bool) (m : t) : t := M.filter f m.

Lemma filter_1 :
  forall k m cond (Hcond_mor : Proper (A.eq ==> Logic.eq) cond)
         (Hcond : cond k = true),
    B.eq (find k (filter cond m)) (find k m).
Proof.
unfold find, filter; s; i.
rewrite (M.filter_1); [by apply B.eq_refl|by auto|by auto].
Qed.

Lemma filter_2 :
  forall k m cond (Hcond_mor : Proper (A.eq ==> Logic.eq) cond)
         (Hcond : cond k = false),
    B.eq (find k (filter cond m)) B.bot.
Proof.
unfold find, filter; s; i.
rewrite (M.filter_2); [by apply B.eq_refl|by auto|by auto].
Qed.

Lemma filter_mor' :
  forall cond (Hcond_mor : Proper (A.eq ==> Logic.eq) cond),
    Proper (le ==> le) (filter cond).
Proof.
i; intros m1 m2 Hm; i; intro k.
remember (cond k) as b; destruct b.
- eapply B.le_trans; [apply B.le_refl; apply filter_1; by auto|].
  eapply B.le_trans; [by apply Hm|].
  apply B.le_refl; apply B.eq_sym; apply filter_1; by auto.
- eapply B.le_trans; [apply B.le_refl; apply filter_2; by auto|].
  apply B.le_refl; apply B.eq_sym; apply filter_2; by auto.
Qed.

Lemma filter_mor :
  forall cond (Hcond_mor : Proper (A.eq ==> Logic.eq) cond),
    Proper (eq ==> eq) (filter cond).
Proof.
i; intros m1 m2 Hm.
apply le_antisym.
- apply le_refl in Hm; by apply filter_mor'.
- apply eq_sym in Hm; apply le_refl in Hm; by apply filter_mor'.
Qed.

Lemma filter_le :
  forall cond x (Hmor : Proper (A.eq ==> Logic.eq) cond),
    le (filter cond x) x.
Proof.
i. intro k. remember (cond k) as b; destruct b.
- apply B.le_refl; by apply filter_1.
- apply B.le_trans with B.bot; [|by apply B.bot_prop].
  apply B.le_refl; by apply filter_2.
Qed.

Definition elements (m : t) : list (A.t * B.t) := M.elements m.

Definition cardinal (m : t) : Z := Zlength (M.elements m).

Fixpoint unstables (old_m new_m : t) (is_unstb : B.t -> B.t -> bool)
           (candidate : list A.t) : list (A.t * B.t * B.t) :=
  match candidate with
  | nil => nil
  | k :: tl =>
    let old_v := find k old_m in
    let new_v := find k new_m in
    if is_unstb old_v new_v then
      (k, old_v, new_v) :: unstables old_m new_m is_unstb tl
    else unstables old_m new_m is_unstb tl
  end.

Definition meet_big_small (x y : t) : t :=
  let iter1 k v := add k (B.meet (find k x) v) in
  foldi iter1 y y.

Lemma le_false :
  forall x y (Hle : ~(le x y)),
  exists k, M.In k x /\ ~(B.le (find k x) (find k y)).
Proof.
i; apply simple_le_dec_prop.
remember (for_all print2 (le_than y) x) as b; destruct b; [|by auto].
elim Hle. by auto using simple_le_dec.
Qed.

Definition strong_le (x y : t) : bool :=
  M.strong_le (fun x y => if B.le_dec x y then true else false) x y.

Lemma strong_le_1 (x y : t) (Hle : strong_le x y) : le x y.
Proof.
unfold le, strong_le in *; i; eapply M.strong_le_1 in Hle.
- elim Hle; i.
  + destruct H as [v1 [v2 [Hv1 [Hv2 He]]]].
    unfold find; rewrite Hv1; rewrite Hv2.
    destruct (B.le_dec v1 v2); [by done|discriminate].
  + unfold find; rewrite H; by apply B.bot_prop.
- i; destruct (B.le_dec v v); [done|].
  elim f; apply B.le_refl; by apply B.eq_refl.
Qed.

Definition opt_le x y :=
  if strong_le x y then true else
  if le_dec x y then true else
    false.

Lemma opt_le_prop :
  forall (x y : t) (Hstrong_le : opt_le x y = true), le x y.
Proof.
unfold opt_le; i.
remember (strong_le x y) as b; destruct b
; [by apply strong_le_1|by destruct (le_dec x y)].
Qed.

Definition strong_eq (x y : t) : bool := strong_le x y && strong_le y x.

Lemma strong_eq_1 (x y : t) (Heq : strong_eq x y) : eq x y.
Proof.
unfold strong_eq in Heq.
apply Bool.andb_true_iff in Heq. destruct Heq as [Heq1 Heq2].
apply le_antisym; by apply strong_le_1.
Qed.

End Map.


Require Import Bedrock.Examples.AutoSep.

(** * Always-0 *)

Definition always0S res : spec := SPEC reserving res
  PRE[_] Emp
  POST[R] [| R = 0 |].

Definition always0 := bmodule "always0" {{
  bfunction "main"("f") [always0S 2]
    "f" <-- Lambda() [always0S 0]
      Return 0
    end;;

    "f" <-- ICall "f"()
    [PRE[_, R] [| R = 0 |]
     POST[R'] [| R' = 0 |] ];;
    Return "f"
  end
}}.

Hint Extern 1 (@eq W _ _) => words.

Theorem always0Ok : moduleOk always0.
  vcgen; abstract (post; try icall (@nil string); (sep_auto; auto)).
Qed.

(** * Add three numbers *)

Definition add3S : spec := SPEC("x", "y", "z") reserving 5
  PRE[V] Emp
  POST[R] [| R = V "x" ^+ V "y" ^+ V "z" |].

Definition addS : spec := SPEC("x", "y") reserving 0
  PRE[V] Emp
  POST[R] [| R = V "x" ^+ V "y" |].

Definition add3 := bmodule "add3" {{
  bfunction "add3"("x", "y", "z", "f", "tmp") [add3S]
    "f" <-- Lambda("x", "y") [addS]
      Return "x" + "y"
    end;;

    "tmp" <-- ICall "f"("x", "y")
    [PRE[V, R] Emp
     POST[R'] [| R' = R ^+ V "z" |]];;

    Return "tmp" + "z"
  end
}}.

Theorem add3Ok : moduleOk add3.
  vcgen; abstract (post; try icall ("x" :: "y" :: nil); (sep_auto; auto)).
Qed.


Require Export P02.

Theorem nil_app : forall X:Type, forall l:list X,
  app [] l = l.
Proof.
  intros X l. reflexivity.
Qed.


(*
(C) Copyright 2010, COQTAIL team

Project Info: http://sourceforge.net/projects/coqtail/

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 2.1 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 GNU Lesser General Public
License for more details.

You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301,
USA.
*)

Require Import Lia.
Require Import Reals.
Require Import Rsequence_def.
Require Import Rsequence_base_facts.
Require Import Rsequence_cv_facts.
Require Import Rsequence_rel_facts.
Require Import Rsequence_rewrite_facts.
Require Import MyRIneq MyReals Lra.
(** printing ~	~ *)
(** * Convergence of usual sequences. *)

(* Convergence of INR *)

Lemma Rseq_cv_pos_infty_INR : Rseq_cv_pos_infty INR.
Proof.
intros M ; pose (n := up (Rabs M)) ; assert (n_pos : (0 <= n)%Z).
 apply le_0_IZR ; transitivity (Rabs M).
  apply Rabs_pos.
  left ; destruct (archimed (Rabs M)) ; assumption.
 destruct (IZN _ n_pos) as [N HN] ; exists N.
 intros m m_lb ; apply Rlt_le_trans with (INR N).
 apply Rle_lt_trans with (Rabs M) ; [apply Rle_abs |].
 rewrite INR_IZR_INZ, <- HN ; destruct (archimed (Rabs M)) ; assumption.
 apply le_INR ; assumption.
Qed.

Lemma Rseq_poly_shifts_equiv : forall d k, (Rseq_poly d) ~ (Rseq_shifts (Rseq_poly d) k).
Proof.
intros d k eps eps_pos.
 assert (lemma : Rseq_cv (fun n => 1 - (1 + INR k / INR n) ^ d)%R 0).
  rewrite <- (Rplus_opp_r 1) ; apply Rseq_cv_minus_compat.
   apply Rseq_constant_cv.
   rewrite <- (pow1 d) ; apply Rseq_cv_pow_compat ; rewrite pow1.
   rewrite <- (Rplus_0_r 1) ; apply Rseq_cv_plus_compat.
    rewrite Rplus_0_r ; apply Rseq_constant_cv.
   rewrite <- (Rmult_0_r (INR k)) ; apply Rseq_cv_mult_compat.
    apply Rseq_constant_cv.
   apply Rseq_cv_pos_infty_inv_compat, Rseq_cv_pos_infty_INR.
 destruct (lemma _ eps_pos) as [N HN] ; exists (S N) ; intros n n_lb.
  transitivity (Rabs (1 - (1 + INR k / INR n) ^ d) * Rabs (Rseq_poly d n)).
   right ; rewrite <- Rabs_mult ; apply Rabs_eq_compat ;
   unfold Rseq_poly, Rseq_minus, Rseq_shift ; ring_simplify.
   rewrite Rplus_comm, Ropp_mult_distr_l_reverse, <- Rpow_mult_distr.
   apply Rplus_eq_compat_l, Ropp_eq_compat, Rpow_eq_compat.
   rewrite plus_INR ; field ; apply not_0_INR ; lia.
  apply Rmult_le_compat_r ; [apply Rabs_pos |].
  rewrite <- (Rminus_0_r (1 - _)) ; left ; apply HN ; lia.
Qed.

Lemma Rseq_poly_shift_equiv : forall d,
  (Rseq_poly d) ~ (Rseq_shift (Rseq_poly d)).
Proof.
intros d ; eapply Rseq_equiv_eq_compat, Rseq_poly_shifts_equiv.
 reflexivity.
 eapply Rseq_eq_trans.
  apply Rseq_shifts_shift.
  apply Rseq_shifts_0.
Qed.

(** Convergence of polynomials. *)

(**********)
Lemma Rseq_poly_cv : forall d, (d > 0)%nat -> Rseq_cv_pos_infty (Rseq_poly d).
Proof.
intros d H M.
assert (Hm : forall n, Rseq_poly d n >= INR n).
unfold Rseq_poly; induction H; intros n.
simpl; lra.
eapply Rge_trans with (INR n * INR n)%R.
rewrite <- tech_pow_Rmult.
apply Rmult_ge_compat_l; [apply Rle_ge; apply pos_INR|apply IHle].
destruct n; auto with real.
destruct n; auto with real.
left; rewrite <- Rmult_1_r.
apply Rmult_gt_compat_l.
apply lt_0_INR; lia.
apply lt_1_INR; lia.
destruct (IZN (up (Rmax 0 (M + 1)))) as [N Hz].
apply le_0_IZR.
destruct (archimed (Rmax 0 (M + 1))) as [Hp _].
left; eapply Rle_lt_trans; [apply RmaxLess1|eexact Hp].
exists N; intros n Hn.
eapply Rlt_le_trans with (INR n); [|apply Rge_le; apply Hm].
eapply Rlt_le_trans with (INR N); [|apply le_INR; assumption].
rewrite INR_IZR_INZ; rewrite <- Hz.
destruct (archimed (Rmax 0 (M + 1))) as [Hp _].
eapply Rlt_trans; [|eexact Hp].
eapply Rlt_le_trans with (M + 1)%R; [lra|apply RmaxLess2].
Qed.

(** Convergence of power sequences. *)

(**********)
Lemma Rseq_pow_eq_1_cv : Rseq_cv (Rseq_pow 1) 1.
Proof.
intros eps Heps.
exists 1%nat; intros n Hn.
assert (He : Rseq_pow 1 n = 1).
clear Hn; induction n; simpl; try rewrite IHn; field.
rewrite He; rewrite R_dist_eq; assumption.
Qed.

(**********)
Lemma Rseq_pow_lt_1_cv : forall r, 0 <= r < 1 -> Rseq_cv (Rseq_pow r) 0.
intros r [Hl Hr] eps Heps.
unfold R_dist; unfold Rseq_pow.
assert (exists N, forall n, (n >= N)%nat -> Rabs (r ^ n) < eps).
apply pow_lt_1_zero; [rewrite Rabs_right|]; try apply Rle_ge; assumption.
destruct H as [N H].
exists N; intros n Hn.
rewrite Rminus_0_r.
apply H; assumption.
Qed.

Lemma Rseq_pow_abs_compat : forall r, Rseq_pow (Rabs r) == Rseq_abs (Rseq_pow r).
Proof.
intros r n ; unfold Rseq_pow, Rseq_abs ; apply RPow_abs.
Qed.

Lemma Rseq_pow_lt_1_cv_strong : forall r, Rabs r < 1 -> Rseq_cv (Rseq_pow r) 0.
intros r H eps eps_pos ;
 assert (Hx : 0 <= Rabs r < 1) by (split ; [apply Rabs_pos | assumption]) ;
 destruct (Rseq_pow_lt_1_cv _ Hx _ eps_pos) as [N HN] ; exists N ; intros n n_lb.
 eapply Rle_lt_trans ; [| eapply HN ; eassumption].
  right ; unfold R_dist, Rseq_pow ; do 2 rewrite Rminus_0_r, <- RPow_abs ;
  rewrite Rabs_Rabsolu ; reflexivity.
Qed.

(**********)
Lemma Rseq_pow_gt_1_cv : forall r, r > 1 -> Rseq_cv_pos_infty (Rseq_pow r).
Proof.
intros r Hr M.
unfold Rseq_pow.
destruct (Pow_x_infinity r) with (b := (M + 1)%R) as [N HN].
rewrite Rabs_right; lra.
exists N; intros n Hn.
rewrite <- Rabs_right.
eapply Rlt_le_trans with (M + 1)%R; [lra|].
apply Rge_le; apply HN; assumption.
left; apply pow_lt; lra.
Qed.

(** Convergence of factorial. *)

(**********)
Lemma Rseq_fact_cv : Rseq_cv_pos_infty Rseq_fact.
Proof.
intros M.
assert (forall n, (INR n) <= Rseq_fact n).
unfold Rseq_fact.
intros n; apply le_INR.
destruct n.
simpl; repeat constructor.
rewrite fact_simpl.
pattern (S n) at 1; rewrite <- mult_1_r.
apply mult_le_compat_l.
induction n.
simpl; constructor.
rewrite fact_simpl; pattern 1%nat; rewrite <- mult_1_r.
apply mult_le_compat; lia.
destruct (IZN (up (Rmax 0 (M + 1)))) as [N Hz].
apply le_0_IZR.
destruct (archimed (Rmax 0 (M + 1))) as [Hp _].
left; eapply Rle_lt_trans; [apply RmaxLess1|eexact Hp].
exists N; intros n Hn.
eapply Rlt_le_trans with (INR n); [|apply H].
eapply Rlt_le_trans with (INR N); [|apply le_INR; assumption].
rewrite INR_IZR_INZ; rewrite <- Hz.
destruct (archimed (Rmax 0 (M + 1))) as [Hp _].
eapply Rlt_trans; [|eexact Hp].
eapply Rlt_le_trans with (M + 1)%R; [lra|apply RmaxLess2].
Qed.

(** * Growth comparison. *)

(**********)
Lemma Rseq_poly_little_O : forall d1 d2, (d1 < d2)%nat -> (Rseq_poly d1) = o(Rseq_poly d2).
Proof.
intros d1 d2 Hd.
intros eps Heps.
unfold Rseq_poly.
pose (k := (d2 - d1)%nat).
assert (Hk : (k > 0)%nat); [unfold k; lia|].
assert (HM : exists N, forall n, (n >= N)%nat -> /eps < Rseq_poly k n).
apply Rseq_poly_cv; assumption.
destruct HM as [N HN].
exists N; intros n Hn.
replace d2 with (d1 + k)%nat by (unfold k; lia).
rewrite pow_add; rewrite Rabs_mult.
rewrite Rmult_comm.
rewrite Rmult_assoc.
pattern (Rabs (INR n ^ d1)) at 1; rewrite <- Rmult_1_r.
apply Rmult_le_compat_l; [apply Rabs_pos|].
rewrite <- (Rinv_l eps); [|apply Rgt_not_eq; assumption].
apply Rmult_le_compat_r; [lra|].
rewrite Rabs_right; [|apply Rle_ge; apply pow_le; apply pos_INR].
left; apply HN; assumption.
Qed.

(**********)
Lemma Rseq_inv_poly_little_O : forall d1 d2, (d1 < d2)%nat -> (Rseq_inv_poly d2) = o(Rseq_inv_poly d1).
Proof.
intros d1 d2 Hd.
eapply Rseq_little_O_asymptotic.
  intros Wn Xn H; eexact H.
exists 1%nat.
eapply Rseq_little_O_eq_compat
  with (Un := fun n => / (INR (S n) ^ d2)) (Vn := fun n => (/ INR (S n) ^ d1)).
intros n; unfold Rseq_inv_poly.
replace (1 + n)%nat with (S n) by lia.
rewrite Rinv_pow; [reflexivity|auto with real].
intros n; unfold Rseq_inv_poly.
replace (1 + n)%nat with (S n) by lia.
rewrite Rinv_pow; [reflexivity|auto with real].
apply Rseq_little_O_inv_contravar.
intros eps Heps.
destruct (Rseq_poly_little_O d1 d2 Hd eps Heps) as [N HN].
exists N; intros n Hn; apply HN; lia.
intros n; apply pow_nonzero; auto with real.
intros n; apply pow_nonzero; auto with real.
Qed.

(**********)
Lemma Rseq_pow_little_O : forall r1 r2, (0 <= r1 < r2) -> (Rseq_pow r1) = o(Rseq_pow r2).
Proof.
intros r1 r2 [Hp Hr] eps Heps.
pose (k := (r1 / r2)%R).
assert (Hkl : 0 <= k).
unfold k; unfold Rdiv; replace 0 with (0 * 0)%R by field.
apply Rmult_le_compat; try apply Rle_refl; try lra.
left; apply Rinv_0_lt_compat; eapply Rle_lt_trans; eassumption.
assert (Hkr : k < 1).
unfold k; unfold Rdiv.
rewrite <- (Rinv_r r2).
apply Rmult_lt_compat_r; [|assumption].
apply Rinv_0_lt_compat; eapply Rle_lt_trans; [eexact Hp|eexact Hr].
apply Rgt_not_eq; eapply Rle_lt_trans; [eexact Hp|eexact Hr].
unfold Rseq_pow.
assert (Hk : exists N, forall n, (n >= N)%nat -> Rabs (k ^ n) < eps).
apply pow_lt_1_zero; [rewrite Rabs_right|]; try apply Rle_ge; assumption.
destruct Hk as [N HN].
exists N; intros n Hn.
replace r1 with (k * r2)%R.
assert ((k * r2) ^ n = k ^ n * r2 ^ n)%R as ->; swap 1 2.
rewrite Rabs_mult.
apply Rmult_le_compat_r; [apply Rabs_pos|].
left; apply HN; apply Hn.
clear Hn HN; induction n; simpl; try rewrite IHn; field.
unfold k; field; apply Rgt_not_eq; eapply Rle_lt_trans; [eexact Hp|eexact Hr].
Qed.

(**********)
Lemma Rseq_poly_pow_gt_1_little_O : forall d r, r > 1 -> (Rseq_poly d) = o(Rseq_pow r).
Proof.
intros d r Hr.
pose (npow := (fix F m d := match d with O => 1 | S d => m * F m d end)%nat).
(* Lack of a lemma in stdlib *)
assert (Hpow : (forall x y n, pow (x * y) n = pow x n * pow y n)%R).
intros x y n; induction n.
simpl; rewrite Rmult_1_l; reflexivity.
repeat rewrite <- tech_pow_Rmult; rewrite IHn; field.
(* end of lemma *)
assert (Ho : forall k, Rseq_poly (npow 2%nat k) = o(Rseq_pow r)).
induction k; simpl.
(* Case k = 0 *)
set (x := (r - 1)%R).
assert (Hx : x > 0); [unfold x; lra|].
assert (Hdev : forall n, (2 <= n)%nat -> (1 + x) ^ n >= 1 + INR n * x + (INR n * (INR n - 1)) * /2 * x * x).
intros n H; induction H.
simpl; right; field.
rewrite <- tech_pow_Rmult.
eapply Rge_trans.
apply Rmult_ge_compat_l; [lra|apply IHle].
repeat rewrite S_INR.
field_simplify.
unfold Rdiv; apply Rmult_ge_compat_r; [lra|].
assert (HINR : 1 < INR m); [apply lt_1_INR; lia|].
rewrite <- Rplus_0_l.
unfold Rminus; repeat rewrite Rplus_assoc.
rewrite <- Rplus_assoc.
apply Rplus_ge_compat_r.
rewrite <- Ropp_mult_distr_r_reverse.
rewrite <- Rmult_plus_distr_l.
rewrite <- (Rmult_0_l 0).
apply Rmult_ge_compat; try lra.
apply Rle_ge; apply pow_le; lra.
simpl.
pattern (INR m) at 3; rewrite <- Rmult_1_r.
rewrite <- Ropp_mult_distr_r_reverse.
rewrite <- Rmult_plus_distr_l.
rewrite <- (Rmult_0_l 0).
apply Rmult_ge_compat; try lra.
assert (Hmin : forall n, (2 <= n)%nat -> r ^ n > (INR n * (INR n - 1) * / 2 * x * x)).
intros n Hd.
replace r with (1 + x)%R by (unfold x; field).
rewrite <- Rplus_0_l.
eapply Rlt_le_trans; [|apply Rge_le; apply Hdev; assumption].
apply Rplus_lt_compat_r.
assert (HINR: 0 <= INR n); [apply pos_INR; lia|].
pattern 0; rewrite <- Rplus_0_l.
apply Rplus_lt_le_compat; [lra|].
apply Rmult_le_pos; lra.
assert (HO : (Rseq_poly 2) = O(fun n => INR n * (INR n - 1) * / 2 * x * x)%R).
unfold Rseq_poly.
exists (INR 4 * / x * / x)%R; split.
  apply Rle_ge; rewrite <- (Rmult_0_r 0).
  rewrite Rmult_assoc.
  apply Rmult_le_compat; try apply Rle_refl.
  apply pos_INR.
  left; apply Rmult_lt_0_compat; apply Rinv_0_lt_compat; assumption.
  exists 2%nat; intros n Hn.
  repeat rewrite Rabs_mult.
  repeat rewrite Rabs_right; try lra.
  simpl; field_simplify; [|apply Rgt_not_eq; assumption].
  replace ((4 * INR n ^ 2 - 4 * INR n) / 2)%R
    with (INR n * (2 * (INR n - 1)))%R by field.
  replace (INR n ^ 2 / 1)%R with (INR n * INR n)%R by field.
  apply Rmult_le_compat_l; [apply pos_INR|].
  replace 1%R with (INR 1) by reflexivity.
  rewrite <- minus_INR; [|lia].
  change 2 with (INR 2).
  rewrite <- 2mult_INR.
  apply le_INR; lia.
  replace 1%R with (INR 1) by reflexivity.
  rewrite <- minus_INR; [apply Rle_ge; apply pos_INR|lia].
  apply Rle_ge; apply pos_INR.
  apply Rle_ge; apply pow_le; apply pos_INR.
assert (HO2 : (fun n => INR n * (INR n - 1) * / 2 * x * x)%R = O(Rseq_pow r)).
  exists 1; split; [lra|].
  exists 2%nat; intros n Hn.
  rewrite Rabs_right; [rewrite Rabs_right|].
  left; rewrite Rmult_1_l; apply Hmin; assumption.
  apply Rle_ge; apply pow_le; lra.
  apply Rle_ge; left; repeat apply Rmult_lt_0_compat; try lra.
  apply lt_0_INR; lia.
  replace 1 with (INR 1) by reflexivity; rewrite <- minus_INR; [|lia].
  apply lt_0_INR; lia.
eapply Rseq_little_O_big_O_trans.
  apply (Rseq_poly_little_O 1 2); lia.
  eapply Rseq_big_O_trans.
    apply HO.
    apply HO2.
(* Case k > 0 *)
set (kk := npow 2%nat k).
rewrite plus_0_r.
replace (kk + kk)%nat
  with (2 * kk)%nat by ring.
intros eps Heps.
destruct (IHk (/ Rabs (2 ^ kk) * sqrt eps * / sqrt r))%R as [N HN].
repeat apply Rmult_lt_0_compat.
apply Rinv_0_lt_compat; apply Rabs_pos_lt;
apply pow_nonzero; apply Rgt_not_eq; lra.
apply sqrt_lt_R0; lra.
apply Rinv_0_lt_compat; apply sqrt_lt_R0; lra.
exists (2 * N)%nat; intros n Hn.
unfold Rseq_poly; unfold Rseq_pow.
pose (m :=
  match Even.even_odd_dec n with
  | left evn => proj1_sig (Div2.even_2n n evn)
  | right odd => S (proj1_sig (Div2.odd_S2n n odd))
  end
).
assert (Hm : (n <= 2 * m /\ 2 * m <= S n)%nat).
destruct (Even.even_odd_dec n) as [Hm|Hm];
[destruct (Div2.even_2n n Hm) as [p Hp]|destruct (Div2.odd_S2n n Hm) as [p Hp]];
simpl in m; unfold Div2.double in Hp; unfold m; lia.
destruct Hm as [Hml Hmr].
apply Rle_trans with (Rabs (INR (2 * m) ^ (2 * kk))).
repeat rewrite Rabs_right.
apply pow_incr; split; [apply pos_INR|apply le_INR; assumption].
apply Rle_ge; apply pow_le; apply pos_INR.
apply Rle_ge; apply pow_le; apply pos_INR.
rewrite pow_Rsqr; rewrite mult_INR.
unfold Rsqr; repeat rewrite Hpow; repeat rewrite Rabs_mult; simpl.
eapply Rle_trans.
apply Rmult_le_compat.
replace 0 with (0 * 0)%R by field;
apply Rmult_le_compat; (apply Rle_refl || apply Rabs_pos).
replace 0 with (0 * 0)%R by field;
apply Rmult_le_compat; (apply Rle_refl || apply Rabs_pos).
change (1 + 1) with 2.
apply Rmult_le_compat_l; [apply Rabs_pos|]; apply HN; lia.
apply Rmult_le_compat_l; [apply Rabs_pos|]; apply HN; lia.
unfold Rseq_pow.
change (1 + 1) with 2.
field_simplify.
simpl; unfold Rdiv; repeat rewrite Rinv_1;
repeat rewrite Rmult_1_r.
rewrite sqrt_sqrt; [|lra].
rewrite sqrt_sqrt; [|lra].
rewrite Rmult_assoc.
apply Rmult_le_compat_l; [lra|].
pattern (/ r)%R at 1; rewrite <- Rabs_right; [|left; apply Rinv_0_lt_compat; lra].
repeat rewrite <- Rabs_mult.
rewrite <- pow_add.
repeat rewrite Rabs_right.
apply (Rmult_le_reg_l r); [lra|].
field_simplify.
unfold Rdiv; repeat rewrite Rinv_1; repeat rewrite Rmult_1_r.
rewrite tech_pow_Rmult.
apply Rle_pow; [lra|].
replace (m + m)%nat with (2 * m)%nat by ring; assumption.
apply Rgt_not_eq; lra.
apply Rle_ge; apply pow_le; lra.
replace 0 with (0 * 0)%R by field.
apply Rmult_ge_compat; try lra.
left; apply pow_lt; lra.
left; apply Rinv_0_lt_compat; lra.
split; apply Rgt_not_eq.
apply sqrt_lt_R0; lra.
apply Rabs_pos_lt; apply pow_nonzero; apply Rgt_not_eq; lra.
assert (Hp : (forall n, exists p, n < npow 2 p)%nat).
intros n.
destruct (zerop n) as [H|H].
exists 0%nat; simpl; lia.
induction H.
exists 1%nat; simpl; lia.
destruct IHle as [p Hp].
exists (S p); simpl; lia.
destruct (Hp d) as [dm Hdm].
apply Rseq_little_O_trans with (Rseq_poly (npow 2 dm)%nat).
apply Rseq_poly_little_O; assumption.
apply Ho.
Qed.

(**********)
Lemma Rseq_inv_poly_pow_lt_1_little_O : forall d r, 0 < r < 1 -> (Rseq_pow r) = o(Rseq_inv_poly d).
Proof.
intros d r [Hr1 Hr2].
eapply Rseq_little_O_asymptotic.
  intros Wn Xn H; eexact H.
exists 1%nat.
apply Rseq_little_O_eq_compat
  with (Un := fun n => / ((/ r) ^ (S n))) (Vn := fun n => (/ INR (S n) ^ d)).
intros n; unfold Rseq_pow.
replace (1 + n)%nat with (S n) by lia.
rewrite Rinv_pow; [|auto with real].
rewrite Rinv_involutive; [|auto with real].
reflexivity.
intros n; unfold Rseq_inv_poly.
replace (1 + n)%nat with (S n) by lia.
rewrite Rinv_pow; [|auto with real].
reflexivity.
apply Rseq_little_O_inv_contravar.
intros eps Heps.
destruct (Rseq_poly_pow_gt_1_little_O d (/ r)) with (eps := eps) as [N HN].
  rewrite <- Rinv_1.
  apply Rinv_lt_contravar.
  rewrite Rmult_1_r; assumption.
  assumption.
  assumption.
exists N; intros n Hn.
apply HN; lia.
intros n; apply pow_nonzero; auto with real.
intros n; apply pow_nonzero; auto with real.
Qed.

(**********)
Lemma Rseq_pow_fact_little_O : forall r, 0 <= r -> (Rseq_pow r) = o(Rseq_fact).
Proof.
assert (HO : forall n, Rseq_pow (INR n) = O(Rseq_fact)).
  intros n.
  assert (Hp: 0 <= INR n ^ n).
    apply pow_le; apply pos_INR.
  assert (Hf: / INR (fact n) > 0).
    apply Rinv_0_lt_compat.
    replace 0 with (INR 0) by reflexivity.
    apply lt_INR; apply lt_O_fact.
  exists (INR n ^ n / INR (fact n)); split.
    replace 0 with (0 * 0)%R by field.
    apply Rmult_ge_compat; try lra;
      try left; apply Hf.
  exists n; intros m Hm.
  induction Hm.
    rewrite Rabs_right; [|apply Rle_ge; apply Hp].
    rewrite Rabs_right; [|apply Rle_ge; apply pos_INR].
    right.
      unfold Rseq_pow; unfold Rseq_fact; field.
      apply Rgt_not_eq.
      replace 0 with (INR 0) by reflexivity.
      apply lt_INR; apply lt_O_fact.
    simpl; unfold Rseq_fact; rewrite fact_simpl.
    rewrite mult_INR.
    repeat rewrite Rabs_mult.
    set (K := INR n ^ n / INR (fact n)).
    replace (K * (Rabs (INR (S m)) * Rabs (INR (fact m))))
      with (Rabs (INR (S m)) * (K * (Rabs (INR (fact m)))))
      by field.
    apply Rmult_le_compat; try apply Rabs_pos.
    repeat rewrite Rabs_right; try (apply Rle_ge; apply pos_INR).
    apply le_INR; lia.
    apply IHHm.
intros r Hr.
destruct (IZN (up r)) as [d Hd].
  destruct (archimed r) as [H _].
  apply le_IZR.
  eapply Rle_trans.
    simpl; eexact Hr.
    left; eexact H.
apply Rseq_little_O_big_O_trans with (Rseq_pow (INR d)).
apply Rseq_pow_little_O; split.
  assumption.
  destruct (archimed r) as [H _].
  rewrite Hd in H.
  rewrite <- INR_IZR_INZ in H.
  exact H.
apply HO.
Qed.

(**********)
Lemma Rseq_poly_fact_little_O : forall d, Rseq_poly d = o(Rseq_fact).
Proof.
intros d.
eapply Rseq_little_O_trans.
apply Rseq_poly_pow_gt_1_little_O.
instantiate (1 := 2); lra.
apply Rseq_pow_fact_little_O; lra.
Qed.

(** * Things that don't have anything to do there... *)

(**********)
Lemma Rseq_ln_cv : Rseq_cv_pos_infty (fun n => ln (INR n)).
Proof.
intro m.
destruct (Rseq_poly_cv 1) with (M := Rabs m) as [N HN]; [lia|].
destruct (IZN(up (exp (INR N)))) as [N1 HN1].
  apply le_IZR; simpl.
  apply Rle_trans with (exp (INR N)).
    left; apply exp_pos.
  left; eapply (proj1 (archimed _)).
exists N1.
intros n Hn.
apply Rle_lt_trans with (Rabs m).
  apply RRle_abs.
apply Rlt_le_trans with (INR N).
  replace (INR N) with (INR N ^ 1) by field.
  apply (HN _ (le_refl _)).
rewrite <- ln_exp with (INR N).
left; apply ln_increasing.
  apply exp_pos.
apply Rlt_le_trans with (IZR (Z_of_nat N1)).
  rewrite <- HN1.
  apply (proj1(archimed _)).
rewrite <- INR_IZR_INZ; apply le_INR; apply Hn.
Qed.


(*
 * Lemmas on bisimulation equivalence
 *)

Section Bisimulation.

Parameters Config Config' : Set.
Parameter moveA : Config -> Config -> Prop.
Parameter moveA' : Config' -> Config' -> Prop.

Parameter config_R_config' : Config -> Config' -> Prop.

Inductive star {A : Type} (p : A -> A -> Prop)
  : A -> A -> Prop :=
  | star_ref : forall c, star p c c
  | star_tran : forall c1 c2 c3,
    p c1 c2 -> star p c2 c3 -> star p c1 c3.

Parameter AccA : Config -> Prop.
Parameter AccA' : Config' -> Prop.

Definition LA (c : Config) : Prop :=
  exists cf, AccA cf /\ star moveA c cf.
Definition LA' (c : Config') : Prop :=
  exists cf, AccA' cf /\ star moveA' c cf.

Hypothesis bisimilar_1 :
  forall (c1 c2 : Config) (c'1 : Config'),
    moveA c1 c2 -> config_R_config' c1 c'1 ->
  exists c'2,
    moveA' c'1 c'2 /\ config_R_config' c2 c'2.
Hypothesis bisimilar_2 :
  forall (c1 : Config) (c'1 c'2 : Config'),
    moveA' c'1 c'2 -> config_R_config' c1 c'1 ->
  exists c2,
    moveA c1 c2 /\ config_R_config' c2 c'2.

Hypothesis bisimilar_3 :
  forall c c',
  config_R_config' c c' -> AccA c <-> AccA' c'.

Lemma bisimilar_implies_same_lang :
  forall c c',
  config_R_config' c c' ->
  LA c <-> LA' c'.
Proof.
  intros c c' HR.
  unfold LA.
  unfold LA'.
  split.
  - (* -> *)
  intros [cf [Hcf Hsm]].
  generalize dependent c'.
  induction Hsm as [c | c c2 c3 Hm Hsm IH].
  + intros c' HR.
  apply (bisimilar_3 c c' HR) in Hcf.
  exists c'; split; auto.
  apply star_ref.
  + intros c' HR.
  apply (bisimilar_1 c c2 c' Hm) in HR.
  destruct HR as [c'2 [HmA' HR']].
  assert (IH' := IH Hcf c'2 HR').
  destruct IH' as [cf' [Hcf' Hsm']].
  exists cf'; split; auto.
  now apply star_tran with c'2.
  - (* <- *)
  intros [cf' [Hcf' Hsm']].
  generalize dependent c.
  induction Hsm' as [c' | c' c'2 c'3 Hm' Hsm' IH].
  + intros c HR.
  apply (bisimilar_3 c c' HR) in Hcf'.
  exists c; split; auto.
  apply star_ref.
  + intros c HR.
  apply (bisimilar_2 c c' c'2 Hm') in HR.
  destruct HR as [c2 [HmA HR']].
  assert (IH' := IH Hcf' c2 HR').
  destruct IH' as [cf [Hcf Hsm]].
  exists cf; split; auto.
  now apply star_tran with c2.
Qed.

End Bisimulation.


Require Import Iron.Language.SystemF2Cap.Value.Relation.TyJudge.

(* Uniqueness of typing.
   Checking an expression always returns a unique type an effect. *)
Lemma typex_unique
 :  forall ke te se sp x t1 e1 t2 e2
 ,  TypeX  ke te se sp x t1 e1
 -> TypeX  ke te se sp x t2 e2
 -> t1 = t2 /\ e1 = e2.
Proof.
 intros. gen ke te se sp t1 e1 t2 e2.
 induction x using exp_mutind with
  (PV := fun v1 => forall ke te se sp t1 t1'
      ,  TypeV ke te se sp v1 t1
      -> TypeV ke te se sp v1 t1'
      -> t1 = t1');
  intros;
   try (solve [inverts_type; try congruence]);
   inverts_type; auto.

 - Case "VBox".
   spec IHx H6 H5.
   rip.

 - Case "VLam".
   spec IHx H9 H10.
   burn.

 - Case "VLAM".
   spec IHx H8 H7.
   burn.

 - Case "XVal".
   spec IHx H6 H5.
   burn.

 - Case "XLet".
   spec IHx1 H11 H13.
   spec IHx2 H12 H14.
   rip.

 - Case "XApp".
   spec IHx  H7  H6.
   spec IHx0 H10 H11.
   subst. inverts IHx. auto.

 - Case "VAPP".
   spec IHx H7 H6.
   inverts IHx. auto.

 - Case "XOp1".
   spec IHx H10 H11.
   subst.
   rip; congruence.

 - Case "XPrivate".
   spec IHx H12 H15.
   rip; congruence.

 - Case "XExtend".
   spec IHx H11 H13.
   rip; congruence.

 - Case "XBox".
   spec IHx H6 H5.
   rip; congruence.

 - Case "XAlloc".
   spec IHx H10 H11.
   subst. burn.

 - Case "XRead".
   spec IHx H10 H11.
   inverts IHx. auto.
Qed.


Require Import HoTT.
Require Import HoTT.Categories.Functor.
From GR.bicategories Require Import
     general_category
     bicategory.bicategory_laws
     bicategory.strict
     bicategory.adjoint.

Class LocallyUnivalent (C : BiCategory)
  := locally_univalent :> forall (X Y : C), IsCategory (C⟦X,Y⟧).

Global Instance ishprop_LocallyUnivalent `{Funext} (C : BiCategory)
  : IsHProp (LocallyUnivalent C).
Proof.
  unfold LocallyUnivalent.
  apply _.
Defined.

Class Univalent_0 `{Funext} (C : BiCategory)
  := univalent_0 :> forall (X Y : C), IsEquiv(id_to_adjequiv X Y).

Notation adjequiv_to_id X Y e := ((id_to_adjequiv X Y)^-1%function e).

Global Instance ishprop_Univalent_0 `{Funext} (C : BiCategory)
  : IsHProp (Univalent_0 C).
Proof.
  unfold Univalent_0.
  apply _.
Defined.

Class Univalent `{Funext} (C : BiCategory)
  := { Univalent_Univalent_0 :> Univalent_0 C;
       Univalent_LocallyUnivalent :> LocallyUnivalent C }.

Global Instance univalent_hprop `{Funext} (C : BiCategory)
  : IsHProp (Univalent C).
Proof.
  apply hprop_allpath.
  intros x y.
  destruct x as [x1 x2], y as [y1 y2].
  assert (x1 = y1) as ->.
  { apply path_ishprop. }
  assert (x2 = y2) as ->.
  { apply path_ishprop. }
  reflexivity.
Defined.

Global Instance hom_locally_univalent_cat
       `{Univalence}
       {C : BiCategory}
       {UC : LocallyUnivalent C}
       (X Y : C)
  : IsTrunc 1 (C⟦X,Y⟧)
  := _.

Global Instance obj_univalent_cat
       `{Univalence}
       (C : BiCategory)
       `{Univalent C}
  : IsTrunc 2 C.
Proof.
  intros X Y.
  rewrite (path_universe (id_to_adjequiv X Y)).
  apply _.
Defined.

Definition whisker_l_functor
           {C : BiCategory}
           `{LocallyUnivalent C}
           {Y Z : C}
           (X : C)
           (g : C⟦Y,Z⟧)
  : Functor (C⟦X,Y⟧) (C⟦X,Z⟧).
Proof.
  simple refine (Build_Functor _ _ _ _ _ _).
  - exact (fun f => g · f).
  - intros ? ? q.
    exact (g ◅ q).
  - intros ; cbn.
    apply bc_whisker_l_compose.
  - intros ; cbn.
    apply hcomp_id₂.
Defined.

Definition transport_whisker_l
           `{Funext}
           {C : BiCategory}
           `{LocallyUnivalent C}
           {X Y Z : C}
           (g : C⟦Y,Z⟧)
           {f₁ f₂ : C⟦X,Y⟧}
           (q : f₁ ==> f₂)
           `{IsIsomorphism _ _ _ q}
  : ap (fun z => g · z) (isotoid (C⟦X,Y⟧) f₁ f₂ {| morphism_isomorphic := q|})
    =
    isotoid (C⟦X,Z⟧) (g · f₁) (g · f₂) {|morphism_isomorphic := g ◅ q|}.
Proof.
  symmetry.
  rewrite <- (eissect (@Category.idtoiso (C⟦X,Z⟧) (g · f₁) (g · f₂))).
  f_ap.
  simple refine (path_isomorphic _ _ _).
  rewrite <- (idtoiso_functor _ (whisker_l_functor X g)) ; cbn.
  rewrite eisretr.
  reflexivity.
Defined.

Definition whisker_r_functor
           {C : BiCategory}
           `{LocallyUnivalent C}
           {X Y : C}
           (Z : C)
           (g : C⟦X,Y⟧)
  : Functor (C⟦Y,Z⟧) (C⟦X,Z⟧).
Proof.
  simple refine (Build_Functor _ _ _ _ _ _).
  - exact (fun f => f · g).
  - intros ? ? q ; cbn.
    exact (q ▻ g).
  - intros ; cbn.
    apply bc_whisker_r_compose.
  - intros ; cbn.
    apply hcomp_id₂.
Defined.

Definition transport_whisker_r
           `{Funext}
           {C : BiCategory}
           `{LocallyUnivalent C}
           {X Y Z : C}
           (g : C⟦X,Y⟧)
           {f₁ f₂ : C⟦Y,Z⟧}
           (q : f₁ ==> f₂)
           `{IsIsomorphism _ _ _ q}
  : ap (fun z => z · g) (isotoid (C⟦Y,Z⟧) f₁ f₂ {| morphism_isomorphic := q|})
    =
    isotoid (C⟦X,Z⟧) (f₁ · g) (f₂ · g) {|morphism_isomorphic := q ▻ g|}.
Proof.
  symmetry.
  rewrite <- (eissect (@Category.idtoiso (C⟦X,Z⟧) (f₁ · g) (f₂ · g))).
  f_ap.
  simple refine (path_isomorphic _ _ _).
  rewrite <- (idtoiso_functor _ (whisker_r_functor Z g)) ; cbn.
  rewrite eisretr.
  reflexivity.
Defined.

Definition isotoid_compose
           {C : PreCategory}
           {X Y Z : C}
           (f : (X <~=~> Y)%category) (g : (Y <~=~> Z)%category)
           `{IsCategory C}
  : isotoid C X Z (isomorphic_trans f g)
    =
    isotoid C X Y f @ isotoid C Y Z g.
Proof.
  rewrite <- (eissect (@Category.Morphisms.idtoiso C X Z)).
  f_ap.
  apply path_isomorphic.
  rewrite <- idtoiso_comp.
  rewrite !eisretr ; simpl.
  reflexivity.
Qed.

Definition locally_univalent_to_strict
           `{Univalence}
           (C : BiCategory)
           `{LocallyUnivalent C}
  : IsStrict C.
Proof.
  make_strict.
  - intros X Y f.
    apply (isotoid (C⟦X,Y⟧) _ _).
    exact {| morphism_isomorphic := left_unit f |}.
  - intros X Y f.
    apply (isotoid (C⟦X,Y⟧) _ _).
    exact {| morphism_isomorphic := right_unit f |}.
  - intros W X Y Z h g f.
    apply (isotoid (C⟦W,Z⟧) _ _).
    exact {| morphism_isomorphic := assoc h g f |}.
  - intros X Y Z g f ; simpl.
    rewrite transport_whisker_l, transport_whisker_r.
    rewrite <- isotoid_compose.
    f_ap.
    apply path_isomorphic ; cbn.
    apply triangle_r.
  - intros V W X Y Z k h g f.
    rewrite transport_whisker_l, transport_whisker_r.
    unfold strict_assoc.
    rewrite <- !isotoid_compose.
    f_ap.
    apply path_isomorphic ; cbn.
    apply pentagon.
  - intros X Y f ; cbn.
    rewrite eisretr.
    reflexivity.
  - intros X Y f ; cbn.
    rewrite eisretr.
    reflexivity.
  - intros W X Y Z h g f.
    rewrite eisretr.
    reflexivity.
Qed.

Global Instance is_hprop_isstrict_locally_univalent
       `{Univalence}
       (C : BiCategory)
       `{LocallyUnivalent C}
  : IsHProp (IsStrict C).
Proof.
  apply hprop_allpath.
  intros S₁ S₂.
  destruct S₁ as [S₁l S₁r S₁a S₁t S₁p S₁il S₁ir S₁ia].
  destruct S₂ as [S₂l S₂r S₂a S₂t S₂p S₂il S₂ir S₂ia].
  assert (S₁l = S₂l) as ->.
  {
    funext X Y f.
    rewrite <- (eissect (@idtoiso (C⟦X,Y⟧) _ _) (S₁l X Y f)).
    rewrite <- (eissect (@idtoiso (C⟦X,Y⟧) _ _) (S₂l X Y f)).
    f_ap.
    apply path_isomorphic.
    rewrite S₁il, S₂il.
    reflexivity.
  }
  assert (S₁r = S₂r) as ->.
  {
    funext X Y f.
    rewrite <- (eissect (@idtoiso (C⟦X,Y⟧) _ _) (S₁r X Y f)).
    rewrite <- (eissect (@idtoiso (C⟦X,Y⟧) _ _) (S₂r X Y f)).
    f_ap.
    apply path_isomorphic.
    rewrite S₁ir, S₂ir.
    reflexivity.
  }
  assert (S₁a = S₂a) as ->.
  {
    funext W X Y Z f g ; funext h.
    rewrite <- (eissect (@idtoiso (C⟦W,Z⟧) _ _) (S₁a W X Y Z f g h)).
    rewrite <- (eissect (@idtoiso (C⟦W,Z⟧) _ _) (S₂a W X Y Z f g h)).
    f_ap.
    apply path_isomorphic.
    rewrite S₁ia, S₂ia.
    reflexivity.
  }
  assert (S₁t = S₂t) as ->.
  {
    apply path_ishprop.
  }
  assert (S₁p = S₂p) as ->.
  {
    apply path_ishprop.
  }
  assert (S₁il = S₂il) as ->.
  {
    apply path_ishprop.
  }
  assert (S₁ir = S₂ir) as ->.
  {
    apply path_ishprop.
  }
  assert (S₁ia = S₂ia) as ->.
  {
    apply path_ishprop.
  }
  reflexivity.
Qed.


Set Implicit Arguments.

Require Import List.
Require Import sha.ByteBitRelations. (*For InBlocks*)
Require Import sha.HMAC_common_defs.
Require Import sha.HMAC_spec_pad.

(*Parameter c:nat.
Parameter p:nat.
Parameter b:nat.*)

Module HMAC_Concat.
Section HMAC.
  Variable c:nat.
  Variable p:nat.
  Definition b := (c+p)%nat.
  Variable B: (0<b)%nat.

  (* The compression function *)
  Variable h : Blist -> Blist -> Blist.

  (* The initialization vector is part of the spec of the hash function. *)
  Variable iv : Blist.

  (* The iteration of the compression function gives a keyed hash function on lists of words. *)
  Definition h_star k (m : Blist) :=
    hash_blocks_bits b B h k m.

  (* The composition of the keyed hash function with the IV.*)
  Definition hash_words := h_star iv.

  (* splitAndPad concat'ed, normal fold replaced by firstn/splitn manual fold *)
  Variable splitAndPad : Blist -> Blist.

  (* fpad can be a constant *)
  Variable fpad : Blist -> Blist.
  Definition app_fpad (x : Blist) : Blist :=
    x ++ fpad x.

  Definition h_star_pad k x :=
    app_fpad (h_star k x).

  (* The "two-key" version of GHMAC and HMAC. *)
  Definition GHMAC_2K (k : Blist) m :=
    let (k_Out, k_In) := splitList b k in
      let h_in := (hash_words (k_In ++ m)) in
        hash_words (k_Out ++ app_fpad h_in).

  Definition HMAC_2K (k : Blist) (m : Blist) :=
    GHMAC_2K k (splitAndPad m).

  (* opad and ipad are constants defined in the HMAC spec. *)
  Variable opad ipad : Blist.

  Definition HMAC (k : Blist) :=
    HMAC_2K (BLxor k opad ++ BLxor k ipad).

  (*The following hypotheses and constructions from the abstract spec
    do not need to be enforced/repeated here

  Hypothesis splitAndPad_1_1 :
    forall b1 b2,
      splitAndPad b1 = splitAndPad b2 -> b1 = b2.

  Definition GNMAC k m :=
    let (k_Out, k_In) := splitList c k in
    h k_Out (app_fpad (h_star k_In m)).

  Hypothesis opad_ne_ipad : opad <> ipad.

  Definition GHMAC (k : Blist) :=
    GHMAC_2K (BLxor k opad ++ BLxor k ipad).
  *)

End HMAC.

Lemma h_star_eq :
  sha.HMAC_spec_pad.h_star = h_star.
Proof. reflexivity. Qed.

Theorem HMAC_concat_pad c p (C: NPeano.Nat.divide 8 c) B sap sap' fp
        (sap_sap': forall l m, length l = (c+p)%nat ->
                          sap (l ++ m) = l ++ sap' m)
        (sap_appfpad: forall (l m : Blist),
                  length l = (c+p)%nat ->
                  InBlocks 8 m ->
                  sap (l ++ m) = l ++ app_fpad fp m)
        (InBlocks_sap': forall m, InBlocks (c+p)%nat (sap' m))
        h (HH: forall x y, length x = c -> length y = (c+p)%nat -> length (h x y)  = c)
        iv (IV: length iv = c) (op ip : Blist) (IL: length ip = (c+p)%nat) (OL: length op = (c+p)%nat)
        : forall (k m : Blist), length k = (c+p)%nat ->
  sha.HMAC_spec_pad.HMAC c p B h iv sap op ip k m =
  HMAC_Concat.HMAC c p B h iv sap' fp op ip k m.
Proof.
  intros k m len_k.
  unfold sha.HMAC_spec_pad.HMAC. unfold HMAC.
  unfold sha.HMAC_spec_pad.HMAC_2K. unfold HMAC_2K.
  unfold sha.HMAC_spec_pad.GHMAC_2K. unfold GHMAC_2K.

  repeat rewrite -> split_append_id; try apply BLxor_length; trivial.
  unfold sha.HMAC_spec_pad.hash_words_padded. unfold Basics.compose.
  unfold hash_words.
  unfold sha.HMAC_spec_pad.hash_words.
  rewrite -> h_star_eq.
  f_equal.

  rewrite <- sap_sap'; try apply BLxor_length; trivial.
  rewrite <- sap_appfpad; try apply BLxor_length; trivial.

  unfold HMAC_Concat.h_star.
    apply InBlocks_len.
    erewrite hash_blocks_bits_len; try eassumption.
      (*exists (32%nat); reflexivity.*)
      rewrite sap_sap'.
               econstructor.
                 2: reflexivity.
                 apply BLxor_length; trivial.
                 apply InBlocks_sap'.
                 apply BLxor_length; trivial.
Qed.

End HMAC_Concat.


Require Import generic_soundness.

Require Import reduction.

Require Import proofsystem.
Set Implicit Arguments.

Require Import Setoid.
Require Import Relation_Definitions.

(* For all-path reachability,
   the approximation is indexed by a number of steps, and says that
   every path which terminates within the bound encountered a state
   matching the target state.
 *)

Parameter cfg : Set.
Parameter SF : cfg -> cfg -> Prop.

(* Lemmas *)
Definition nat_pred n n' := n = 1+n'.
Lemma le_iff_clos_nat_pred : forall n m,
                               clos nat_pred false n m <-> m <= n.
Proof.
split.
induction 1.
auto.
unfold nat_pred in H;subst. auto.
eauto with arith.

induction 1.
constructor.
apply clos_trans with m0.
apply clos_step. reflexivity.
assumption.
Qed.

Lemma nat_le_ind : forall (P : nat -> Prop), forall n,
  (forall n0, n0 <= n ->
              (forall n', n0 = 1+n' -> P n') ->
              P n0)
  -> P n.
induction n.
intro H; apply H. constructor. intros. discriminate.
intro H.
apply H.
constructor.
intros.
injection H0;clear H0;intro H0.
subst n'.
auto.
Qed.

Inductive ix_al_reach (P : cfg -> Prop) (c : cfg) : bool -> nat -> Prop :=
  | al_exhausted : forall s, ix_al_reach P c s 0
  | al_here : P c -> forall n, ix_al_reach P c false n
  | al_later : forall n, (exists c', SF c c') ->
                         (forall c', SF c c' -> ix_al_reach P c' false n) ->
                         forall s, ix_al_reach P c s (Datatypes.S n)
  .

Lemma al_reach_unstrict P c n : ix_al_reach P c true n -> ix_al_reach P c false n.
Proof. destruct 1;constructor (assumption). Qed.

Lemma al_reach_pred P c s n : ix_al_reach P c s (S n) -> ix_al_reach P c s n.
remember (S n) as Sn eqn:HeqSn; intro H; revert n HeqSn; induction H.
(* exhausted *)
discriminate.
(* here *)
constructor (assumption).
(* later *)
intros.
injection HeqSn;clear HeqSn;intro HeqSn.
destruct n0;constructor(auto).
Qed.

Lemma al_reach_impl (P Q : cfg -> Prop) : (forall c, P c -> Q c) -> forall c s n,
                            ix_al_reach P c s n -> ix_al_reach Q c s n.
induction 2;constructor(auto).
Qed.

Require Import Arith.

Lemma min_half_suc (P : nat -> Prop) n m :
  P (S (min n m)) -> P (min n m) -> P (min (S n) m).
Proof.
  destruct (le_lt_dec m n);
  rewrite ?Min.min_r, ?Min.min_l by (auto using le_S, le_Sn_le);
  trivial.
Qed.

Lemma al_reach_join P c s1 n1 s2 n2 :
  ix_al_reach (fun c' => ix_al_reach P c' s2 n2) c s1 n1
  -> ix_al_reach P c s1 (min n1 (if s1 then S n2 else n2)).
induction 1.
+ (* Exhausted *)
  rewrite Min.min_0_l.
  constructor.
+ (* Here *)
  assert (min n n2 <= n2) by auto with arith.
  revert H0; generalize (min n n2); intros n0 Hle.
  induction Hle.
  destruct s2;auto using al_reach_unstrict.
  auto using al_reach_pred.
+ (* Later *)
  assert (ix_al_reach P c s (S (min n n2))) as IH by constructor (assumption).
  clear -IH.
  destruct s.
  assumption.
  pose proof (al_reach_pred IH).
  apply min_half_suc; assumption.
Qed.

Module AllPathSemantics <: ReachabilitySemantics.

(* Definitions *)
Definition index : Set := nat.
Definition ix_rel (i1 i2 : index) : Prop := (i1 = S i2).

Definition holds strict env (phi1 phi2 : formula cfg env) i :=
  forall rho gamma, phi1 rho gamma -> ix_al_reach (phi2 rho) gamma strict i.

(* Nontrivial proofs *)
(** Circularity **)
Lemma ix_rel_ind : forall env (phi phi' : formula cfg env),
      forall i0,
      (forall i, clos ix_rel false i0 i ->
                   (forall i', ix_rel i i' -> holds true phi phi' i') ->
                   holds true phi phi' i)
       -> holds true phi phi' i0.
intros.
apply nat_le_ind.
intros.
rewrite <- le_iff_clos_nat_pred in H0.
auto.
Qed.

Create HintDb holds_solve discriminated.
Hint Transparent holds : holds_solve.
Hint Unfold holds : holds_solve.

Hint Resolve al_here al_exhausted : holds_solve.
(* Hint Resolve al_reach_pred al_reach_unstrict : holds_solve. *)

Ltac holds_start := unfold index;intros;
  repeat match goal with
  | [|- holds _ _ _ _] => unfold holds;intros
  | [H : ix_rel ?l _ |- _] => unfold ix_rel in H;rewrite H in * |- *;clear H;clear l
  (* Use holds hypotheses *)
  | [H : holds _ ?phi _ _, Hphi : ?phi _ ?gamma |- _]=> specialize (H _ _ Hphi)
  | [H : forall _ _, ?phi _ _ -> _, Hphi : ?phi _ _ |- _] =>
    specialize (H _ _ Hphi)
  end.
(*
Ltac holds_start := intros;
  repeat match goal with
  (* open unnecessary uses of holds/indices *)
  | [i : index |- _] => destruct i
  | [H : holds _ _ _ (exist _ _ _) |- _] => unfold holds in H;simpl proj1_sig in H
  | [|- holds _ _ _ (exist _ _ _)] => unfold holds;simpl proj1_sig;unfold holds';intros
  | [H : ix_rel (exist _ _ _) _ |- _] => unfold ix_rel in H; simpl proj1_sig in H
  | [H : ix_rel _ (exist _ _ _) |- _] => unfold ix_rel in H; simpl proj1_sig in H
  (* Instantate a hypothesis quantified over ix_rel, as appears in strict trans *)
  | [H : forall i', ix_rel (exist _ ?x ?t) i' -> holds _ ?phi _ i',
       Hphi : ?phi _ ?x0 |- _ ] =>
    let Hprog := fresh "Hprog" in
    assert (clos S true x x0) as Hprog by clos_solve;
    let x1 := fresh "x1" with Hstep := fresh "Hstep" with Hreach := fresh "Hreach" in
    apply clos_true_step in Hprog; destruct Hprog as [x1 [Hstep Hreach]];
    specialize (H (exist _ x1 (terminates_next t _ Hstep)) Hstep)
  (* Use holds' hypotheses *)
  | [H : holds' _ ?phi _ ?x, Hphi : ?phi _ ?gamma |- _]=>
    let Hreach := fresh "Hreach" in
    assert (clos S false x gamma) as Hreach by clos_solve;
    specialize (H _ _ Hreach Hphi)
  | [H : exists _, clos S _ _ _ /\ _ |- _] => destruct H as [? []]
  end.
*)
Ltac holds_finish :=
  solve[auto with holds_solve
       |intuition
          (repeat match goal with
             | [H : forall _ _, ?phi _ _ -> _, Hphi : ?phi _ _ |- _] =>
               specialize (H _ _ Hphi)
           end;firstorder with holds_solve)
       ].
Ltac holds_finish' lem :=
  solve[eauto using lem with holds_solve
       |intuition
          (repeat match goal with
             | [H : forall _ _, ?phi _ _ -> _, Hphi : ?phi _ _ |- _] =>
               specialize (H _ _ Hphi)
           end;firstorder using lem with holds_solve)
       ].

Ltac holds_tac := holds_start;holds_finish.

(* Simple properties *)
Lemma holds_strict_later : forall env phi1 phi2 i,
                             @holds true env phi1 phi2 i ->
                             forall i', ix_rel i i' ->
                                        holds true phi1 phi2 i'.
holds_start. holds_finish' al_reach_pred.
Qed.

Lemma holds_unstrict : forall env phi1 phi2 i,
                         @holds true env phi1 phi2 i -> holds false phi1 phi2 i.
holds_start. holds_finish' al_reach_unstrict.
Qed.

Lemma holds_step : forall env (phi phi' : formula cfg env),
    (forall (e : env) (c : cfg),
      phi e c ->
      (exists c2 : cfg, SF c c2) /\ (forall c2 : cfg, SF c c2 -> phi' e c2)) ->
    forall i, holds true phi phi' i.
holds_start.
destruct H.
apply al_reach_pred;apply al_later;eauto with holds_solve.
Qed.

Lemma holds_refl : forall env phi i, @holds false env phi phi i.
holds_tac.
Qed.

Lemma holds_case :
    forall strict env (phi phi1 phi' : formula cfg env) i,
      holds strict phi phi' i -> holds strict phi1 phi' i ->
      holds strict (fun (e : env) (g : cfg) => phi e g \/ phi1 e g) phi' i.
holds_tac.
Qed.

Lemma holds_mut_conseq :
    forall strict env1 (phi1 phi2 : formula cfg env1)
                  env2 (phi1' phi2' : formula cfg env2),
     (forall gamma rho,
        phi1 rho gamma ->
        exists rho', phi1' rho' gamma /\
                     forall gamma', phi2' rho' gamma' -> phi2 rho gamma') ->
    forall i, holds strict phi1' phi2' i ->
              holds strict phi1 phi2 i.
holds_start;holds_finish' al_reach_impl.
Qed.

(** Transitivity **)
Lemma holds_trans : forall env phi phi' phi'' i,
    @holds false env phi phi' i ->
    holds false phi' phi'' i ->
    holds false phi phi'' i.
holds_start.
unfold holds in H0.
apply (al_reach_impl _ (H0 rho)) in H.
clear -H.
apply al_reach_join in H.
rewrite Min.min_idempotent in H;assumption.
Qed.

Lemma holds_trans_strict : forall env phi phi' phi'' i,
    @holds true env phi phi' i ->
    (forall i' : index, ix_rel i i' -> holds false phi' phi'' i') ->
   holds true phi phi'' i.
holds_start.
destruct i.
constructor.
apply (al_reach_impl _ (H0 _ (eq_refl _) rho)) in H.
clear -H.
apply al_reach_join in H.
rewrite Min.min_idempotent in H;assumption.
Qed.

Definition cfg := cfg.
Definition S := SF.

End AllPathSemantics.

Module AllPathSoundness := Soundness AllPathSemantics.

(* Now, define two versions of full soundness and show equivalences *)
(* We'll end up using some assumptions about decidability of
   stuckness and matching to show equivalence of tree- and path-based
   properties *)

Inductive closed_path (start : cfg) : Set :=
  | path_end : ~(exists c', SF start c') -> closed_path start
  | path_step : forall c', SF start c' -> closed_path c' -> closed_path start.
Fixpoint path_length c (path : closed_path c) : nat :=
  match path with
    | path_end _ => 0
    | path_step _ _ rest => 1 + path_length rest
  end.
Definition drop1 c (path : closed_path c) : {c' : cfg & closed_path c'} :=
  match path with
    | path_end final => existT _ c (path_end final)
    | path_step c' _ rest => existT _ c' rest
  end.
Lemma drop_rebuild c (path : closed_path c) : path_length path <> 0 ->
   exists step : SF c (projT1 (drop1 path)), path = path_step step (projT2 (drop1 path)).
intro Hlen;destruct path;[exfalso|];eauto.
Qed.

Lemma drop_len c (path : closed_path c) :
  path_length (projT2 (drop1 path)) = pred (path_length path).
Proof.
destruct path;reflexivity.
Qed.

Inductive InPath c : forall c', closed_path c' -> Set :=
  | in_here : forall p, @InPath c c p
  | in_later : forall c' c'' (s : SF c' c'') (p' : closed_path c''),
                 InPath c p' -> InPath c (path_step s p').

Fixpoint tail_at c c' (path : closed_path c') (pf : InPath c path) : closed_path c :=
  match pf with
    | in_here p => p
    | in_later _ _ _ _ pf' => tail_at pf'
  end.

Lemma tail_len c c' (path : closed_path c') (pf : InPath c path) :
  path_length (tail_at pf) <= path_length path.
Proof.
induction pf;simpl;auto with arith.
Qed.

Inductive squash (A : Type) : Prop :=
  | inhabited : A -> squash A.

Definition StuckDecidable := forall c, (exists c', SF c c') \/ ~(exists c', SF c c').

Definition path_reach (P : cfg -> Prop) (c : cfg) : Prop :=
  forall (path : closed_path c), exists c', P c' /\ squash (InPath c' path).

Lemma path_reach_next P c c' : SF c c' -> ~ P c -> path_reach P c -> path_reach P c'.
intros Hstep Hnot_here Hpath.
unfold path_reach.
intro path.
specialize (Hpath (path_step Hstep path)).
destruct Hpath as [c0 [HPc0 Hpath']].
exists c0;split;[exact HPc0|].
destruct Hpath'.
remember (path_step Hstep path) as path' in H.
destruct H.
exfalso;auto.
inversion Heqpath'.
rewrite EqdepFacts.eq_sigT_sig_eq in H2.
destruct H2.
destruct x.
simpl in e.
subst p'.
constructor (assumption).
Qed.

Lemma path_reach_approx P (P_dec : forall c, P c \/ ~P c) (stuck_dec : StuckDecidable) :
  forall c, path_reach P c -> (forall n, ix_al_reach P c false n).
intros c H n. revert n c H. induction n; intros c H.
apply al_exhausted.
(* Need information about complete paths to proceed,
   if c is stuck we can't use later
 *)
destruct (stuck_dec c).
(* When the configuration isn't stuck, it could still be the case
   that some successors don't reach P, and path_reach P c holds
   only because P c is true now. *)
destruct (P_dec c);eauto using ix_al_reach, path_reach_next.
(* When the configuraton is stuck we can prove P holds here *)
+ specialize (H (path_end H0)).
  destruct H as [c' [Pc' Hhere]].
  replace c' with c in Pc'.
  apply al_here;assumption.
  destruct Hhere. inversion H. reflexivity.
Qed.

Lemma approx_path_reach P : forall c, (forall n, ix_al_reach P c false n) -> path_reach P c.
intros.
unfold path_reach.
intros.
specialize (H (S (path_length path))).
induction path.
simpl in H;inversion H;subst.
eauto using squash, InPath.
exfalso; firstorder.
inversion H;subst.
eauto using squash, InPath.
specialize (IHpath (H3 _ s));clear -IHpath;
firstorder using squash, InPath.
Qed.

(* Define unconditional versions of all-path reachability *)
CoInductive reach (P : cfg -> Prop) (c : cfg) : bool -> Prop :=
  | here : P c -> reach P c false
  | later : (exists c', SF c c') ->
               (forall c', SF c c' -> reach P c' false) ->
               forall s, reach P c s
.

Lemma reach_approx P c s : reach P c s -> forall n, ix_al_reach P c s n.
intros H n; revert s c H;induction n;intros s c H.
constructor.
inversion H;[apply al_here|apply al_later];auto.
Qed.

Lemma approx_defer P c : ~ P c ->
  (forall n, ix_al_reach P c false n) ->
  forall c', SF c c' -> (forall n, ix_al_reach P c' false n).
intros.
specialize (H0 (S n)).
inversion H0.
destruct (H H2).
auto.
Qed.

Lemma approx_reach P (P_dec : forall c, P c \/ ~ P c)
  (stuck_dec : StuckDecidable):
  forall c, (forall n, ix_al_reach P c false n) -> reach P c false.
cofix.
intros c Happrox.
destruct (stuck_dec c).
(* Later *)
destruct (P_dec c).
apply here; assumption.
apply later.
assumption.
intros.
apply approx_reach.
clear approx_reach.
apply approx_defer with c;assumption.
(* Here *)
clear approx_reach.
apply here.
specialize (Happrox 1).
inversion Happrox.
assumption.
destruct (H H1).
Qed.

Definition holds' env (phi1 phi2 : formula cfg env) strict :=
  forall rho gamma, phi1 rho gamma -> reach (phi2 rho) gamma strict.
Definition system_holds (A : system cfg) :=
  forall env (phi1 phi2 : formula cfg env),
    A env phi1 phi2 -> holds' phi1 phi2 true.

Theorem soundness : forall (A : system cfg) env (phi1 phi2 : formula cfg env),
                      (forall rho gamma, phi2 rho gamma \/ ~phi2 rho gamma) ->
                      StuckDecidable ->
                      IS cfg SF None A env phi1 phi2 ->
                      system_holds A ->
                      holds' phi1 phi2 false.
intros A env phi1 phi2 phi2_dec stuck_dec pf A_holds.
unfold holds'.
intros rho gamma Hphi1.
apply (approx_reach (phi2_dec rho) stuck_dec).
intro n.
revert rho gamma Hphi1.
fold (AllPathSemantics.holds false phi1 phi2 n).
apply (AllPathSoundness.soundness pf);trivial.
clear -A_holds.
unfold AllPathSoundness.system_holds.
intros.
specialize (A_holds _ _ _ H).
unfold AllPathSemantics.holds.
intros.
apply reach_approx.
auto.
Qed.


Require Import Essentials.Notations.
Require Import Essentials.Types.
Require Import Essentials.Facts_Tactics.
Require Import Category.Main.
Require Import Ext_Cons.Prod_Cat.Prod_Cat.
Require Import Functor.Main.
Require Import Basic_Cons.Product.
Require Import Basic_Cons.Exponential.

Local Obligation Tactic := idtac.
(**
The exponential functor maps each pair of objects (a, b) (an object of product
category Cᵒᵖ × C -> C) to the exponential bᵃ.
*)
Program Definition Exp_Func {C : Category}
        {hp : Has_Products C}
        (exps : ∀ a b, (a ⇑ b)%object)
: ((C^op × C) –≻ C)%functor :=
{|
  FO := fun x => exps (fst x) (snd x);
  FA := fun a b f =>
          Exp_morph_ex
            _ _
            ((snd f) ∘ (eval _)
                     ∘ ((×ᶠⁿᶜ C) @_a
                                 (_, fst b) (_, fst a)
                                 (id (exps (fst a) (snd a)), fst f)))%morphism
|}.

Next Obligation. (* F_id *)
Proof.
  program_simpl.
  eapply Exp_morph_unique.
  rewrite <- Exp_morph_com.
  reflexivity.
  simpl; simpl_ids; reflexivity.
Qed.

Next Obligation. (* F_compose *)
Proof.
  intros.
  eapply Exp_morph_unique.
  rewrite <- Exp_morph_com; reflexivity.
  rewrite Prod_compose_id.
  rewrite F_compose.
  rewrite <- (assoc _ _ (eval _)).
  rewrite <- Exp_morph_com.
  repeat rewrite assoc.
  rewrite <- F_compose.
  rewrite <- Prod_cross_compose.
  rewrite F_compose.
  match goal with
      [|- _ = (?X ∘ ?A ∘ ?B ∘ _)%morphism] =>
      rewrite (assoc_sym _ _ X);
        rewrite (assoc_sym _ _ (X ∘ A));
        rewrite (assoc _ _ X)
  end.
  rewrite <- Exp_morph_com.
  repeat rewrite assoc.
  rewrite <- F_compose.
  cbn; auto.
Qed.

Arguments Exp_Func {_ _} _, {_} _ _, _ _ _.

Notation "⇑ᶠⁿᶜ" := Exp_Func : functor_scope.