Require Import Common.Definitions.
Require Import Common.Values.
Require Import Common.Linking.
Require Import Lib.Extra.
From mathcomp Require Import ssreflect ssrfun ssrbool ssrnat seq eqtype.

Module Type AbstractComponentMemory.
  Parameter t : Type.

  Parameter prealloc : {fmap Block.id -> nat + list value} -> t.
  Parameter empty : t.
  Parameter reserve_block : t -> t * Block.id.
  Parameter alloc : t -> nat -> t * Block.id.
  Parameter load : t -> Block.id -> Block.offset -> option value.
  Parameter store : t -> Block.id -> Block.offset -> value -> option t.
  Parameter domm : t -> {fset Block.id}.

  Axiom load_prealloc:
    forall bufs b i,
      load (prealloc bufs) b i =
      if (0 <=? i)%Z then
        match bufs b with
        | Some (inl size) =>
          if (i <? Z.of_nat size)%Z then Some Undef else None
        | Some (inr chunk) => nth_error chunk (Z.to_nat i)
        | None => None
        end
      else None.

  Axiom load_after_alloc:
    forall m m' n b,
      alloc m n = (m',b) ->
    forall b' i,
      b' <> b -> load m' b' i = load m b' i.

  Axiom load_after_store:
    forall m m' b i v,
      store m b i v = Some m' ->
    forall b' i',
      load m' b' i' =
      if (b', i') == (b, i) then Some v else load m b' i'.

  Axiom store_after_load:
    forall m b i v v',
      load m b i = Some v ->
      exists m',
        store m b i v' = Some m'.

  Axiom domm_prealloc :
    forall bufs m,
      prealloc bufs = m ->
      domm m = fmap.domm bufs.

  Axiom domm_alloc :
    forall m m' n b,
      alloc m n = (m', b) ->
      size (domm m') = size (domm m) + 1.
End AbstractComponentMemory.

Module ComponentMemory : AbstractComponentMemory.
  Definition block := list value.

  Implicit Types (b : Block.id).

  Record mem := mkMem {
    content : NMap block;
    nextblock : Block.id;
  }.
  Definition t := mem.

  Definition prealloc (bufs: {fmap Block.id -> nat + list value}) : t :=
    let init_block x := match x with
                        | inl size => repeat Undef size
                        | inr chunk => chunk
                        end in
    {| content := mapm init_block bufs;
       nextblock := S (fold_left Nat.max (domm bufs) 0) |}.

  Definition empty :=
    {| content := emptym; nextblock := 0 |}.

  Definition reserve_block (m: t) : t * Block.id :=
    ({| content := content m; nextblock := (1 + nextblock m)%nat |},
     nextblock m).

  Definition alloc m (size : nat) : mem * Block.id :=
    let fresh_block := nextblock m in
    let chunk := repeat Undef size in
    ({| content := setm (content m) fresh_block chunk;
        nextblock := (1 + nextblock m) |},
     fresh_block).

  Definition load m b i : option value :=
    match getm (content m) b with
    | Some chunk =>
      if (0 <=? i)%Z then nth_error chunk (Z.to_nat i)
      else None
    | None => None
    end.

  Definition store m b i v : option mem :=
    match getm (content m) b with
    | Some chunk =>
      if (0 <=? i)%Z then
        match list_upd chunk (Z.to_nat i) v with
        | Some chunk' =>
          Some {| content := setm (content m) b chunk';
                  nextblock := nextblock m |}
        | _ => None
        end
      else None
    | None => None
    end.

  Definition domm (m : t) := @domm nat_ordType block (content m).

  Lemma load_prealloc:
    forall bufs b i,
      load (prealloc bufs) b i =
      if (0 <=? i)%Z then
        match bufs b with
        | Some (inl size) =>
          if (i <? Z.of_nat size)%Z then Some Undef else None
        | Some (inr chunk) => nth_error chunk (Z.to_nat i)
        | None => None
        end
      else None.
  Proof.
    intros bufs b i. unfold load, prealloc. simpl.
    rewrite mapmE. unfold Block.id in *.
    destruct (Z.leb_spec0 0 i) as [i_pos|i_neg].
    - simpl. destruct (bufs b) as [buf|]; trivial.
      simpl. destruct buf as [size|chunk]; trivial.
      destruct (Z.ltb_spec0 i (Z.of_nat size)) as [i_lt_size|i_ge_size].
      + rewrite <- (Z2Nat.id _ i_pos) in i_lt_size.
        rewrite <- Nat2Z.inj_lt in i_lt_size.
        rewrite <- (repeat_length Undef size) in i_lt_size.
        rewrite <- nth_error_Some in i_lt_size.
        destruct (nth_error (repeat Undef size) (Z.to_nat i)) as [v|] eqn:get_i; try congruence.
        apply nth_error_In in get_i.
        apply repeat_spec in get_i.
        now rewrite get_i.
      + rewrite nth_error_None repeat_length Nat2Z.inj_le.
        now rewrite Z2Nat.id // -Z.nlt_ge.
    - simpl. now destruct (bufs b).
  Qed.

  Lemma load_after_alloc:
    forall (m m' : mem) (n : nat) b,
      alloc m n = (m',b) ->
    forall b' i,
      b' <> b -> load m' b' i = load m b' i.
  Proof.
    intros m m' n b Halloc b' i Hb'.
    unfold alloc in Halloc. inversion Halloc. subst.
    unfold load. simpl.
    rewrite setmE.
    now rewrite (introF (b' =P nextblock m :> nat) Hb').
  Qed.

  Ltac inv H := (inversion H; subst; clear H).

  Lemma load_after_store:
    forall m m' b i v,
      store m b i v = Some m' ->
    forall b' i',
      load m' b' i' =
      if (b', i') == (b, i) then Some v else load m b' i'.
  Proof.
    move=> m m' b i v Hstore b' i'.
    move: Hstore; rewrite /store /load.
    case m_b: (content m b) => [chunk|] //=.
    case: (Z.leb_spec0 0 i)=> [i_pos|//] /=.
    case upd_chunk: (list_upd chunk (Z.to_nat i) v) => [chunk'|] // [<- {m'}] /=.
    rewrite setmE xpair_eqE; case: (b' =P b) => [-> {b'}|] //=.
    case: (i' =P i) => [-> {i'}|i'_ne_i] /=.
    - move/Z.leb_spec0: i_pos => ->; exact: list_upd_nth_error_same upd_chunk.
    - rewrite m_b; case: (Z.leb_spec0 0 i')=> [i'_pos|] //=.
      apply: list_upd_nth_error_other; eauto.
      contradict i'_ne_i; symmetry; exact: Z2Nat.inj i'_ne_i.
  Qed.

  Lemma store_after_load:
    forall m b i v v',
      load m b i = Some v ->
      exists m',
        store m b i v' = Some m'.
  Proof.
    move=> m b i v v'; rewrite /load /store.
    case m_b: (content m b)=> [chunk|] //.
    case: (Z.leb_spec0 0 i)=> [i_pos|] //= chunk_i.
    suffices [? ->] :
      exists chunk', list_upd chunk (Z.to_nat i) v' = Some chunk' by eauto.
    elim: {m_b i i_pos} chunk (Z.to_nat i) chunk_i => [|v'' chunk IH] [|i] //=.
    - by eauto.
    - by move=> /IH [chunk' ->]; eauto.
  Qed.

  Lemma domm_prealloc :
    forall bufs m,
      prealloc bufs = m ->
      domm m = fmap.domm bufs.
  Admitted.

  Lemma domm_alloc :
    forall m m' n b,
      alloc m n = (m', b) ->
      size (domm m') = size (domm m) + 1.
  Admitted.
End ComponentMemory.

Module ComponentMemoryExtra.
  Import ComponentMemory.
  (* RB: NOTE: Prove composition as needed. Blocks are emitted in the same order
     as the sequence of single calls. *)
  Definition reserve_blocks (mem : t) (n : nat) : t * list Block.id :=
    let acc '(mem, bs) :=
        let '(mem', b) := reserve_block mem in
        (mem', bs ++ [b]) in
    iter n acc (mem, []).

  Lemma reserve_blocks_length (mem mem' : t) (n : nat) (bs : list Block.id) :
    ComponentMemoryExtra.reserve_blocks mem n = (mem', bs) ->
    length bs = n.
  Proof.
    generalize dependent mem'. generalize dependent n.
    induction bs using rev_ind.
    - intros n mem' H.
      destruct n; auto.
      unfold reserve_blocks in H.
      simpl in H.
      destruct (iter n (fun '(mem, bs) => let '(mem', b) := reserve_block mem in (mem', bs ++ [b])) (mem, [])).
      destruct (reserve_block t0).
      inversion H. symmetry in H2; now apply app_cons_not_nil in H2.
    - intros n mem' H.
      destruct n; auto.
      + simpl in *. inversion H. now apply app_cons_not_nil in H2.
      + rewrite app_length plus_comm. simpl.
        unfold reserve_blocks in H.
        simpl in H.
        destruct (iter n (fun '(mem, bs) => let '(mem', b) := reserve_block mem in (mem', bs ++ [b])) (mem, []))
          as [mem'' bs'] eqn:Hiter.
        rewrite (IHbs n mem'').
        reflexivity.
        destruct (reserve_block mem''). simpl in H.
        inversion H.
        assert (bs' = bs).
        {
          clear -H2. generalize dependent bs'.
          induction bs; destruct bs'; intros H; auto.
          - inversion H. symmetry in H2; now apply app_cons_not_nil in H2.
          - inversion H; subst; now apply app_cons_not_nil in H2.
          - inversion H; subst. simpl in *. rewrite (IHbs _ H2); reflexivity.
        }
        subst bs'.
        rewrite -Hiter. reflexivity.
  Qed.

End ComponentMemoryExtra.

Module Memory.
  Definition t := NMap ComponentMemory.t.

  Fixpoint empty (cs : list Component.id) :=
    match cs with
    | [] => emptym
    | c::cs' => setm (empty cs') c ComponentMemory.empty
    end.

  Definition alloc (mem : t) (C : Component.id) (size : nat) : option (t * Pointer.t) :=
    match mem C with
    | Some memC =>
      let '(memC', b) := ComponentMemory.alloc memC size in
      Some (setm mem C memC', (C, b, 0%Z))
    | None => None
    end.

  Definition load (mem: t) (ptr: Pointer.t) : option value :=
    match mem (Pointer.component ptr) with
    | Some memC => ComponentMemory.load memC (Pointer.block ptr) (Pointer.offset ptr)
    | None => None
    end.

  Definition store (mem: t) (ptr: Pointer.t) (v: value) : option t :=
    match mem (Pointer.component ptr) with
    | Some memC =>
      match ComponentMemory.store memC (Pointer.block ptr) (Pointer.offset ptr) v with
      | Some memC' => Some (setm mem (Pointer.component ptr) memC')
      | None => None
      end
    | None => None
    end.

  Lemma load_after_store mem ptr v mem' ptr' :
    store mem  ptr v = Some mem' ->
    load mem' ptr' =
    if ptr' == ptr then Some v else load mem ptr'.
  Proof.
    case: ptr ptr'=> [[c b] off] [[c' b'] off']; rewrite /store /load /=.
    case mem_c: (mem c) => [bs|] //.
    case bs_ptr: (ComponentMemory.store bs b off v) => [bs'|] //= [<- {mem'}].
    rewrite !xpair_eqE setmE; case: (c' =P c) => [-> {c'}|] //=.
    by rewrite (ComponentMemory.load_after_store _ _ _ _ _ bs_ptr) mem_c.
  Qed.

  Lemma load_after_store_eq mem ptr v mem' :
    store mem  ptr v = Some mem' ->
    load  mem' ptr   = Some v.
  Proof. by move=> /load_after_store ->; rewrite eqxx. Qed.

  Lemma load_after_store_neq mem ptr v mem' ptr' :
    ptr <> ptr' ->
    store mem  ptr  v = Some mem' ->
    load  mem' ptr'   = load mem ptr'.
  Proof. by move=> /eqP/negbTE ne /load_after_store ->; rewrite eq_sym ne. Qed.

  Lemma store_after_load mem ptr v v' :
    load mem ptr = Some v ->
    exists mem', store mem ptr v' = Some mem'.
  Proof.
    case: ptr=> [[c b] off]; rewrite /load /store /=.
    case mem_c: (mem c)=> [bs|] //=.
    case/(ComponentMemory.store_after_load _ _ _ _ v')=> [bs' ->].
    by eauto.
  Qed.

End Memory.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

(* TODO: Clean these lemmas and their weak variants *)

Definition to_partial_memory (mem : Memory.t) (ctx : {fset Component.id}) :=
  filterm (fun k _ => negb (k \in ctx)) mem.

Definition merge_memories (mem1 mem2: Memory.t): Memory.t :=
  unionm mem1 mem2.

(* RB: NOTE: An equality relation could be used to contain the usual partial
   equality. *)

Lemma program_allocation_in_partialized_memory_strong :
  forall (ctx: {fset Component.id}) mem1 mem2,
    to_partial_memory mem1 ctx = to_partial_memory mem2 ctx ->
  forall C size mem1' ptr,
    C \notin ctx ->
    Memory.alloc mem1 C size = Some (mem1', ptr) ->
  exists2 mem2',
    Memory.alloc mem2 C size = Some (mem2', ptr) &
    to_partial_memory mem1' ctx = to_partial_memory mem2' ctx.
Proof.
move=> ctx mem1 mem2 /eq_fmap Hfilter C size mem1' ptr nin_ctx.
rewrite /Memory.alloc; move/(_ C): (Hfilter); rewrite !filtermE nin_ctx.
case: (mem1 C) (mem2 C)=> [memC|] // [_|] //= [<-].
case: (ComponentMemory.alloc memC size)=> [memC' b] [<- <-].
eexists; eauto; apply/eq_fmap=> C'; rewrite !filtermE !setmE.
case: eqP=> [-> {C'}|_] //=.
by move/(_ C'): Hfilter; rewrite !filtermE.
Qed.

Lemma program_allocation_in_partialized_memory:
  forall (ctx: {fset Component.id}) mem1 mem2,
    to_partial_memory mem1 ctx = to_partial_memory mem2 ctx ->
  forall C size mem1' mem2' ptr1 ptr2,
    C \notin ctx ->
    Memory.alloc mem1 C size = Some (mem1', ptr1) ->
    Memory.alloc mem2 C size = Some (mem2', ptr2) ->
    ptr1 = ptr2 /\
    to_partial_memory mem1' ctx = to_partial_memory mem2' ctx.
Proof.
move=> ctx mem1 mem2 Hfilter C size mem1' mem2' ptr1 ptr2 nin_ctx e_mem1.
case: (program_allocation_in_partialized_memory_strong Hfilter nin_ctx e_mem1).
by move=> mem2'' -> e' [<- <-]; eauto.
Qed.

Lemma program_load_in_partialized_memory_strong:
  forall (ctx: {fset Component.id}) mem1 mem2,
    to_partial_memory mem1 ctx = to_partial_memory mem2 ctx ->
  forall C b o v,
    C \notin ctx ->
    Memory.load mem1 (C, b, o) = Some v ->
    Memory.load mem2 (C, b, o) = Some v.
Proof.
move=> ctx mem1 mem2 /eq_fmap Hfilter C b o v nin_ctx.
rewrite /Memory.load /=; move/(_ C): Hfilter; rewrite !filtermE nin_ctx.
by case: (mem1 C) (mem2 C)=> [memC|] // [_|] //= [<-].
Qed.

Lemma program_load_in_partialized_memory:
  forall (ctx: {fset Component.id}) mem1 mem2,
    to_partial_memory mem1 ctx = to_partial_memory mem2 ctx ->
  forall C b o v1 v2,
    C \notin ctx ->
    Memory.load mem1 (C, b, o) = Some v1 ->
    Memory.load mem2 (C, b, o) = Some v2 ->
    v1 = v2.
Proof.
move=> ctx mem1 mem2 Hfilter C b o v1 v2 nin_ctx e_mem.
rewrite (program_load_in_partialized_memory_strong Hfilter nin_ctx e_mem).
by case.
Qed.

Lemma program_store_in_partialized_memory_strong:
  forall (ctx: {fset Component.id}) mem1 mem2,
    to_partial_memory mem1 ctx = to_partial_memory mem2 ctx ->
  forall C b o v mem1',
    C \notin ctx ->
    Memory.store mem1 (C, b, o) v = Some mem1' ->
  exists2 mem2',
    Memory.store mem2 (C, b, o) v = Some mem2' &
    to_partial_memory mem1' ctx = to_partial_memory mem2' ctx.
Proof.
move=> ctx mem1 mem2 /eq_fmap Hfilter C b o v mem1' nin_ctx.
rewrite /Memory.store /=; move/(_ C): (Hfilter); rewrite !filtermE nin_ctx.
case: (mem1 C) (mem2 C)=> [memC|] // [_|] //= [<-].
case: (ComponentMemory.store memC b o v)=> [memC'|] //= [<-].
eexists; eauto; apply/eq_fmap=> C'; rewrite !filtermE !setmE.
case: eqP=> [-> {C'}|_] //.
by move/(_ C'): Hfilter; rewrite !filtermE.
Qed.

Lemma program_store_in_partialized_memory:
  forall (ctx: {fset Component.id}) mem1 mem2,
    to_partial_memory mem1 ctx = to_partial_memory mem2 ctx ->
  forall C b o v mem1' mem2',
    C \notin ctx ->
    Memory.store mem1 (C, b, o) v = Some mem1' ->
    Memory.store mem2 (C, b, o) v = Some mem2' ->
    to_partial_memory mem1' ctx = to_partial_memory mem2' ctx.
Proof.
move=> ctx mem1 mem2 Hfilter C b o v mem1' mem2' nin_ctx e_mem.
case: (program_store_in_partialized_memory_strong Hfilter nin_ctx e_mem).
move=> *; congruence.
Qed.

Lemma context_allocation_in_partialized_memory:
  forall (ctx: {fset Component.id}) mem C size mem' ptr,
    C \in ctx ->
    Memory.alloc mem C size = Some (mem', ptr) ->
    to_partial_memory mem' ctx = to_partial_memory mem ctx.
Proof.
  move=> ctx mem C size mem' ptr HC_in_ctx.
  rewrite /Memory.alloc => Halloc.
  case mem_C: (mem C) => [memC|];
    rewrite mem_C // in Halloc.
  case memC_alloc: (ComponentMemory.alloc memC size);
    rewrite memC_alloc // in Halloc.
  injection Halloc.
  move=> Hptr <-.
  apply/eq_fmap => C'.
  rewrite filtermE filtermE setmE.
  case: (@eqP _ C' C) => [-> | _] //.
  by rewrite HC_in_ctx mem_C /=.
Qed.

Lemma context_store_in_partialized_memory:
  forall (ctx: {fset Component.id}) mem C b o v mem',
    C \in ctx ->
    Memory.store mem (C, b, o) v = Some mem' ->
    to_partial_memory mem' ctx = to_partial_memory mem ctx.
Proof.
  move=> ctx mem C b o v mem' C_in_ctx.
  rewrite /Memory.store /= => Hstore.
  case mem_C: (mem C) => [memC|];
    rewrite mem_C // in Hstore.
  case memC_store: (ComponentMemory.store memC b o v);
    rewrite memC_store // in Hstore.
  injection Hstore.
  move=> <-.
  apply/eq_fmap => C'.
  rewrite filtermE filtermE setmE.
  case: (@eqP _ C' C) => [-> | _] //.
  by rewrite C_in_ctx mem_C /=.
Qed.

(* RB: TODO: More properly, this seems to belong in Machine.Memory. However, it
   is natural to resort to a notion of partial memory that seems logically
   related to the supporting components of PS. Again, note, however, that this
   notion of partial memory is already used in the Memory module, and it may be
   a good idea to relocate our compact definitions there.

   Otherwise, this is a more convenient wrapper for
   context_store_in_partialized_memory which does not require the destruction of
   pointers, and could conceivably replace the wrappee throughout the
   development. *)
Lemma program_store_to_partialized_memory
      ptr (iface : Program.interface) mem mem' v :
  Pointer.component ptr \in domm iface ->
  Memory.store mem ptr v = Some mem' ->
  to_partial_memory mem (domm iface) = to_partial_memory mem' (domm iface).
Proof.
  destruct ptr as [[C b] o]. simpl.
  intros Hdome Hsome.
  unfold to_partial_memory. symmetry.
  eapply context_store_in_partialized_memory; eassumption.
Qed.

(* RB: TODO: Same notes as above.
   Cf.  program_allocation_in_partialized_memory_strong. *)
Lemma program_allocation_to_partialized_memory
      C (iface : Program.interface) size mem mem' ptr :
  C \in domm iface ->
  Memory.alloc mem C size = Some (mem', ptr) ->
  to_partial_memory mem (domm iface) = to_partial_memory mem' (domm iface).
Proof.
  destruct ptr as [[C' b] o]. simpl.
  intros Hdome Hsome.
  unfold to_partial_memory. symmetry.
  eapply context_allocation_in_partialized_memory; eassumption.
Qed.

(* The following two lemmas manipulate memory stores and partialized memories
   more conveniently than the full-fledged "partialized" results. Note naming
   conventions for some of those are currently somewhat confusing.  *)
Lemma partialize_program_store :
  forall mem mem' (ctx : Program.interface) ptr v,
    Pointer.component ptr \notin domm ctx ->
    Memory.store mem ptr v = Some mem' ->
    Memory.store (to_partial_memory mem (domm ctx)) ptr v =
    Some (to_partial_memory mem' (domm ctx)).
Proof.
  unfold Memory.store, to_partial_memory.
  intros mem mem' ctx ptr v Hnotin Hstore.
  destruct (mem (Pointer.component ptr)) as [memC |] eqn:HmemC;
    last discriminate.
  destruct (ComponentMemory.store memC (Pointer.block ptr) (Pointer.offset ptr) v)
    as [memC' |] eqn:HmemC';
    last discriminate.
  inversion Hstore as [[Hstore']].
  now rewrite (getm_filterm_notin_domm _ Hnotin) HmemC HmemC'
      (setm_filterm_notin_domm _ _ Hnotin).
Qed.

Lemma unpartialize_program_store :
  forall mem1 mem1' mem2 ptr v,
    Memory.store mem1 ptr v = Some mem1' ->
    Memory.store (merge_memories mem1 mem2) ptr v =
    Some (merge_memories mem1' mem2).
Proof.
  unfold Memory.store.
  intros mem1 mem1' mem2 ptr v Hstore.
  unfold merge_memories. rewrite unionmE.
  destruct (mem1 (Pointer.component ptr)) eqn:Hcase1;
    rewrite Hcase1 || idtac "ExStructures 0.1 legacy rewrite inactive";
    last discriminate.
  simpl.
  destruct (ComponentMemory.store t (Pointer.block ptr) (Pointer.offset ptr) v) eqn:Hcase2;
    last discriminate.
  rewrite setm_union. now inversion Hstore.
Qed.

Lemma partialize_program_alloc :
  forall mem mem' (ctx : Program.interface) C ptr size,
    C \notin domm ctx ->
    Memory.alloc mem C size = Some (mem', ptr) ->
    Memory.alloc (to_partial_memory mem (domm ctx)) C size =
    Some (to_partial_memory mem' (domm ctx), ptr).
Proof.
  unfold Memory.alloc, to_partial_memory.
  intros mem mem' ctx C ptr size Hnotin Halloc.
  destruct (mem C) as [memC |] eqn:HmemC;
    last discriminate.
  destruct (ComponentMemory.alloc memC size) as [memC' b] eqn:HmemC'.
  inversion Halloc; subst.
  now rewrite (getm_filterm_notin_domm _ Hnotin) HmemC HmemC'
      (setm_filterm_notin_domm _ _ Hnotin).
Qed.

Lemma unpartialize_program_alloc :
  forall mem1 mem1' mem2 C ptr size,
    Memory.alloc mem1 C size = Some (mem1', ptr) ->
    Memory.alloc (merge_memories mem1 mem2) C size =
    Some (merge_memories mem1' mem2, ptr).
Proof.
  unfold Memory.alloc.
  intros mem1 mem1' mem2 C ptr size Halloc.
  unfold merge_memories. rewrite unionmE.
  destruct (mem1 C) as [memC |] eqn:Hcase1;
    rewrite Hcase1 || idtac "ExStructures 0.1 legacy rewrite inactive";
    last discriminate.
  simpl.
  destruct (ComponentMemory.alloc memC size) as [memC' b].
  rewrite setm_union. now inversion Halloc.
Qed.

(* (* JT: TODO: clean proof *) *)
(* Lemma mem_store_different_component : forall mem mem' C b o val Cid, *)
(*               Memory.store mem (C, b, o) val = Some mem' -> *)
(*               Cid <> C -> *)
(*               mem Cid = mem' Cid. *)
(* Proof. *)
(*   intros mem mem' C b o val Cid Hmem Hneq. *)
(*   unfold Memory.store in Hmem. *)
(*   simpl in *. *)
(*   destruct (mem C) eqn:HmemC. *)
(*   - destruct (ComponentMemory.store t b o val). *)
(*     + inversion Hmem; subst. *)
(*       rewrite setmE. *)
(*       rewrite eqtype.eqE. simpl. *)
(*       destruct (ssrnat.eqn Cid C) eqn:Heq; *)
(*         last reflexivity. *)
(*       assert (Cid = C). *)
(*       { clear -Heq. revert C Heq. *)
(*         induction Cid; intros C Heq; destruct C; eauto; *)
(*           inversion Heq. *)
(*       } *)
(*       contradiction. *)
(*     + inversion Hmem. *)
(*   - inversion Hmem. *)
(* Qed. *)

Section Partial.
  Lemma to_partial_memory_in ip ic mem Cid :
    mergeable_interfaces ip ic ->
    Cid \in domm ip ->
    (to_partial_memory mem (domm ic)) Cid = mem Cid.
  Proof.
    intros Hmerge HCid.
    unfold to_partial_memory.
    apply getm_filterm_notin_domm.
    eapply domm_partition_notin_r; eassumption.
  Qed.

  Lemma to_partial_memory_notin ip ic mem Cid :
    mergeable_interfaces ip ic ->
    Cid \in domm ic ->
    (to_partial_memory mem (domm ic)) Cid = None.
  Proof.
    intros Hmerge HCid.
    unfold to_partial_memory.
    rewrite filtermE.
    unfold obind, oapp.
    destruct (mem Cid) eqn:Hmem;
      rewrite Hmem || idtac "ExStructures 0.1 legacy rewrite inactive".
    now rewrite HCid.
    now reflexivity.
  Qed.

  (* RB: NOTE: We should rename these, and probably use this instead of the
     weaker version (currently, [in], confusingly). *)
  Lemma to_partial_memory_notin_strong ip ic mem Cid :
    mergeable_interfaces ip ic ->
    Cid \notin domm ic ->
    (to_partial_memory mem (domm ic)) Cid = mem Cid.
  Proof.
    intros Hmerge HCid.
    unfold to_partial_memory.
    rewrite filtermE.
    unfold obind, oapp.
    destruct (mem Cid) eqn:Hmem;
      rewrite Hmem || idtac "ExStructures 0.1 legacy rewrite inactive".
    now rewrite HCid.
    now reflexivity.
  Qed.
End Partial.


Require Import Coq.Strings.String.

Require Export SystemFR.Trees.

Require Export SystemFR.Syntax.

Require Export SystemFR.WFLemmas.
Require Export SystemFR.TWFLemmas.

Require Export SystemFR.FVLemmas.
Require Export SystemFR.AnnotatedTermLemmas.
Require Export SystemFR.Tactics.
Require Export SystemFR.TypeOperations.
Require Export SystemFR.ListUtils.

Lemma ite_type_open:
  forall b T1 T2 T, T_ite_push b T1 T2 T -> forall k a,
    is_erased_term a ->
    wf b 0 ->
    T_ite_push b (open k T1 a) (open k T2 a) (open k T a).
Proof.
  induction 1; repeat step || constructor || fv_open || list_utils ||
                      rewrite (open_none b) in * by (eauto with wf lia) ||
                      rewrite is_erased_term_tfv in * by assumption;
    eauto with fv.
Qed.

Lemma ite_type_topen:
  forall b T1 T2 T, T_ite_push b T1 T2 T -> forall k X,
    twf b 0 ->
    T_ite_push b (topen k T1 (fvar X type_var)) (topen k T2 (fvar X type_var)) (topen k T (fvar X type_var)).
Proof.
  induction 1; repeat step || constructor || fv_open || list_utils ||
                      rewrite (topen_none b) in * by (eauto with twf lia) ||
                      rewrite is_erased_term_tfv in * by assumption;
    eauto with fv.
Qed.

Lemma ite_type_subst:
  forall b T1 T2 T, T_ite_push b T1 T2 T -> forall l,
    T_ite_push (psubstitute b l term_var) (psubstitute T1 l term_var) (psubstitute T2 l term_var) (psubstitute T l term_var).
Proof.
  induction 1; repeat step || constructor.
Qed.


Require Import SpecDeps.
Require Import RData.
Require Import EventReplay.
Require Import MoverTypes.
Require Import Constants.
Require Import CommonLib.
Require Import AbsAccessor.Spec.
Require Import BaremoreHandler.Spec.

Local Open Scope Z_scope.

Section Spec.

  Definition smc_mark_nonsecure_spec (addr: Z64) (adt: RData) : option RData :=
    match addr with
    | VZ64 addr =>
      rely is_int64 addr;
      rely (Z.land (r_scr_el3 (cpu_regs (priv adt))) SCR_WORLD_MASK =? SCR_REALM_WORLD);
      let gidx := __addr_to_gidx addr in
      rely is_gidx gidx;
      when adt == query_oracle adt;
      rely prop_dec ((gpt_lk (share adt)) @ gidx = None);
      rely prop_dec ((gpt (share adt)) @ gidx = true);
      let e := EVT CPU_ID (ACQ_GPT gidx) in
      let e' := EVT CPU_ID (REL_GPT gidx false) in
      Some adt {log: e' :: e :: (log adt)} {share: (share adt) {gpt: (gpt (share adt)) # gidx == false}}
           {priv: (priv adt) {cpu_regs: (cpu_regs (priv adt)) {r_x0: 0} {r_x1: addr} {r_esr_el3: ESR_EC_SMC}}}
    end.

End Spec.


(*
 * © 2019 Massachusetts Institute of Technology.
 * MIT Proprietary, Subject to FAR52.227-11 Patent Rights - Ownership by the Contractor (May 2014)
 * SPDX-License-Identifier: MIT
 *
 *)
From Coq Require Import
     FSets.FMapList
     FSets.FMapFacts
     Structures.OrderedType
     Structures.OrderedTypeEx
     Logic.ProofIrrelevance
     Program.Equality
.

From Coq Require List.

From SPICY Require Import
     MyPrelude
     Tactics.

Set Implicit Arguments.

Module MyOrderedMap (OT : UsualOrderedType).
  Import OT.

  Module Import Map := FMapList.Make( OT ).
  Definition t := Map.t.

  Module Import P := WProperties_fun OT Map.
  Module Import F := P.F.
  Module Import O := OrdProperties Map.
  Module Import OTF := OrderedType.OrderedTypeFacts OT.

  Local Notation "$0" := (empty _).
  Local Notation "m $+ ( k , v )" := (add k v m) (at level 50, left associativity).
  Local Notation "m $- k" := (remove k m) (at level 50, left associativity).
  Local Notation "m $? k" := (find k m) (at level 50, left associativity).

  Lemma lookup_empty_none : forall V k,
      (@empty V) $? k = None.
  Proof. unfold find, Raw.find; trivial. Qed.

  Lemma map_not_none : forall V k (m : Map.t V),
      m $? k <> None
      -> exists v, m $? k = Some v.
  Proof.  unfold not; intros; cases (m $? k); try contradiction; eauto. Qed.

  Ltac context_map_rewrites1 :=
    match goal with
    | [ H : ?m $? ?k = _ |- context[?m $? ?k] ] => rewrite H
    | [ H : context [ match ?matchee with _ => _ end ]
      , H1 : ?matchee = _ |- _] => rewrite H1 in H
    end.

  Ltac contra_map_lookup1 :=
    match goal with
    | [ H : ?ks $? ?k = ?v -> _, ARG : ?ks $? ?k = ?v |- _ ] => specialize (H ARG)
    | [ H1 : ?ks $? ?k = _, H2 : ?ks $? ?k = _ |- _ ] => rewrite H1 in H2; invert H2
    | [ H : ?ks $? ?k = _ |- context [ ?ks $? ?k <> _] ] => unfold not; intros
    end.

  Local Ltac clean_map_lookups1' :=
    invert_base_equalities1
    || contra_map_lookup1
    || context_map_rewrites1
    || match goal with
      | [ H : context [ $0 $? _ ] |- _ ] =>
        rewrite lookup_empty_none in H
        ; try discriminate H
      | [ |- context [ $0 $? _ ] ] =>
        rewrite lookup_empty_none
      | [ H : context [ _ $+ (_,_) $? _ ] |- _ ] =>
        progress (
            repeat (
                ( rewrite add_eq_o in H by trivial )
              || ( rewrite add_neq_o in H by auto 2 )
              || ( rewrite lookup_empty_none in H ) ) )

      | [ |- context [ _ $+ (_,_) $? _ ] ] =>
        progress (
            repeat (
                ( rewrite add_eq_o by trivial )
              || ( rewrite add_neq_o by auto 2 )
              || ( rewrite lookup_empty_none ) ) )

      | [ H : context [ _ $- _ $? _ ] |- _ ] =>
        progress (
            repeat (
                ( rewrite remove_eq_o in H by trivial )
              || ( rewrite remove_neq_o in H by auto 2 ) ) )

      | [ |- context [ _ $- _ $? _ ] ] =>
        progress (
            repeat (
                ( rewrite remove_eq_o by trivial )
              || ( rewrite remove_neq_o by auto 2 ) ) )

      | [ H : ~ In _ _ |- _ ] => rewrite not_find_in_iff in H
      | [ |- ~ In _ _ ] => rewrite not_find_in_iff
      | [ H : In _ _ |- _ ] => rewrite in_find_iff in H
      | [ H1 : ?m $? ?k1 = _ , H2 : ?m $? ?k2 = _ |- _] =>
        assert (k1 = k2) as RW by auto 2; rewrite RW in H1; clear RW; rewrite H1 in H2
      | [ H : ?m $? ?k = None -> False |- _ ] =>
        change (m $? k = None -> False) with (m $? k <> None) in H
      | [ H : ?m $? ?k <> None |- _ ] =>
        apply map_not_none in H; split_ex
      | [ H : MapsTo _ _ _ |- _ ] => rewrite find_mapsto_iff in H
      | [ |- context [ MapsTo _ _ _ ] ] => rewrite find_mapsto_iff
      end.

  Ltac contra_map_lookup := repeat (invert_base_equalities1 || contra_map_lookup1).
  Local Ltac clean_map_lookups' := repeat clean_map_lookups1'.
  Ltac context_map_rewrites := repeat context_map_rewrites1.

  Lemma lookup_some_implies_in : forall V (m : Map.t V) k v,
      m $? k = Some v
      -> List.In (k,v) (to_list m).
  Proof.
    intros * H.

    rewrite <- find_mapsto_iff, elements_mapsto_iff, InA_alt in H.
    split_ex.
    unfold eq_key_elt, Raw.PX.eqke in H; simpl in H.
    destruct x; simpl in *; split_ands; subst; eauto.
  Qed.

  Lemma lookup_split : forall V (m : Map.t V) k v k' v',
      (m $+ (k, v)) $? k' = Some v'
      -> (k' <> k /\ m $? k' = Some v') \/ (k' = k /\ v' = v).
  Proof.
    intros;
      case (eq_dec k k'); intros; subst; clean_map_lookups'; eauto.
  Qed.

  Lemma map_eq_fields_eq :
    forall V (th th' : Raw.t V) s s',
      th = th'
      -> {| this := th ; sorted := s |} = {| this := th' ; sorted := s' |}.
  Proof.
    intros; subst; f_equal; apply proof_irrelevance.
  Qed.

  Lemma map_eq_elements_eq :
    forall {V} (m m' : Map.t V),
      elements m = elements m'
      -> m = m'.
  Proof.
    intros. destruct m. destruct m'.
    simpl in *;
      eapply map_eq_fields_eq;
      eauto.
  Qed.

  Lemma Equal_hd_tl :
    forall {V} (m1 m1' m2 m2' : t V) x xs y ys sx sy,
      m1 = {| this := x :: xs ; sorted := sx |}
      -> m2 = {| this := y :: ys ; sorted := sy |}
      -> Equal m1 m2
      -> m1' = m1 $- fst x
      -> m2' = m2 $- fst y
      -> x = y /\ Equal m1' m2'.
  Proof.
    intros.

    destruct x as [n1 v1]; destruct y as [n2 v2]; simpl in *.

    assert ( (n1,v1) = (n2,v2) ).
    - unfold Equal in *; subst; simpl in *.
      match goal with
      | [ H : forall _, _ |- _ ] =>
        generalize (H n1); generalize (H n2); intros
      end;
        unfold find, Raw.find in *; simpl in *.

      pose proof (Raw.MX.elim_compare_eq (eq_refl n1)) as EQn1.
      pose proof (Raw.MX.elim_compare_eq (eq_refl n2)) as EQn2.
      split_ex.
      rewrite H2, H3 in *.

      cases (compare n1 n2);
        cases (compare n2 n1);
        try discriminate; subst; repeat invert_base_equalities1; eauto;
          repeat
            match goal with
            | [ H : eq _ _ |- _ ] => unfold eq in H; subst
            end; eauto.

      pose proof (lt_trans l0 l) as CONTRA;
        apply lt_not_eq in CONTRA; assert (eq n1 n1) by auto; contradiction.

    - split; auto; subst.
      invert H4.
      unfold Equal in *; simpl in *.
      intro k.
      case (eq_dec k n2); intros; subst;
        (rewrite !remove_eq_o by auto 2)
        || (rewrite !remove_neq_o by auto 2); eauto.
  Qed.

  Lemma remove_hd :
    forall {V} n (v : V) xs sx hdrel,
      {| this := (n,v) :: xs ; sorted := Sorted.Sorted_cons sx hdrel |} $- n = {| this := xs ; sorted := sx |}.
  Proof.
    intros.
    unfold remove, Raw.remove. simpl.
    eapply map_eq_elements_eq; simpl.

    pose proof (Raw.MX.elim_compare_eq (eq_refl n)); split_ex.
    rewrite H; trivial.
  Qed.

  Lemma Empty_eq_empty :
    forall {V} m,
      Empty (elt:=V) m
      -> $0 = m.
  Proof.
    intros.
    apply elements_Empty in H.
    apply map_eq_elements_eq. auto.
  Qed.

  Lemma map_eq_Equal :
    forall {V} (m m' : t V),
      Equal m m'
      -> m = m'.
  Proof.
    destruct m as [l sl].
    generalize dependent l.
    induction l; intros.

    - unfold Equal in H. simpl in *.
      apply map_eq_elements_eq; simpl.
      symmetry in H.

      destruct m'; simpl in *.
      cases this0; trivial.
      exfalso.
      destruct p. specialize (H t0).
      unfold find, Raw.find in *; simpl in *.

      pose proof (elim_compare_eq (eq_refl t0)) as RW; destruct RW as [?e RW];
        rewrite RW in *; discriminate.

    - simpl.
      destruct m'; cases this0; simpl in *.
      + destruct a as [n v].
        unfold Equal in H; specialize (H n).
        unfold find, Raw.find in H; simpl in H.
        pose proof (Raw.MX.elim_compare_eq) as P; specialize (P n n (eq_refl n)); destruct P.
        rewrite H0 in H; discriminate.

      + eapply Equal_hd_tl in H; eauto; split_ands; subst.
        unfold Equal in H0; simpl in *.

        dependent destruction sl.
        dependent destruction sorted0.
        specialize (IHl sl {| this := this0 ; sorted := sorted0 |}).

        assert (tlEQ : Equal {| this := l ; sorted := sl |} {| this := this0 ; sorted := sorted0 |} ).
        * destruct p;
            unfold Equal; intro k;
              specialize (H0 k); rewrite !remove_hd in H0; eauto.
        * specialize (IHl tlEQ).
          dependent destruction IHl.
          eapply map_eq_elements_eq; simpl; f_equal.
  Qed.

  Lemma empty_Empty :
    forall {V}, Empty (elt:=V) $0.
  Proof.
    intros.
    unfold Empty, Raw.Empty, Raw.PX.MapsTo, not; intros.
    invert H.
  Qed.

  Lemma map_add_eq :
    forall {V} (m : Map.t V) k v1 v2,
      m $+ (k,v1) $+ (k,v2) = m $+ (k,v2).
  Proof.
    intros; apply map_eq_Equal; unfold Equal; intros;
      destruct (eq_dec k y); subst; clean_map_lookups'; eauto.
  Qed.

  Lemma map_add_remove_eq :
    forall {V} (m : Map.t V) k v1,
      m $+ (k, v1) $- k = m $- k.
  Proof.
    intros. apply map_eq_Equal; unfold Equal; intros.
    destruct (eq_dec k y); subst; clean_map_lookups'; eauto.
  Qed.

  Lemma map_add_remove_neq :
    forall {V} (m : Map.t V) k1 v1 k2,
      k1 <> k2
      -> m $+ (k1, v1) $- k2 = m $- k2 $+ (k1, v1).
  Proof.
    intros. apply map_eq_Equal; unfold Equal; intros.
    destruct (eq_dec k2 y); destruct (eq_dec k1 y); intros; subst; clean_map_lookups'; eauto.
  Qed.

  Lemma remove_empty :
    forall V k,
      (@empty V) $- k = $0.
  Proof.
    intros; eapply map_eq_Equal; unfold Equal; intros; eauto.
  Qed.

  Lemma map_ne_swap :
    forall {V} (m : Map.t V) k v k' v',
      k <> k'
      -> m $+ (k,v) $+ (k',v') = m $+ (k',v') $+ (k,v).
  Proof.
    intros.
    apply map_eq_Equal; unfold Equal; intros.
    cases (eq_dec y k); cases (eq_dec y k'); subst; clean_map_lookups'; auto; contradiction.
  Qed.

  Lemma map_remove_not_in_idempotent :
    forall {V} (m : Map.t V) k1,
      m $? k1 = None
      -> m $- k1 = m.
  Proof.
    intros.
    eapply map_eq_Equal; unfold Equal; intros.
    destruct (eq_dec y k1); subst; clean_map_lookups'; eauto.
  Qed.

  Ltac Equal_eq :=
    repeat
      match goal with
      | [ H : Equal _ _ |- _] => apply map_eq_Equal in H; subst
      end.

  Lemma remove_not_in_map_idempotent :
    forall {V} (m : Map.t V) k,
      m $? k = None
      -> m $- k = m.
  Proof.
    intros; apply map_eq_Equal. unfold Equal; intros;
      destruct (eq_dec k y); subst; context_map_rewrites; clean_map_lookups'; trivial.
  Qed.

  Ltac clean_map_lookups1 :=
    clean_map_lookups1'
    || match goal with
      | [ H : context [ $0 $- _ ] |- _ ] =>
        rewrite remove_empty in H
      | [ H : context [ _ $+ (_,_) $- _ ] |- _ ] =>
        progress (
            repeat (
                (rewrite map_add_remove_neq in H by congruence)
                || (rewrite map_add_remove_eq in H by trivial)
                || (rewrite remove_empty in H)
          ) )
      end.

  Ltac clean_map_lookups := repeat clean_map_lookups1.

  Ltac solve_simple_maps1 :=
    clean_map_lookups1
    || match goal with
      | [ |- context [ _ $+ (?k1,_) $? ?k2 ] ] => destruct (eq_dec k1 k2); subst
      | [ H : context [ _ $+ (?k1,_) $? ?k2 ] |- _ ] => destruct (eq_dec k1 k2); subst
      | [ |- context [ match ?m $? ?k with _ => _ end ]] => cases (m $? k)
      | [ H : context [ match ?m $? ?k with _ => _ end ] |- _ ] => cases (m $? k)
      | [ |- context [ ?m $+ (?k,_) $+ (?k,_) ]] => rewrite map_add_eq by trivial
      (* maybe a little too specific? *)
      | [ |- context [ ?m $+ (?k1,_) $+ (?k2,_) = ?m $+ (?k2,_) $+ (?k1,_)]] => rewrite map_ne_swap by auto 2; trivial
      end.

  Ltac solve_simple_maps := repeat solve_simple_maps1.

  Ltac maps_equal1 :=
    match goal with
    | [ |- _ $+ (_,_) = _ ] => apply map_eq_Equal; unfold Equal; intros
    | [ |- _ = _ $+ (_,_) ] => apply map_eq_Equal; unfold Equal; intros
    end
    || solve_simple_maps1.

  (* TODO -- think of how to eliminate this *)
  Ltac maps_equal :=
    apply map_eq_Equal; unfold Equal; intros;
    (repeat solve_simple_maps1); trivial.

  Local Ltac dupKey k m :=
    match m with
    | add k _ _  => idtac
    | add _ _ ?m' => dupKey k m'
    end.

  Ltac canonicalize_map m :=
    match m with
    | context [ add ?k ?v ?m1 ] =>
      dupKey k m1;
      let CANON := fresh "CANON" in
      assert ( CANON : m = m $- k $+ (k,v) ) by maps_equal;
      repeat
        (rewrite map_add_remove_eq in CANON by trivial)
      || (rewrite map_add_remove_neq in CANON by eauto)
      || (rewrite remove_not_in_map_idempotent in CANON by eauto)
      ; rewrite !CANON;
      match type of CANON with
      | _ = ?m' => clear CANON; try canonicalize_map m'
      end
    end.

  Lemma canonicalize_map_test1 :
    forall {V} (m : Map.t V) k1 k2 (v1 v2 v3 : V),
      k1 <> k2
      -> m $? k1 = None
      -> m $+ (k1,v1) $+ (k2,v2) $+ (k1,v3) = m $+ (k2,v2) $+ (k1,v3).
  Proof.
    intros.
    match goal with
    | [ |- ?m = _ ] => canonicalize_map m
    end. maps_equal.
  Qed.

  Lemma canonicalize_map_test2 :
    forall {V} (m : Map.t V) k1 k2 k3 (v1 v2 v3 v4 : V),
      k1 <> k2
      -> k1 <> k3
      -> k2 <> k3
      -> m $? k1 = None
      -> m $+ (k1,v1) $+ (k2,v2) $+ (k1,v3) $+ (k3,v4) = m $+ (k2,v2) $+ (k1,v3) $+ (k3,v4).
  Proof.
    intros.
    match goal with
    | [ |- ?m = _ ] => canonicalize_map m
    end; maps_equal.
  Qed.

  Lemma canonicalize_map_test3 :
    forall {V} (m : Map.t V) k1 k2 k3 (v1 v2 v3 v4 : V),
      k1 <> k2
      -> k1 <> k3
      -> k2 <> k3
      -> m $? k1 = None
      -> m $+ (k1,v1) $+ (k2,v2) $+ (k1,v3) $+ (k2,v4) $+ (k3,v4) = m $+ (k2,v4) $+ (k1,v3) $+ (k3,v4).
  Proof.
    intros.
    match goal with
    | [ |- ?m = _ ] => canonicalize_map m
    end; maps_equal.
  Qed.

  Definition canon_map {V} (m : Map.t V) :=
    of_list (to_list m).

  Lemma canon_map_ok :
    forall {V} (m : Map.t V),
      m = canon_map m.
  Proof.
    intros.
    unfold canon_map.
    pose proof (of_list_3 m).
    apply map_eq_Equal in H.
    rewrite H.
    trivial.
  Qed.

  (* Use if the keys are concrete. Faster and it sorts by key so order is consistent *)
  Definition canonicalize_concrete_map {V} (m : Map.t V) : Map.t V.
    destruct m.
    unfold Raw.t in this0.
    let f := constr:(fun (acc : Map.t V) (cur : OT.t * V) =>
                       let (k, v) := cur
                       in acc $+ (k, v))
    in let m' := (eval simpl in (fold_left f this0 $0))
       in apply m'.
  Defined.

  Ltac canonicalize_concrete_map m :=
    let m' := (eval simpl in (canonicalize_concrete_map m))
    in replace m with m' in * by maps_equal.

  Section MapPredicates.
    Variable V : Type.
    Variable P : V -> Prop.

    Inductive Forall_natmap : Map.t V -> Prop :=
    | Empty_Natmap : Forall_natmap $0
    | Add_Natmap k v (m : Map.t V) :
        P v
        -> Forall_natmap m
        -> Forall_natmap ( m $+ (k,v)).

    Lemma Forall_natmap_forall :
      forall m,
        Forall_natmap m <-> (forall k v, m $? k = Some v -> P v).
    Proof.
      split.
      - induction 1; intros; solve_simple_maps; eauto.
      - induction m using P.map_induction_bis; intros; Equal_eq; eauto.
        econstructor; solve_simple_maps; eauto.

        assert (Forall_natmap m).
        eapply IHm; intros.
        apply H0 with (k:=k); solve_simple_maps; eauto.

        econstructor; eauto.
        eapply H0 with (k := x); clean_map_lookups; auto.
    Qed.

    Lemma Forall_natmap_in_prop :
      forall k v m,
        Forall_natmap m
        -> m $? k = Some v
        -> P v.
    Proof.
      intros.
      rewrite Forall_natmap_forall in H; eauto.
    Qed.

    Lemma Forall_natmap_in_prop_add :
      forall k v m,
        Forall_natmap (m $+ (k,v))
        -> P v.
    Proof.
      intros.
      eapply Forall_natmap_in_prop with (k:=k); eauto; clean_map_lookups; trivial.
    Qed.

    Lemma Forall_natmap_split :
      forall k v m,
        Forall_natmap (m $+ (k,v))
        -> ~ In k m
        -> Forall_natmap m
          /\ P v.
    Proof.
      intros.
      rewrite Forall_natmap_forall in *; intros.
      assert (P v) by (eapply H with (k:=k); clean_map_lookups; trivial).
      split; auto; intros.
      destruct (eq_dec k k0); subst; clean_map_lookups; eauto.
      eapply H with (k:=k0); clean_map_lookups; trivial.
    Qed.

  End MapPredicates.

  Export Map F P.

End MyOrderedMap.

Module Export NatMap := MyOrderedMap( Nat_as_OT ).
Module NatMapNotation.
  Notation "$0" := (empty _).
  Notation "m $+ ( k , v )" := (add k v m) (at level 50, left associativity).
  Notation "m $- k" := (remove k m) (at level 50, left associativity).
  Notation "m $? k" := (find k m) (at level 50, left associativity).
End NatMapNotation.

Export NatMapNotation.

Definition merge_maps {V : Type} (m1 m2 : Map.t V) : Map.t V :=
  fold (fun k v m => m $+ (k,v) ) m1 m2.

Notation "m1 $++ m2" := (merge_maps m2 m1) (at level 50, left associativity).

Lemma add_empty_idempotent :
  forall V (m : Map.t V),
    m $++ $0 = m.
Proof.
  intros; unfold merge_maps, Map.fold, Map.Raw.fold; simpl; auto.
Qed.

Lemma empty_add_idempotent :
  forall {V}(m : Map.t V),
    $0 $++ m = m.
Proof.
  intros; unfold merge_maps.
  apply P.fold_rec.
  - intros.
    apply P.elements_Empty in H; simpl in *.
    apply map_eq_elements_eq; auto.

  - intros. subst.
    apply map_eq_Equal. unfold Map.Equal; intros.
    unfold P.Add in H1. specialize (H1 y). symmetry; auto.
Qed.

Ltac m_equal :=
  repeat match goal with
         | [ |- context[_ $+ (?k,_) $? ?k ] ]  =>
           rewrite add_eq_o by (simple apply @eq_refl)
         | [ |- context[_ $+ (?k',_) $? ?k] ] =>
           rewrite add_neq_o by ( (unfold not; intros ?SIMPLEQ; invert SIMPLEQ) || intuition idtac )
         | [ |- context[$0 $++ _ ] ] => rewrite empty_add_idempotent
         | [ |- context[_ $++ $0 ] ] => rewrite add_empty_idempotent
         | [ |- (_ $+ (_,_)) = _ ] => unfold Map.add, Map.Raw.add; simpl
         | [ |- {| Map.this := _ ; Map.sorted := _ |} = _ ] => eapply map_eq_fields_eq
         | [ H : Map.Empty ?m |- $0 = ?m ] => eapply Empty_eq_empty; exact H
         | [ H : Map.Empty ?m |- ?m = $0 ] => symmetry
         | [ |- Map.empty _ = _ ] => unfold Map.empty, Map.Raw.empty, remove, Map.Raw.remove; simpl
         end.

Section ConcreteMaps.

  Definition next_key {V} (m : Map.t V) : nat :=
    match O.max_elt m with
    | None => 0
    | Some (k,v) => S k
    end.

  Lemma next_key_not_in :
    forall {V} (m : Map.t V) k,
      k = next_key m
      -> m $? k = None.
  Proof.
    unfold next_key; intros.
    cases (O.max_elt m); subst.
    - destruct p; simpl.
      cases (m $? S k); eauto.
      exfalso.

      assert (O.Above k (m $- k)) by eauto using O.max_elt_Above.
      specialize (H (S k)).

      assert (In (S k) (m $- k)).
      rewrite in_find_iff; unfold not; intros.
      rewrite remove_neq_o in H0 by eauto; contra_map_lookup.
      specialize (H H0).

      assert (k < S k) by eauto using Nat.lt_succ_diag_r.
      assert (S k < S k) by eauto using Nat.lt_trans.

      assert (~ (S k < S k)) by eauto using OTF.lt_antirefl.
      contradiction.

    - apply O.max_elt_Empty in Heq.
      apply Empty_eq_empty in Heq; subst.
      apply lookup_empty_none.
  Qed.

End ConcreteMaps.


From CoqMTL Require Import Control.All.
From CoqMTL Require Import Control.Monad.Trans.
From CoqMTL Require Import Control.Monad.Class.All.
From CoqMTL Require Import Control.Monad.Identity.

(** A transformer which adds a layer of error handling monad on top of the
    base monad [M]. *)
Definition SumT (E : Type) (M : Type -> Type) (A : Type)
  : Type := M (sum E A).

(** Definitions of [fmap], [pure], [ap], [bind] and so on are similar to
    these for the ordinary [sum] monad, but we need to insert [M]'s
    [pure] and [bind] in appropriate places. *)

Definition fmap_SumT
  {M : Type -> Type} {inst : Monad M} {E A B : Type} (f : A -> B)
  : SumT E M A -> SumT E M B :=
    fmap (fun sa : sum E A =>
    match sa with
    | inl e => inl e
    | inr a => inr (f a)
    end).

#[global] Hint Unfold SumT fmap_SumT : CoqMTL.

#[refine]
#[export]
Instance Functor_SumT
  {M : Type -> Type} {inst : Monad M} {E : Type} : Functor (SumT E M) :=
{
  fmap := @fmap_SumT M inst E;
}.
Proof. all: hs; mtrans; monad. Defined.

Definition pure_SumT
  {M : Type -> Type} {inst : Monad M} {E A : Type} (x : A)
  : SumT E M A := pure (inr x).

Definition ap_SumT
  {M : Type -> Type} {inst : Monad M} {E A B : Type}
  (msf : SumT E M (A -> B)) (msx : SumT E M A) : SumT E M B :=
    @bind M inst _ _ msf (fun sf =>
      match sf with
      | inl e => pure (inl e)
      | inr f =>
          @bind M inst _ _ msx (fun sx =>
          match sx with
              | inl e => pure (inl e)
              | inr x => pure (inr (f x))
          end)
      end).

#[global] Hint Unfold pure_SumT ap_SumT : CoqMTL.

#[refine]
#[export]
Instance Applicative_SumT
  (E : Type) (M : Type -> Type) (inst : Monad M) : Applicative (SumT E M) :=
{
  is_functor := @Functor_SumT M inst E;
  pure := @pure_SumT M inst E;
  ap := @ap_SumT M inst E;
}.
Proof. all: monad. Defined.

(** [SumT] is not [Alternative], just as the ordinary [sum]. *)

Lemma SumT_not_Alternative :
  (forall (E : Type) (M : Type -> Type) (inst : Monad M),
    Alternative (SumT E M)) -> False.
Proof.
  intros. destruct (X False Identity Monad_Identity).
  clear -aempty. specialize (aempty False).
  compute in aempty. destruct aempty; assumption.
Qed.

(** If the base monad [M] is [Alternative], it doesn't help much. *)

Definition aempty_SumT
  (E : Type) {M : Type -> Type} {instA : Alternative M}
  {A : Type} : SumT E M A := fmap inr aempty.

Definition aplus_SumT
  {E : Type} {M : Type -> Type} {instA : Alternative M}
  {A : Type} (x y : SumT E M A) : SumT E M A :=
    @aplus _ instA _ x y.

#[global] Hint Unfold aempty_SumT aplus_SumT : CoqMTL.

#[refine]
#[export]
Instance Alternative_SumT
  (E : Type) (M : Type -> Type) (instM : Monad M) (instA : Alternative M)
  : Alternative (SumT E M) :=
{
  is_applicative := Applicative_SumT E M instM;
  aempty := @aempty_SumT E M instA;
  aplus := @aplus_SumT E M instA;
}.
Proof. all: monad. Abort.

Definition bind_SumT
  {M : Type -> Type} {inst : Monad M} {E A B : Type}
  (ma : SumT E M A) (f : A -> SumT E M B) : SumT E M B :=
    @bind M inst _ _ ma (fun sa : E + A =>
    match sa with
    | inl e => pure (inl e)
    | inr a => f a
    end).

#[global] Hint Unfold bind_SumT : CoqMTL.

#[refine]
#[export]
Instance Monad_SumT
  (E : Type) (M : Type -> Type) (inst : Monad M) : Monad (SumT E M) :=
{
  is_applicative := @Applicative_SumT E M inst;
  bind := @bind_SumT M inst E;
}.
Proof. all: hs; monad. Defined.

(** We can lift a computation by wrapping it in the [inr] constructor. *)
Definition lift_SumT
  (E : Type) {M : Type -> Type} {inst : Monad M} {A : Type} (ma : M A)
  : SumT E M A := fmap inr ma.

#[global] Hint Unfold lift_SumT : CoqMTL.

#[refine]
#[export]
Instance MonadTrans_SumT (E : Type) : MonadTrans (SumT E) :=
{
  is_monad := @Monad_SumT E;
  lift := @lift_SumT E;
}.
Proof. all: monad. Defined.

(** [SumT M] is supposed to enrich [M] with error handling capabilities,
    but there is a lot of problems. *)

(** The first problem is that [SumT M] can fail only if the error type
    [E] is inhabited. We use this inhabitant to represent failure, but
    this means there are as many instances of [MonadFail] as there are
    inhabitants of [E]. *)
Definition fail_SumT
  {E : Type} (e : E) {M : Type -> Type} {inst : Monad M} {A : Type}
    : SumT E M A := pure (inl e).

#[refine]
#[export]
Instance MonadFail_SumT
  (E : Type) (M : Type -> Type) {inst : Monad M} (e : E)
  : MonadFail (SumT E M) (Monad_SumT E M inst) :=
{
  fail := @fail_SumT E e M inst;
}.
Proof. intros. unfold fail_SumT. hs. Defined.

(** The problem with [MonadExcept] is lies in the law [catch_fail_r]. It
    boils down to the fact that there are various ways of failing. One
    of them is [fail], but there are others, like [inl e] for any [e : E].
    Since [E] may have more than one inhabitant, there may be more than one
    way to fail and the law [catch_fail_r] doesn't hold. *)
#[refine]
#[export]
Instance MonadExcept_SumT
  (E : Type) (e : E) (M : Type -> Type)
  (inst : Monad M) (inst' : MonadExcept M inst)
  : MonadExcept (SumT E M) (Monad_SumT E M inst) :=
{
  instF := @MonadFail_SumT E M inst e;
  catch :=
    fun A x y =>
    @bind M inst _ _ x (fun ea =>
    match ea with
    | inl e => y
    | inr a => pure (inr a)
    end);
}.
Proof.
(*
  all: cbn; intros.
    unfold fail_SumT. rewrite bind_pure_l. reflexivity.
    Focus 2. rewrite bind_assoc. f_equal. ext ea. destruct ea.
      reflexivity.
      rewrite bind_pure_l. reflexivity.
    Focus 2. unfold pure_SumT. rewrite bind_pure_l. reflexivity.
    rewrite <- (@bind_pure_r M inst _ x) at 2. f_equal.
      ext ea. destruct ea.
        Focus 2. reflexivity.
        unfold fail_SumT.
*)
Abort.

(** [SumT] preserves [MonadAlt] but not [MonadNondet] (and thus not
    [MonadStateNondet]). The problem is that [SumT] has its own [fail],
    but only inherits [choose] from [M]'s [MonadAlt] and these two may
    be incompatible. *)

#[refine]
#[export]
Instance MonadAlt_SumT
  (E : Type) (M : Type -> Type) (inst : Monad M) (inst' : MonadAlt M inst)
  : MonadAlt (SumT E M) (Monad_SumT E M inst) :=
{
  choose :=
    fun A x y => @choose M inst inst' _ x y;
}.
Proof.
  intros. rewrite choose_assoc. reflexivity.
  intros. cbn. unfold bind_SumT. rewrite bind_choose_l. reflexivity.
Defined.

#[refine]
#[export]
Instance MonadNondet_SumT
  (E : Type) (e : E) (M : Type -> Type)
  (inst : Monad M) (inst' : MonadNondet M inst)
  : MonadNondet (SumT E M) (Monad_SumT E M inst) :=
{
  instF := @MonadFail_SumT E M inst e;
  instA := @MonadAlt_SumT E M inst (@instA _ _ inst');
}.
Proof.
  intros. cbn. unfold fail_SumT. admit.
  intros. cbn. unfold fail_SumT. admit.
Admitted.

(** [SumT] preserves [MonadReader] and [MonadState], but not (yet)
    [MonadWriter]. *)

#[refine]
#[export]
Instance MonadReader_SumT
  (E R : Type) (M : Type -> Type)
  (inst : Monad M) (inst' : MonadReader R M inst)
  : MonadReader R (SumT E M) (Monad_SumT E M inst) :=
{
  ask := ask >>= fun x => pure (inr x);
}.
Proof.
  rewrite <- ask_ask at 3. rewrite !constrA_spec. monad.
Defined.

(** The problem with [MonadWriter] lies in the fact that we use [bind]
    in the definition of [listen], which prevents us from proving the
    law [listen_listen]. *)

#[refine]
#[export]
Instance MonadWriter_SumT
  (W : Monoid) (E : Type) (M : Type -> Type)
  (inst : Monad M) (inst' : MonadWriter W M inst)
  : MonadWriter W (SumT E M) (Monad_SumT E M inst) :=
{
  tell w := fmap inr (tell w);
  listen :=
    fun A (m : M (E + A)%type) =>
    listen m >>=
      fun '(ea, w) => pure
      match ea with
      | inl e => inl e
      | inr a => inr (a, w)
      end;
}.
Proof.
  intros. cbn. unfold pure_SumT.
    rewrite listen_pure, bind_pure_l. reflexivity.
  intros. cbn. unfold fmap_SumT.
Abort.

#[refine]
#[export]
Instance MonadState_SumT
  (E S : Type) (M : Type -> Type)
  (inst : Monad M) (inst' : MonadState S M inst)
  : MonadState S (SumT E M) (Monad_SumT E M inst) :=
{
  get := get >>= fun x => pure (inr x);
  put := fun s => put s >> pure (inr tt);
}.
Proof.
  all: intros.
    monad.
    rewrite !constrA_spec. cbn. unfold bind_SumT, pure_SumT.
      rewrite !bind_assoc. rewrite !bind_pure_l.
      rewrite <- constrA_spec, constrA_bind_assoc, put_get.
      rewrite <- constrA_bind_assoc, bind_pure_l, <- constrA_spec.
      reflexivity.
    cbn. unfold bind_SumT, pure_SumT.
      rewrite bind_assoc, <- fmap_pure at 1.
      rewrite <- get_put, fmap_bind. f_equal. monad.
    cbn. unfold bind_SumT. rewrite !bind_assoc.
      replace
        (fun x : S =>
          pure (inr x) >>=
            fun sa : E + S =>
            match sa with
            | inl e => pure (inl e)
            | inr a => k a a
            end)
      with
        (fun s : S => k s s).
      rewrite <- get_get. f_equal. monad.
      ext s. rewrite bind_pure_l. reflexivity.
Defined.

(* TODO *)
#[refine]
#[export]
Instance MonadStateNondet_SumT
  (E S : Type) (e : E) (M : Type -> Type)
  (inst : Monad M) (inst' : MonadStateNondet S M inst)
  : MonadStateNondet S (SumT E M) (Monad_SumT E M inst) :=
{
  instS := MonadState_SumT E S M inst inst';
  instN := MonadNondet_SumT E e M inst inst';
}.
Proof.
Abort.

(** If [M] is the free monad of [F], so is [SumT E M]. *)
#[refine]
#[export]
Instance MonadFree_SumT
  (F : Type -> Type) (instF : Functor F)
  (E : Type) (M : Type -> Type)
  (instM : Monad M) (instMF : MonadFree F M instF instM)
  : MonadFree F (SumT E M) instF (Monad_SumT E M instM) :=
{
  wrap := fun A m => @wrap F M instF instM instMF _ m;
}.
Proof.
  intros. cbn. unfold bind_SumT, pure_SumT,SumT in *.
  rewrite wrap_law.
  rewrite (wrap_law _ _ (fun a : A => pure (inr a)) x).
  monad.
Defined.


(*
Copyright © 2006-2008 Russell O’Connor

Permission is hereby granted, free of charge, to any person obtaining a copy of
this proof and associated documentation files (the "Proof"), to deal in
the Proof without restriction, including without limitation the rights to
use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of
the Proof, and to permit persons to whom the Proof is furnished to do so,
subject to the following conditions:

The above copyright notice and this permission notice shall be included in all
copies or substantial portions of the Proof.

THE PROOF IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS
FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR
COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER
IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
CONNECTION WITH THE PROOF OR THE USE OR OTHER DEALINGS IN THE PROOF.
*)
Require Import CoRN.metric2.Metric.
Require Import CoRN.metric2.UniformContinuity.
Require Import CoRN.reals.fast.CRAlternatingSum.
Require Import CoRN.reals.fast.CRstreams.
Require Import CoRN.model.totalorder.QposMinMax.
Require Import CoRN.model.totalorder.QMinMax.
Require Import Coq.QArith.Qpower.
Require Import Coq.QArith.Qabs.
Require Import Coq.ZArith.Zdiv.

Set Implicit Arguments.

Opaque Qabs.

Local Open Scope Q_scope.

Import MathClasses.theory.CoqStreams.

(** [InfiniteSum] approximates the limit of the series s within err_prop. *)
(* This Fixpoint is fat because the fuel is a unary nat,
   which can waste a lot of memory in normal form inside vm_compute. *)
Fixpoint InfiniteSum_fat (filter:Stream Q -> bool) (s:Stream Q) (q : Q) (fuel:nat) : Q
  := if filter s
     then q
     else match fuel with
          | O => q
          | S p => InfiniteSum_fat filter (tl s) (Qplus' q (hd s)) p
          end.

Definition InfiniteSum_raw_F (cont: Stream Q -> Q -> Q)
           (err_prop:Stream Q -> bool) (s:Stream Q) (q : Q) : Q :=
  if (err_prop s)
  then q (* the error is small enough, stop the sum *)
  else cont (tl s) (Qplus' q (hd s)). (* continue the calculations *)

(** Sum a rational stream up to the first index at which the filter
    Stream Q -> bool equals true, or 2^n.
    n is intended as a termination proof (fuel). It is otherwise useless
    for the calculations and we want it as small as possible in memory,
    because vm_compute will start by computing its normal form.
    By choosing 2^n we make the fuel logarithmic in the actual number of iterations.
    cont is a continuation that holds the rest of the computations
    to do in the recursion, it starts with fun _ q => q.
    This has the same calculation speed as InfiniteSum_fat, and
    should take less memory. *)
Fixpoint InfiniteSum_raw_N (n:nat) (filter: Stream Q -> bool)
         (cont: Stream Q -> Q -> Q) {struct n}
  : Stream Q -> Q -> Q :=
match n with
| O => InfiniteSum_raw_F cont filter
| S p => InfiniteSum_raw_N p filter (fun s => InfiniteSum_raw_N p filter cont s)
end.

(*
Remark : the eta expension here is important, else the virtual machine will
compute the value of (InfiniteGeometricSum_raw_N n') before
reducing the call of InfiniteGeometricSum_raw_F.*)

(* Get an idea of how the recursion goes. The continuation will
   unfold n layers deep, before being folded by additions. *)
Lemma InfiniteSum_raw_N_unfold : forall n cont (filter : Stream Q -> bool) s,
    InfiniteSum_raw_N (S (S n)) filter cont s
    = InfiniteSum_raw_N
        n filter (fun s0 => InfiniteSum_raw_N
                           n filter (fun s1 => InfiniteSum_raw_N
                                              (S n) filter cont s1) s0) s.
Proof.
  reflexivity.
Qed.

Lemma InfiniteSum_fat_plus
  : forall (fuel:nat) (filter:Stream Q -> bool) (s:Stream Q) (q : Q),
    InfiniteSum_fat filter s q fuel == q + InfiniteSum_fat filter s 0 fuel.
Proof.
  induction fuel.
  - intros. simpl. destruct (filter s); rewrite Qplus_0_r; reflexivity.
  - intros. simpl. destruct (filter s). symmetry. apply Qplus_0_r.
    rewrite IHfuel.
    rewrite (IHfuel filter (tl s) (Qplus' 0 (hd s))).
    rewrite Qplus_assoc. apply Qplus_comp. 2: reflexivity.
    rewrite Qplus'_correct, Qplus'_correct, Qplus_0_l. reflexivity.
Qed.

Lemma InfiniteSum_fat_remove_filter
  : forall (fuel:nat) (filter:Stream Q -> bool) (s:Stream Q) (q : Q),
    filter (Str_nth_tl fuel s) = true
    -> exists n:nat,
      InfiniteSum_fat filter s q fuel
      = InfiniteSum_fat (fun _ => false) s q n
      /\ (forall p:nat, lt p n -> filter (Str_nth_tl p s) = false)
      /\ filter (Str_nth_tl n s) = true.
Proof.
  induction fuel.
  - intros. exists O.
    split. 2: split. simpl. destruct (filter s); reflexivity.
    intros. exfalso; inversion H0. exact H.
  - intros. destruct (filter s) eqn:des.
    + exists O. split. 2: split. simpl. rewrite des. reflexivity.
      intros. exfalso; inversion H0. exact des.
    + specialize (IHfuel filter (tl s) (Qplus' q (hd s)) H) as [n [H1 H2]].
      exists (S n). split. 2: split.
      simpl. rewrite des. rewrite H1. reflexivity.
      intros. destruct p. exact des.
      simpl. apply H2. apply le_S_n in H0. exact H0.
      apply H2.
Qed.

Lemma InfiniteSum_fat_add_stop
  : forall (p n : nat) (s : Stream Q) (filter : Stream Q -> bool) (q : Q),
    le n p
    -> filter (Str_nth_tl n s) = true
    -> InfiniteSum_fat filter s q p
      = InfiniteSum_fat filter s q n.
Proof.
  induction p.
  - intros n s filter q H H0.
    inversion H. reflexivity.
  - intros n s filter q H H0.
    destruct n.
    + simpl in H0. simpl. rewrite H0. reflexivity.
    + specialize (IHp n (tl s) filter).
      simpl.
      destruct (filter s) eqn:des. reflexivity.
      rewrite IHp. reflexivity. apply le_S_n, H. exact H0.
Qed.

Lemma InfiniteSum_fat_extend
  : forall (n : nat) (s : Stream Q) (filter : Stream Q -> bool) (q : Q),
    filter (Str_nth_tl n s) = true
    -> InfiniteSum_fat filter s q n
      = InfiniteSum_fat filter s q (S n).
Proof.
  intros. symmetry. apply InfiniteSum_fat_add_stop.
  apply le_S, le_refl. exact H.
Qed.

Lemma InfiniteSum_fat_add_pass
  : forall (n p : nat) (s : Stream Q) (filter : Stream Q -> bool) (q : Q),
    (forall k:nat, lt k n -> filter (Str_nth_tl k s) = false)
    -> InfiniteSum_fat filter s q (n+p)
      = InfiniteSum_fat
          filter (Str_nth_tl n s) (InfiniteSum_fat filter s q n) p.
Proof.
  induction n.
  - intros. simpl.
    destruct (filter s); reflexivity.
  - intros.
    pose proof (H O (le_n_S 0 n (le_0_n _))) as zeroFalse.
    simpl in zeroFalse.
    simpl. rewrite zeroFalse.
    rewrite IHn. reflexivity.
    intros k H0. destruct n. exfalso; inversion H0.
    apply Nat.le_succ_r in H0. destruct H0.
    apply (H (S k)), le_n_S, le_S, H0.
    inversion H0. subst k.
    apply (H (S n) (le_refl _)).
Qed.

Lemma decide_filter_before_n
  : forall (n : nat) (filter : Stream Q -> bool) (s : Stream Q),
    (exists p:nat, lt p n /\ filter (Str_nth_tl p s) = true)
    \/ (forall p:nat, lt p n -> filter (Str_nth_tl p s) = false).
Proof.
  induction n.
  - intros. right.
    intros. exfalso. inversion H.
  - intros. destruct (filter (Str_nth_tl n s)) eqn:des.
    left. exists n. split. apply le_refl. exact des.
    destruct (IHn filter s).
    + left. destruct H as [p [H H0]]. exists p.
      split. apply le_S, H. exact H0.
    + right. intros.
      apply Nat.le_succ_r in H0. destruct H0.
      apply H, H0. inversion H0. subst p. exact des.
Qed.

Lemma InfiniteSum_raw_N_step
  : forall (fuel : nat) c (filter : Stream Q -> bool) (s : Stream Q) (q : Q),
    (forall p:nat, p < 2 ^ fuel -> filter (Str_nth_tl p s) = false)%nat
    -> InfiniteSum_raw_N fuel filter c s q
      = c (Str_nth_tl (2^fuel) s)
          (InfiniteSum_raw_N fuel filter (fun _ r => r) s q).
Proof.
  induction fuel.
  - intros. simpl. unfold InfiniteSum_raw_F.
    destruct (filter s) eqn:des. 2: reflexivity.
    exfalso. specialize (H O (le_refl _)). simpl in H.
    rewrite H in des. discriminate.
  - intros. simpl.
    assert (forall p : nat, (p < 2 ^ fuel)%nat -> filter (Str_nth_tl p s) = false) as firstHalf.
    { intros. apply (H p).
      simpl. rewrite Nat.add_0_r.
      apply (lt_le_trans _ (0+2^fuel)).
      exact H0. apply Nat.add_le_mono_r, le_0_n. }
    rewrite IHfuel, IHfuel.
    3: exact firstHalf.
    rewrite Nat.add_0_r, Str_nth_tl_plus.
    apply f_equal. symmetry. apply IHfuel.
    exact firstHalf.
    intros. rewrite Str_nth_tl_plus. apply H.
    simpl. rewrite Nat.add_0_r.
    apply Nat.add_lt_mono_r, H0.
Qed.

(* The initial continuation is not reached when
   the filter is triggered before. *)
Lemma InfiniteSum_raw_N_cont_invariant
  : forall (fuel p : nat) c d (filter : Stream Q -> bool) (s : Stream Q) (q : Q),
    (p < 2 ^ fuel)%nat
    -> filter (Str_nth_tl p s) = true
    -> InfiniteSum_raw_N fuel filter c s q
      = InfiniteSum_raw_N fuel filter d s q.
Proof.
  induction fuel.
  - intros. simpl in H. simpl.
    unfold InfiniteSum_raw_F.
    destruct (filter s) eqn:des. reflexivity.
    apply le_S_n in H. inversion H.
    exfalso. subst p. simpl in H0.
    rewrite H0 in des. discriminate.
  - intros. simpl. simpl in H. rewrite Nat.add_0_r in H.
    destruct (decide_filter_before_n (2^fuel) filter s).
    destruct H1 as [k [H1 H2]]. apply (IHfuel k).
    exact H1. exact H2.
    (* Now 2^fuel <= p *)
    destruct (Nat.lt_ge_cases p (2^fuel)).
    exfalso. specialize (H1 p H2). rewrite H0 in H1. discriminate.
    apply Nat.le_exists_sub in H2.
    destruct H2 as [k [H2 _]]. subst p.
    rewrite <- Str_nth_tl_plus in H0.
    rewrite (InfiniteSum_raw_N_step
               fuel (fun s0 : Stream Q => InfiniteSum_raw_N fuel filter c s0)).
    2: exact H1.
    rewrite (InfiniteSum_raw_N_step
               fuel (fun s0 : Stream Q => InfiniteSum_raw_N fuel filter d s0)).
    2: exact H1.
    apply (IHfuel k).
    apply Nat.add_lt_mono_r in H. exact H. exact H0.
Qed.

Lemma InfiniteSum_raw_N_correct
  : forall (fuel : nat) (s : Stream Q) (filter : Stream Q -> bool) (q : Q),
    InfiniteSum_raw_N fuel filter (fun _ r => r) s q
    = InfiniteSum_fat filter s q (2 ^ fuel)%nat.
Proof.
  induction fuel.
  - intros. simpl. unfold InfiniteSum_raw_F.
    destruct (filter s). reflexivity. simpl.
    destruct (filter (tl s)); reflexivity.
  - intros s filter q. simpl. rewrite Nat.add_0_r.
    destruct (decide_filter_before_n (2^fuel)%nat filter s).
    + destruct H as [p [H H0]].
      rewrite (@InfiniteSum_fat_add_stop _ p).
      3: exact H0.
      rewrite <- (@InfiniteSum_fat_add_stop (2^fuel)).
      2: apply (le_trans _ (S p) _ (le_S _ _ (le_refl p)) H).
      2: exact H0.
      rewrite <- IHfuel.
      apply (@InfiniteSum_raw_N_cont_invariant fuel p).
      exact H. exact H0.
      apply (le_trans _ (2^fuel + 0)).
      rewrite Nat.add_0_r.
      apply (le_trans _ (S p) _ (le_S _ _ (le_refl p)) H).
      apply Nat.add_le_mono_l, le_0_n.
    + rewrite InfiniteSum_fat_add_pass. 2: exact H.
      rewrite <- IHfuel. rewrite <- IHfuel.
      rewrite InfiniteSum_raw_N_step. reflexivity. exact H.
Qed.

Lemma InfiniteSum_raw_N_extend : forall (p q:nat) s (err : Stream Q -> bool) (r:Q),
 (Is_true (err (Str_nth_tl (2^p) s))) -> (p <= q)%nat ->
 InfiniteSum_raw_N p err (fun _ r => r) s r
 = InfiniteSum_raw_N q err (fun _ r => r) s r.
Proof.
  intros.
  rewrite InfiniteSum_raw_N_correct, InfiniteSum_raw_N_correct.
  symmetry. apply InfiniteSum_fat_add_stop.
  apply Nat.pow_le_mono_r. discriminate. exact H0.
  unfold Is_true in H.
  destruct (err (Str_nth_tl (2 ^ p) s)).
  reflexivity. contradiction.
Qed.

Lemma InfiniteSum_fat_minus
  : forall (i p : nat) (s : Stream Q) (q : Q),
    InfiniteSum_fat (fun _ => false) s q (p + i) -
    InfiniteSum_fat (fun _ => false) s q i
    == InfiniteSum_fat (fun _ => false) (Str_nth_tl i s) 0 p.
Proof.
  induction i.
  - intros. simpl. rewrite Nat.add_0_r.
    unfold Qminus. rewrite InfiniteSum_fat_plus.
    ring.
  - intros. rewrite Nat.add_succ_r. simpl.
    rewrite IHi. reflexivity.
Qed.

Lemma InfiniteSum_fat_wd
  : forall (fuel:nat) (filter:Stream Q -> bool) (s:Stream Q) (q r : Q),
    q == r
    -> InfiniteSum_fat filter s q fuel
      == InfiniteSum_fat filter s r fuel.
Proof.
  induction fuel.
  - intros. simpl. destruct (filter s); exact H.
  - intros. simpl. destruct (filter s). exact H.
    apply IHfuel. rewrite Qplus'_correct, Qplus'_correct.
    apply Qplus_comp. exact H. reflexivity.
Qed.

(**
** Geometric Series
A geometric series is simple to sum.  However we do something slightly
more general.  We sum a series that satifies the ratio test. *)

Section GeometricSeries.
Variable a : Q.

Hypothesis Ha0 : 0 <= a.
Hypothesis Ha1 : a < 1.

(** The definition of what we are calling a [GeometricSeries]: a series
that satifies the ratio test. *)
Definition GeometricSeries := ForAll (fun s => Qabs ((hd (tl s))) <= a*(Qabs(hd s))).

(** [err_bound] majorates the distance between
    the head of the series and its limit. *)
Let err_bound (s:Stream Q) : Q := Qabs (hd s)/(1-a).

(** [err_prop]: is err a bound on the series s? *)
Let err_prop (err:Q) (s:Stream Q) : bool :=
match ((err_bound s) ?= err) with
 Gt => false
|_ => true
end.

Lemma err_prop_prop : forall e s, err_prop e s = true <-> err_bound s <= e.
Proof.
 intros e s.
 unfold err_prop, err_bound, Qcompare, Qle, Z.le.
 destruct (Qnum (Qabs (hd s) / (1 - a))%Q * Zpos (Qden e) ?= Qnum e * Zpos (Qden (Qabs (hd s) / (1 - a))%Q))%Z;
   split; auto with *.
Qed.

Lemma err_prop_nonneg : forall e s, err_prop e s = true -> 0 <= e.
Proof.
  intros. apply err_prop_prop in H.
  refine (Qle_trans _ _ _ _ H).
  apply Qmult_le_0_compat. apply Qabs_nonneg.
  apply Qlt_le_weak, Qinv_lt_0_compat.
  unfold Qminus. rewrite <- Qlt_minus_iff. exact Ha1.
Qed.

(** The key lemma about error bounds. *)
Lemma err_prop_key : forall (e:Q) (s: Stream Q) (x:Q),
 err_prop e s = true -> Qabs x <= a*e -> Qabs (Qplus' (hd s) x) <= e.
Proof.
 intros e s x Hs Hx.
 rewrite -> Qplus'_correct.
 eapply Qle_trans.
  apply Qabs_triangle.
  setoid_replace e with (e*(1-a) + a*e)
    by (unfold canonical_names.equiv, stdlib_rationals.Q_eq; simpl; ring).
 assert (X:0 < 1 - a).
  change (0 < 1 + - a).
  rewrite <- Qlt_minus_iff.
  assumption.
 apply Qplus_le_compat; try assumption.
 rewrite -> err_prop_prop in Hs.
 unfold err_bound in Hs.
 apply Qmult_lt_0_le_reg_r with (/(1-a)).
  apply Qinv_lt_0_compat; assumption.
  rewrite <- Qmult_assoc, Qmult_inv_r, Qmult_1_r.
  assumption.
 auto with *.
Qed.

Lemma err_prop_key' : forall (e:Q) (s: Stream Q),
 GeometricSeries s -> err_prop e s = true -> err_prop (a*e) (tl s) = true.
Proof.
 intros e s [H _] Hs.
 rewrite -> err_prop_prop in *.
 unfold err_bound in *.
 rewrite -> Qle_minus_iff in H, Hs |- *.
 rewrite -> Qlt_minus_iff in Ha1.
 setoid_replace (a * e + - (Qabs (hd (tl s)) / (1 - a)))
   with (a * (e + - (Qabs (hd s)/(1-a)))+ (a * Qabs (hd s) + - Qabs (hd (tl s)))/(1+-a))
   by (unfold canonical_names.equiv, stdlib_rationals.Q_eq; simpl; field).
 rewrite <- Qplus_0_r.
 apply Qplus_le_compat.
 apply Qmult_le_0_compat. exact Ha0. exact Hs.
 apply Qmult_le_0_compat. exact H.
 apply Qlt_le_weak, Qinv_lt_0_compat, Ha1.
 intro abs. rewrite abs in Ha1. exact (Qlt_irrefl 0 Ha1).
Qed.

Lemma err_prop_monotone : forall (e0 e1:Q) (s: Stream Q),
    (e0 <= e1) -> err_prop e0 s = true -> err_prop e1 s = true.
Proof.
 intros e0 e1 s He H.
 rewrite ->  err_prop_prop in *.
 apply Qle_trans with e0; assumption.
Qed.

Lemma err_prop_monotone' : forall (e:Q) (s: Stream Q),
    GeometricSeries s -> err_prop e s = true -> err_prop e (tl s) = true.
Proof.
 intros e s Hs H.
 rewrite -> err_prop_prop in *.
 eapply Qle_trans;[|apply H].
 unfold err_bound.
 apply Qmult_le_r.
 - apply Qinv_lt_0_compat. unfold Qminus.
   rewrite <- Qlt_minus_iff. exact Ha1.
 - destruct Hs as [H0 _].
   eapply Qle_trans;[apply H0|].
   rewrite <- (Qmult_1_l (Qabs(hd s))) at 2.
   apply Qmult_le_compat_r.
   apply Qlt_le_weak, Ha1. apply Qabs_nonneg.
Qed.

(** If a geometric sum s is bounded by e,
    summing s to any index p is within bound e. *)
Lemma err_prop_correct : forall (p:nat) (e:Q) (s : Stream Q) (e':Stream Q -> bool),
    GeometricSeries s
    -> err_prop e s = true
    -> Qabs (InfiniteSum_fat e' s 0%Q p) <= e.
Proof.
  induction p.
  - intros. simpl. apply err_prop_nonneg in H0.
    destruct (e' s); exact H0.
  - intros. simpl.
    destruct (e' s). apply err_prop_nonneg in H0. exact H0.
    rewrite InfiniteSum_fat_plus.
    rewrite Qplus'_correct, Qplus_0_l.
    rewrite <-  Qplus'_correct.
    apply err_prop_key. exact H0.
    apply (IHp (a*e)). apply H.
    apply err_prop_key'; assumption.
Qed.

(** This lemma tells us how to compute an upper bound on the number of
terms we will need to compute.  It is okay for this error to be loose
because the partial sums will bail out early when it sees that its
estimate of the error is small enough. *)
Lemma GeometricCovergenceLemma : forall (n:positive) (e:Qpos),
 /(proj1_sig e*(1 - a)) <= inject_Z (Zpos n) -> a^Zpos n <= proj1_sig e.
Proof.
 destruct (Qle_lt_or_eq _ _ Ha0) as [Ha0'|Ha0'].
 - intros n e H.
  assert (0 < a^Zpos n).
  { assert (X:0 < proj1_sig (Qpos_power (exist _ _ Ha0') (Zpos n))%Qpos)
      by auto with *.
   exact X. }
  apply Qmult_lt_0_le_reg_r with ((/proj1_sig e)*/(a^Zpos n)).
  apply (Qle_lt_trans _ (0 * (/a^Zpos n))).
  rewrite Qmult_0_l. apply Qle_refl.
  apply Qmult_lt_r.
    apply Qinv_lt_0_compat; exact H0.
   apply Qinv_lt_0_compat, Qpos_ispos.
  assert (0 < proj1_sig e) by (apply Qpos_ispos).
  rewrite (Qmult_assoc (proj1_sig e)), Qmult_inv_r, Qmult_1_l.
  2: apply Qpos_nonzero.
  setoid_replace (a ^ Zpos n * (/ proj1_sig e * / a ^ Zpos n))
    with (/proj1_sig e)
    by (unfold canonical_names.equiv, stdlib_rationals.Q_eq; simpl; field).
  2: split. 2: apply Qpos_nonzero. 2: auto with *.
  rewrite -> Qlt_minus_iff in Ha1.
  change (0<1-a) in Ha1.
  rewrite -> Qle_minus_iff in H.
  apply Qle_trans with (1 + inject_Z (Zpos n) * (/a -1)).
   + rewrite -> Qle_minus_iff.
     setoid_replace (1 + inject_Z (Zpos n) * (/ a - 1) + - / proj1_sig e)
       with (1+(1 - a)*((inject_Z (Zpos n)*(1-a)*/a + (inject_Z (Zpos n) +-(/(proj1_sig e*(1 - a)))))))
       by (unfold canonical_names.equiv, stdlib_rationals.Q_eq; simpl; field).
     2: split; auto with *.
     apply (Qle_trans _ (1+0)).
   discriminate. apply Qplus_le_r.
   repeat apply Qmult_le_0_compat; simpl; auto with *.
   assert (0 <= 1-a) by auto with *.
   apply (Qle_trans _ (0+0)). discriminate.
   apply Qplus_le_compat. 2: exact H.
   apply Qmult_le_0_compat.
   apply Qmult_le_0_compat. discriminate.
   exact H2. apply Qlt_le_weak, Qinv_lt_0_compat, Ha0'.
   + clear -n Ha0'.
     induction n using Pind.
     simpl.
     setoid_replace (1 + inject_Z 1 * (/ a - 1)) with (/a)
       by (unfold canonical_names.equiv, stdlib_rationals.Q_eq; simpl; ring).
     apply Qle_refl.
     rewrite Zpos_succ_morphism.
     unfold Z.succ.
     rewrite -> Qpower_plus;[|auto with *].
     rewrite -> Qinv_mult_distr.
     rewrite -> Q.Zplus_Qplus.
     apply Qle_trans with ((1 + inject_Z (Zpos n) * (/ a - 1))*/a).
     rewrite -> Qle_minus_iff.
     setoid_replace ( (1 + inject_Z (Z.pos n) * (/ a - 1)) * / a +
  - (1 + (inject_Z (Z.pos n) + inject_Z 1) * (/ a - 1)))
       with (inject_Z (Zpos n)*(/a -1)^2)
       by (unfold canonical_names.equiv, stdlib_rationals.Q_eq; simpl; ring).
     apply Qmult_le_0_compat. discriminate.
     unfold Qle. rewrite Z.mul_0_l. simpl.
     rewrite Z.mul_1_r. apply Z.square_nonneg.
     apply Qmult_le_compat_r.
     assumption.
     apply Qinv_le_0_compat; auto with *.
 - intros n e _.
   rewrite <- Ha0'.
   rewrite -> Qpower_0; auto with *.
Qed.

Definition InfiniteGeometricSum_maxIter series (err:Qpos) : positive :=
  let x := (1-a) in
  let (n,d) := (Qabs (hd series))/(proj1_sig err*x*x) in
  match Z.succ (Z.div n (Zpos d)) with
  | Zpos p => p
  | _ => 1%positive
  end.

Lemma InfiniteGeometricSum_maxIter_monotone : forall series (err:Qpos),
 GeometricSeries series ->
 (InfiniteGeometricSum_maxIter (tl series) err
  <= InfiniteGeometricSum_maxIter series err)%positive.
Proof.
 intros series err Gs.
 unfold InfiniteGeometricSum_maxIter.
 cut ((Qabs (hd (tl series)) / (proj1_sig err * (1 - a) * (1 - a))) <=
      (Qabs (hd series) / (proj1_sig err * (1 - a) * (1 - a)))).
 - generalize (Qabs (hd (tl series)) / (proj1_sig err * (1 - a) * (1 - a)))
              (Qabs (hd series) / (proj1_sig err * (1 - a) * (1 - a))).
   intros [na da] [nb db] H.
   cut (Z.succ (na/Zpos da) <= Z.succ (nb/Zpos db))%Z.
   generalize (Z.succ (na / Zpos da)) (Z.succ (nb/Zpos db)).
   intros [|x|x] [|y|y] Hxy;
     try solve [apply Hxy | apply Qle_refl | elim Hxy; constructor
                | unfold Qle; simpl; repeat rewrite Pmult_1_r].
   apply Pos.le_1_l. discriminate.
   apply Pos.le_1_l. discriminate.
   apply Zsucc_le_compat.
   unfold Qle in H.
   simpl in H.
   rewrite <- (Zdiv_mult_cancel_r na (Zpos da) (Zpos db)).
   2: discriminate.
   rewrite <- (Zdiv_mult_cancel_r nb (Zpos db) (Zpos da)).
   2: discriminate.
   rewrite (Zmult_comm (Zpos db) (Zpos da)).
   apply Z_div_le. reflexivity. exact H.
 - assert (X:0 < 1 - a).
   change (0 < 1 + - a).
   rewrite <- Qlt_minus_iff.
   assumption.
   apply Qle_shift_div_l.
   apply (Qpos_ispos (err * (exist _ _ X) * (exist _ _ X))).
   unfold Qdiv. rewrite <- Qmult_assoc.
   rewrite <- (Qmult_comm (proj1_sig err * (1 - a) * (1 - a))).
   rewrite Qmult_inv_r, Qmult_1_r.
   destruct Gs as [H _].
   eapply Qle_trans.
   apply H.
   rewrite <- (Qmult_1_l (Qabs (hd series))) at 2.
   apply Qmult_le_compat_r.
   apply Qlt_le_weak, Ha1. apply Qabs_nonneg.
   apply (Qpos_nonzero (err * (exist _ _ X) * (exist _ _ X))).
Qed.

Lemma InfiniteGeometricSum_maxIter_correct
  : forall series (err:Qpos),
    GeometricSeries series ->
    err_prop (proj1_sig err) (Str_nth_tl (nat_of_P (InfiniteGeometricSum_maxIter series err)) series) = true.
Proof.
 intros series err H.
 rewrite -> err_prop_prop.
 unfold err_bound.
 assert (X:0 < 1 - a).
  change (0 < 1 + - a).
  rewrite <- Qlt_minus_iff.
  assumption.
 apply Qle_shift_div_r; try assumption.
 assert (Y:(Qabs (hd series) * a ^ Zpos (InfiniteGeometricSum_maxIter series err)
            <= proj1_sig err * (1 - a))).
 { destruct (Qlt_le_dec 0 (Qabs (hd series))).
   apply Qmult_lt_0_le_reg_r with (/Qabs (hd series)).
    apply Qinv_lt_0_compat; assumption.
    rewrite (Qmult_comm (Qabs (hd series))), <- Qmult_assoc.
    rewrite Qmult_inv_r, Qmult_1_r.
    2: auto with *.
   cut (a ^ Zpos (InfiniteGeometricSum_maxIter series err)
        <= proj1_sig (err * exist _ _ X * Qpos_inv (exist _ _ q))%Qpos).
    autorewrite with QposElim; auto.
   apply GeometricCovergenceLemma.
   autorewrite with QposElim.
   unfold InfiniteGeometricSum_maxIter.
   simpl (/ (proj1_sig
     (err * exist (Qlt 0) (1 - a) X * Qpos_inv (exist (Qlt 0) (Qabs (hd series)) q))%Qpos * (1 - a))).
   setoid_replace (/ (proj1_sig err * (1 - a) * / Qabs (hd series) * (1 - a)))
     with (Qabs (hd series) / (proj1_sig err * (1 - a) * (1 - a)))
     by (unfold canonical_names.equiv, stdlib_rationals.Q_eq; simpl; field).
   2: repeat split;auto with *;apply Qpos_nonzero.
   cut (0 < (Qabs (hd series) / (proj1_sig err * (1 - a) * (1 - a)))).
    generalize (Qabs (hd series) / (proj1_sig err * (1 - a) * (1 - a))).
    intros [n d] Hnd.
    apply Qle_trans with (inject_Z (Z.succ (n/Zpos d))).
     unfold Qle.
     simpl.
     unfold Z.succ.
     apply Zle_0_minus_le.
     replace ((n / Zpos d + 1) * Zpos d - n * 1)%Z
       with (Zpos d*(n/Zpos d) + n mod (Zpos d) - n mod (Zpos d) - n + Zpos d)%Z
       by ring.
     rewrite <- Z_div_mod_eq_full.
     replace (n - n mod (Zpos d) - n + Zpos d)%Z
       with (Zpos d - n mod (Zpos d))%Z by ring.
     apply Zle_minus_le_0.
     destruct (Z_mod_lt n (Zpos d)); auto with *.
    generalize (Z.succ (n/Zpos d)).
    intros [|z|z].
      discriminate.
     apply Qle_refl.
    discriminate.
   cut (0 < proj1_sig ((exist _ _ q) * Qpos_inv(err * (exist _ _ X)*(exist _ _ X)))%Qpos).
    simpl; auto.
   apply Q.Qmult_lt_0_compat; auto with *.
  setoid_replace (Qabs (hd series)) with 0.
   rewrite Qmult_0_l.
   apply (Qpos_nonneg (err * (exist _ _ X))).
  apply Qle_antisym; try assumption.
  apply Qabs_nonneg. }
 apply Qle_trans with (Qabs (hd series)*a^Zpos (InfiniteGeometricSum_maxIter series err)); try assumption.
 clear Y.
 generalize (InfiniteGeometricSum_maxIter series err).
 intros p.
 revert series H.
 induction p using Pind; intros series H.
  simpl.
  destruct H.
  rewrite -> Qmult_comm.
  assumption.
 rewrite nat_of_P_succ_morphism.
 rewrite Zpos_succ_morphism.
 unfold Z.succ.
 rewrite -> Qpower_plus';[|discriminate].
 rewrite Qmult_assoc.
 apply Qle_trans with (Qabs (hd (Str_nth_tl (nat_of_P p) series))*a).
  change (S (nat_of_P p)) with (1+(nat_of_P p))%nat.
  rewrite <- Str_nth_tl_plus.
  cut (GeometricSeries (Str_nth_tl (nat_of_P p) series)).
   generalize (Str_nth_tl (nat_of_P p) series).
   intros s [H0 _].
   rewrite -> Qmult_comm.
   assumption.
  clear -H.
  induction (nat_of_P p).
   auto.
  change (S n) with (1+n)%nat.
  rewrite <- Str_nth_tl_plus.
  simpl.
  destruct IHn; assumption.
 apply Qmult_le_compat_r; try assumption.
 apply IHp; assumption.
Qed.

(** The implemenation of [InfiniteGeometricSum]. *)
Definition InfiniteGeometricSum_fat series (e:QposInf) : Q :=
  match e with
  | QposInfinity => 0
  | Qpos2QposInf err => InfiniteSum_fat
                         (err_prop (proj1_sig err))
                         series 0%Q
                         (Pos.to_nat (InfiniteGeometricSum_maxIter series err))
  end.

Definition InfiniteGeometricSum_raw series (e:QposInf) : Q :=
  match e with
  | QposInfinity => 0
  | Qpos2QposInf err => InfiniteSum_raw_N
                         (Pos.to_nat (Pos.size (InfiniteGeometricSum_maxIter series err)))
                         (err_prop (proj1_sig err))
                         (fun _ r => r) series 0%Q
  end.

Lemma InfiniteGeometricSum_raw_correct
  : forall (series : Stream Q) (e : QposInf),
    GeometricSeries series
    -> InfiniteGeometricSum_raw series e = InfiniteGeometricSum_fat series e.
Proof.
  assert (forall n:nat,
             lt 0 n -> Pos.of_nat (2 ^ n) = (2 ^ Pos.of_nat n)%positive) as inj_pow.
  { induction n.
    - intros. exfalso; inversion H.
    - intros _. destruct n. reflexivity.
      rewrite Nat2Pos.inj_succ. 2: discriminate.
      rewrite Pos.pow_succ_r.
      rewrite <- IHn. 2: apply le_n_S, le_0_n. clear IHn.
      generalize (S n). intro k.
      change (2 ^ S k)%nat with (2 * 2 ^ k)%nat.
      rewrite Nat2Pos.inj_mul. reflexivity. discriminate.
      apply Nat.pow_nonzero. discriminate. }
  intros. destruct e. 2: reflexivity.
  simpl. rewrite InfiniteSum_raw_N_correct.
  apply InfiniteSum_fat_add_stop.
  2: apply InfiniteGeometricSum_maxIter_correct, H.
  specialize (inj_pow (Pos.to_nat (Pos.size (InfiniteGeometricSum_maxIter series q)))
                      (Pos2Nat.is_pos _)).
  rewrite Pos2Nat.id in inj_pow.
  rewrite <- Nat2Pos.id. rewrite inj_pow.
  apply Pos2Nat.inj_le.
  apply Pos.lt_le_incl, Pos.size_gt.
  apply Nat.pow_nonzero. discriminate.
Qed.

(* Now we prove that bounds are correct when applied to tails
   of a geometric series at indexes p and p0. *)
Lemma err_prop_tail_correct :
  forall (series : Stream Q) (e0 e1:Q) (p p0 : nat),
    GeometricSeries series
    -> e1 <= e0
    -> err_prop e0 (Str_nth_tl p series) = true
    -> err_prop e1 (Str_nth_tl p0 series) = true
    -> Qball e0
            (InfiniteSum_fat (err_prop e0) series 0%Q p)
            (InfiniteSum_fat (err_prop e1) series 0%Q p0).
Proof.
  intros series e0 e1 p0 p1 H He H0 H1.
  (* err_prop e1 implies err_prop e0 so the e1 sum is longer.
     Replace by the first indexes where the filters are triggered,
     the one of e1 being higher.
     The subtraction is a tail sum of e0 after the convergence index,
     so it is below e0. *)
  pose proof (@InfiniteSum_fat_remove_filter p0 (err_prop e0) series 0%Q)
    as [i [H2 H3]].
  exact H0. rewrite H2.
  pose proof (@InfiniteSum_fat_remove_filter p1 (err_prop e1) series 0%Q)
    as [j [H4 H5]].
  exact H1. rewrite H4.
  clear H4 H2 H1 H0 p0 p1. destruct H3. destruct H5.
  destruct (Nat.lt_ge_cases j i).
  - exfalso.
    specialize (H0 j H4).
    pose proof (err_prop_monotone (Str_nth_tl j series) He H3) as mon.
    rewrite mon in H0. discriminate.
  - unfold Qball.
    rewrite <- AbsSmall_Qabs, Qabs_Qminus.
    apply Nat.le_exists_sub in H4. destruct H4 as [p [H4 _]].
    subst j. clear H3 H2 He e1.
    rewrite InfiniteSum_fat_minus.
    apply err_prop_correct.
    2: exact H1.
    apply ForAll_Str_nth_tl, H.
Qed.

Lemma InfiniteGeometricSum_raw_prf : forall series,
    GeometricSeries series ->
    is_RegularFunction Qball (InfiniteGeometricSum_raw series).
Proof.
 intros series H e0 e1.
 rewrite InfiniteGeometricSum_raw_correct.
 rewrite InfiniteGeometricSum_raw_correct.
 2: exact H. 2: exact H.
 pose proof (InfiniteGeometricSum_maxIter_correct e0 H) as H0.
 pose proof (InfiniteGeometricSum_maxIter_correct e1 H) as H1.
 destruct (Qle_total (proj1_sig e1) (proj1_sig e0)).
 - apply ball_weak. apply Qpos_nonneg.
   apply (err_prop_tail_correct _ _ H q H0 H1).
 - rewrite Qplus_comm.
   apply ball_weak. apply Qpos_nonneg.
   apply ball_sym.
   apply (err_prop_tail_correct _ _ H q H1 H0).
Qed.

Definition InfiniteGeometricSum series (Gs:GeometricSeries series) : CR :=
Build_RegularFunction (InfiniteGeometricSum_raw_prf Gs).

(** The [InfiniteGeometricSum] is correct. *)
Lemma InfiniteGeometricSum_step : forall series (Gs:GeometricSeries series),
 (InfiniteGeometricSum Gs ==
  ('(hd series))+(InfiniteGeometricSum (ForAll_Str_nth_tl 1%nat Gs)))%CR.
Proof.
 intros series Gs.
 rewrite -> CRplus_translate.
 apply regFunEq_equiv, regFunEq_e.
 intros e.
 change (approximate (InfiniteGeometricSum Gs) e)
   with (InfiniteGeometricSum_raw series e).
 rewrite InfiniteGeometricSum_raw_correct. 2: exact Gs.
 simpl (InfiniteGeometricSum (ForAll_Str_nth_tl 1 Gs)).
 change (approximate
       (translate (hd series) (InfiniteGeometricSum (ForAll_Str_nth_tl 1 Gs))) e)
   with (hd series
         + (InfiniteGeometricSum_raw (tl series) e)).
 rewrite InfiniteGeometricSum_raw_correct. 2: apply Gs.
 simpl.
 rewrite InfiniteSum_fat_extend.
 2: apply InfiniteGeometricSum_maxIter_correct, Gs.
 simpl.
 case_eq (err_prop (proj1_sig e) series); intros He.
 - apply ball_sym.
  simpl.
  unfold Qball.
  rewrite <- AbsSmall_Qabs.
  unfold Qminus. rewrite Qplus_0_r.
  eapply Qle_trans.
   apply Qabs_triangle.
  apply Qplus_le_compat; simpl.
   rewrite ->  err_prop_prop in He.
   unfold err_bound in He.
   assert (X:0 < 1 - a).
    change (0 < 1 + - a).
    rewrite <- Qlt_minus_iff.
    assumption.
   clear - He Ha0 X.
   setoid_replace (Qabs (hd series))
     with ((Qabs (hd series)/(1-a))*(1-a))
     by (unfold canonical_names.equiv, stdlib_rationals.Q_eq; simpl; field).
   2: auto with *.
   apply (Qle_trans _ ((proj1_sig e) * (1-a))).
   apply Qmult_le_compat_r. exact He.
   apply Qlt_le_weak, X.
   rewrite <- (Qmult_1_r (proj1_sig e)) at 2.
   apply Qmult_le_l. apply Qpos_ispos.
   rewrite <- (Qplus_0_r 1) at 2. apply Qplus_le_r.
   apply (Qopp_le_compat 0), Ha0.
  apply err_prop_correct.
    destruct Gs; assumption.
   apply err_prop_monotone'; assumption.
 - assert (Qplus' 0 (hd series) == hd series).
   { rewrite Qplus'_correct. apply Qplus_0_l. }
   rewrite (InfiniteSum_fat_wd _ _ _ H).
   rewrite InfiniteSum_fat_plus.
   rewrite (@InfiniteSum_fat_add_stop
              (Pos.to_nat (InfiniteGeometricSum_maxIter series e))
              (Pos.to_nat (InfiniteGeometricSum_maxIter (tl series) e))).
   apply Qball_Reflexive.
   apply (Qpos_nonneg (e+e)).
   apply Pos2Nat.inj_le.
   apply (@InfiniteGeometricSum_maxIter_monotone series e), Gs.
   apply InfiniteGeometricSum_maxIter_correct, Gs.
Qed.

Lemma InfiniteGeometricSum_bound : forall series
 (Gs:GeometricSeries series),
    (-'(err_bound series) <= InfiniteGeometricSum Gs
     /\ InfiniteGeometricSum Gs <= '(err_bound series))%CR.
Proof.
 intros series Gs.
 assert (Y:0 < 1 - a).
 { change (0 < 1 + - a).
  rewrite <- Qlt_minus_iff.
  assumption. }
 destruct (Qeq_dec (err_bound series) 0) as [Hq|Hq].
 - setoid_replace (InfiniteGeometricSum Gs) with 0%CR.
   split; simpl; rewrite -> Hq; try apply CRle_refl.
   rewrite CRopp_0. apply CRle_refl.
  apply regFunEq_equiv, regFunEq_e.
  intros e.
  apply ball_sym.
  change (approximate (InfiniteGeometricSum Gs) e)
    with (InfiniteGeometricSum_raw series e).
  rewrite InfiniteGeometricSum_raw_correct. 2: exact Gs.
  simpl.
  unfold Qball.
  unfold QAbsSmall.
  setoid_replace (0 - InfiniteSum_fat (err_prop (proj1_sig e)) series 0
                                      (Pos.to_nat (InfiniteGeometricSum_maxIter series e)))%Q
    with 0.
  split. apply (Qopp_le_compat 0), (Qpos_nonneg (e+e)).
  apply (Qpos_nonneg (e+e)).
   unfold canonical_names.equiv, stdlib_rationals.Q_eq.
  unfold Qminus. rewrite Qplus_0_l.
  assert (X:err_prop (proj1_sig e) series = true).
   rewrite -> err_prop_prop.
   rewrite -> Hq.
   apply Qpos_nonneg.
  destruct  (InfiniteGeometricSum_maxIter series e) using Pind.
   simpl.
   destruct (err_prop (proj1_sig e) series).
   reflexivity. discriminate.
   rewrite Pos2Nat.inj_succ.
   simpl.
   destruct (err_prop (proj1_sig e) series).
   reflexivity. discriminate.
 - cut (-(' err_bound series) <= InfiniteGeometricSum Gs
        /\ InfiniteGeometricSum Gs <= 'err_bound series)%CR.
   + intros [H0 H1].
     split; assumption.
   + setoid_replace (InfiniteGeometricSum Gs)
       with (InfiniteGeometricSum Gs - 0)%CR
       by (unfold canonical_names.equiv, msp_Equiv; ring).
     apply CRAbsSmall_ball.
     apply regFunBall_e.
     intros d.
     change (approximate (InfiniteGeometricSum Gs) d)
       with (InfiniteGeometricSum_raw series d).
     rewrite InfiniteGeometricSum_raw_correct. 2: exact Gs.
     simpl.
     set (p:=(InfiniteGeometricSum_maxIter series d)).
     unfold Qball.
     rewrite <- AbsSmall_Qabs.
     unfold Qminus. rewrite Qplus_0_r.
     apply (err_prop_correct _ (proj1_sig d+err_bound series+proj1_sig d));
       try assumption.
     apply err_prop_monotone with (err_bound series).
     simpl.
     apply (Qle_trans _ (0 + err_bound series + 0)).
     rewrite Qplus_0_l, Qplus_0_r. apply Qle_refl.
     apply Qplus_le_compat. apply Qplus_le_compat.
     apply Qpos_nonneg. apply Qle_refl. apply Qpos_nonneg.
     rewrite -> err_prop_prop.
     apply Qle_refl.
Qed.

Lemma InfiniteGeometricSum_small_tail : forall series (e : Qpos),
GeometricSeries series ->
{n : nat & forall Gs : GeometricSeries (Str_nth_tl n series),
     (- ' proj1_sig e <= InfiniteGeometricSum Gs
      /\ InfiniteGeometricSum Gs <= 'proj1_sig e)%CR }.
Proof.
 intros series e.
 exists (nat_of_P (InfiniteGeometricSum_maxIter series e)).
 intros Gs.
 pose proof (InfiniteGeometricSum_bound Gs) as [H0 H1].
 split.
 refine (CRle_trans _ H0). apply CRopp_le_compat.
 rewrite ->  CRle_Qle.
 rewrite <- err_prop_prop.
 apply InfiniteGeometricSum_maxIter_correct.
 assumption.
 apply (CRle_trans H1).
 rewrite ->  CRle_Qle.
 rewrite <- err_prop_prop.
 apply InfiniteGeometricSum_maxIter_correct.
 assumption.
Qed.

End GeometricSeries.

(** If one stream is [DecreasingNonNegative] and the other is
a [GeometricSeries], then the result is a [GeometricSeries]. *)
Lemma mult_Streams_Gs : forall a (x y  : Stream Q),
 (DecreasingNonNegative x) ->
 (GeometricSeries a y) ->
 (GeometricSeries a (mult_Streams x y)).
Proof.
 cofix mult_Streams_Gs.
 intros a x y Hx Hy.
 constructor.
  destruct Hy as [Hy _].
  apply dnn_alt in Hx.
  destruct Hx as [[[Hx2 _] [[Hx0 Hx1] _]] _].
  simpl.
  rewrite -> Qabs_Qmult.
  apply Qle_trans
    with (Qabs (CoqStreams.hd x) * Qabs (CoqStreams.hd (CoqStreams.tl y))).
   apply Qmult_le_compat_r.
    do 2 (rewrite -> Qabs_pos; try assumption).
   apply Qabs_nonneg.
  rewrite -> Qabs_Qmult.
  rewrite Qmult_comm.
  rewrite (Qmult_comm (Qabs (CoqStreams.hd x))), Qmult_assoc.
  apply Qmult_le_compat_r; try assumption.
  apply Qabs_nonneg.
 destruct Hy.
 apply mult_Streams_Gs. 2: exact Hy.
 apply Hx.
Qed.

(** [powers] is a [GeometricSeries]. *)
Lemma powers_help_Gs (a : Q) : (0 <= a) -> forall c,
 (GeometricSeries a (powers_help a c)).
Proof.
 intros Ha.
 cofix powers_help_Gs.
 intros c.
 constructor.
  simpl.
  rewrite -> Qmult_comm.
  rewrite -> Qabs_Qmult.
  rewrite -> (Qabs_pos a); try assumption.
  apply Qle_refl.
 apply powers_help_Gs.
Qed.

Lemma powers_Gs (a : Q) : (0 <= a) -> (GeometricSeries a (powers a)).
Proof.
 intros Ha.
 apply (powers_help_Gs Ha).
Qed.

Definition InfiniteGeometricSum_shift_raw
           (s : Stream Q) (n : nat) {a : Q}
           (Gs : GeometricSeries a (Str_nth_tl n s))
           (e : QposInf) : Q
  := take s n Qplus' 0
     + InfiniteGeometricSum_raw a (Str_nth_tl n s) e.

Lemma InfiniteGeometricSum_raw_shift_prf
  : forall (s : Stream Q) (n : nat) {a : Q}
      (Gs : GeometricSeries a (Str_nth_tl n s)),
    0 <= a -> a < 1 ->
    is_RegularFunction Qball (InfiniteGeometricSum_shift_raw s n Gs).
Proof.
  intros. intros e1 e2.
  apply AbsSmall_Qabs.
  unfold InfiniteGeometricSum_shift_raw.
  setoid_replace (take s n Qplus' 0 + InfiniteGeometricSum_raw a (Str_nth_tl n s) e1 -
              (take s n Qplus' 0 + InfiniteGeometricSum_raw a (Str_nth_tl n s) e2))
    with (InfiniteGeometricSum_raw a (Str_nth_tl n s) e1
          - InfiniteGeometricSum_raw a (Str_nth_tl n s) e2)
    by (unfold canonical_names.equiv, stdlib_rationals.Q_eq; ring).
  apply AbsSmall_Qabs.
  apply (InfiniteGeometricSum_raw_prf H H0 Gs).
Qed.

Definition InfiniteGeometricSum_shift (s : Stream Q) (n : nat) (a : Q)
      (Gs : GeometricSeries a (Str_nth_tl n s))
      (apos : 0 <= a) (aone : a < 1) : CR
  := Build_RegularFunction (InfiniteGeometricSum_raw_shift_prf s n Gs apos aone).

(* Proof of correctness : the limit of the geometric series does not depend
   on the geometric ratio. *)
Lemma InfiniteGeometricSum_wd : forall (s : Stream Q) (a b : Q)
      (Gsa : GeometricSeries a s)
      (Gsb : GeometricSeries b s)
      (apos : 0 <= a) (aone : a < 1)
      (bpos : 0 <= b) (bone : b < 1),
    msp_eq (InfiniteGeometricSum apos aone Gsa)
          (InfiniteGeometricSum bpos bone Gsb).
Proof.
  assert (forall (s : Stream Q) (a b : Q)
      (Gsa : GeometricSeries a s)
      (Gsb : GeometricSeries b s)
      (apos : 0 <= a) (aone : a < 1)
      (bpos : 0 <= b) (bone : b < 1),
    a <= b ->
    msp_eq (InfiniteGeometricSum apos aone Gsa)
          (InfiniteGeometricSum bpos bone Gsb)).
  { intros.
    (* The same series is summed up to 2 different indexes,
       the distance is the sum between the lower and upper index.
       The upper index is associated to b, which corresponds to a
       slower geometric series. *)
    intros e1 e2.
    change (approximate (InfiniteGeometricSum apos aone Gsa) e1)
      with (InfiniteGeometricSum_raw a s e1).
    rewrite (InfiniteGeometricSum_raw_correct apos aone _ Gsa).
    change (approximate (InfiniteGeometricSum bpos bone Gsb) e2)
      with (InfiniteGeometricSum_raw b s e2).
    rewrite (InfiniteGeometricSum_raw_correct bpos bone _ Gsb).
    simpl.
    pose proof (@InfiniteSum_fat_remove_filter
                  (Pos.to_nat (InfiniteGeometricSum_maxIter a s e1))
                  (fun s0 : Stream Q =>
                     match Qabs (hd s0) / (1 - a) ?= proj1_sig e1 with
                     | Gt => false
                     | _ => true
                     end)
                  s 0%Q)
      as [i [H2 H3]].
    apply (InfiniteGeometricSum_maxIter_correct apos aone _ Gsa).
    rewrite H2.
    pose proof (@InfiniteSum_fat_remove_filter
                  (Pos.to_nat (InfiniteGeometricSum_maxIter b s e2))
                  (fun s0 : Stream Q =>
                     match Qabs (hd s0) / (1 - b) ?= proj1_sig e2 with
                     | Gt => false
                     | _ => true
                     end)
                  s 0%Q)
      as [j [H4 H5]].
    apply (InfiniteGeometricSum_maxIter_correct bpos bone _ Gsb).
    rewrite H4.
    destruct (Nat.lt_ge_cases i j) as [H0|H0].
    - rewrite Qplus_0_r.
      apply Nat.le_exists_sub in H0.
      destruct H0 as [k [H0 _]]. subst j.
      unfold Qball. clear H5.
      rewrite <- AbsSmall_Qabs, Qabs_Qminus.
      replace (k + S i)%nat with (S k + i)%nat
        by (rewrite Nat.add_succ_r; reflexivity).
      rewrite InfiniteSum_fat_minus.
      apply (Qle_trans _ (proj1_sig e1 + 0)).
      rewrite Qplus_0_r.
      apply (err_prop_correct apos aone).
      apply ForAll_Str_nth_tl, Gsa. apply H3.
      apply Qplus_le_r, Qpos_nonneg.
    - rewrite Qplus_0_r.
      apply Nat.le_exists_sub in H0.
      destruct H0 as [k [H0 _]]. subst i.
      unfold Qball. clear H3.
      rewrite <- AbsSmall_Qabs, Qabs_Qminus.
      rewrite Qabs_Qminus.
      rewrite InfiniteSum_fat_minus.
      apply (Qle_trans _ (0 + proj1_sig e2)).
      rewrite Qplus_0_l.
      apply (err_prop_correct bpos bone).
      apply ForAll_Str_nth_tl, Gsb. apply H5.
      apply Qplus_le_l, Qpos_nonneg. }
  intros. destruct (Qle_total a b).
  apply H, q. symmetry. apply H, q.
Qed.