Require Import
  ByteString.Lib.Nomega
  ByteString.Lib.FMapExt
  ByteString.Lib.Relations
  ByteString.Ens.HeapEns
  ByteString.Ens.HeapEnsADT
  ByteString.Ens.MemoryBlockC
  Coq.FSets.FMapFacts
  Coq.Structures.DecidableTypeEx.

Module Within (M : WSfun N_as_DT).

Module X := FMapExt N_as_DT M.
Include X.

Module Import Block := MemoryBlockC M.

Local Open Scope lsignature_scope.

Lemma within_AbsR :
  within [R N.eq ==> N.eq ==> N.eq ==> boolR] within_bool.
Proof.
  intros.
  relational; unfold Basics.compose, negb; split; intros.
    rewrite H, H0, H1 in H2.
    decisions; auto; nomega.
  rewrite <- H, <- H0, <- H1 in H2.
  decisions; auto; nomega.
Qed.

Lemma not_within_AbsR : forall b l,
  (Basics.compose not (within b l))
    [R N.eq ==> boolR] (Basics.compose negb (within_bool b l)).
Proof.
  intros.
  relational; unfold Basics.compose, negb; split; intros.
    rewrite H in H0.
    decisions; auto; nomega.
  rewrite <- H in H0.
  decisions; auto.
    discriminate.
  nomega.
Qed.

Definition within_allocated_mem (n : N) :=
  fun (addr : M.key) (blk : MemoryBlockC) => addr + memCSize blk <=? n.
Arguments within_allocated_mem n addr blk /.

Program Instance within_allocated_mem_Proper :
  Proper (eq ==> eq ==> eq ==> eq) within_allocated_mem.
Obligation 1. relational; subst; reflexivity. Qed.

Hint Extern 4 (Proper (eq ==> eq ==> eq) (within_allocated_mem _)) =>
  apply within_allocated_mem_Proper; auto.

Lemma within_allocated_mem_add : forall n x k e,
  within_allocated_mem n k e = true
    -> 0 < x
    -> within_allocated_mem (n + x) k e = true.
Proof. nomega. Qed.

Lemma within_allocated_mem_at_end : forall n x d,
   within_allocated_mem (n + x) n {| memCSize := x; memCData := d |} = true.
Proof. nomega. Qed.

Lemma for_all_within_allocated_mem_add : forall n m o addr blk,
  P.for_all (within_allocated_mem n) m = true ->
  n <= o -> addr + memCSize blk <= o ->
  P.for_all (within_allocated_mem o) (M.add addr blk m) = true.
Proof.
  intros.
  apply P.for_all_iff; auto; intros.
  simplify_maps.
    nomega.
  eapply P.for_all_iff in H; relational; [|exact H6].
  unfold within_allocated_mem in H.
  nomega.
Qed.

Hint Resolve for_all_within_allocated_mem_add.

Lemma for_all_within_allocated_mem_empty :
  P.for_all (within_allocated_mem 0) (M.empty MemoryBlockC) = true.
Proof.
  apply P.for_all_iff; auto.
Qed.

Hint Resolve for_all_within_allocated_mem_empty.

Lemma for_all_within_allocated_mem_remove : forall n m addr,
  P.for_all (within_allocated_mem n) m = true ->
  P.for_all (within_allocated_mem n) (M.remove addr m) = true.
Proof.
  intros.
  apply for_all_remove; auto.
Qed.

Hint Resolve for_all_within_allocated_mem_remove.

Require Import Fiat.ADT Fiat.ADTNotation.

Lemma for_all_within_allocated_mem_If n m (mres : bool) f :
  (If mres
   Then P.for_all (within_allocated_mem f) m
   Else P.for_all (within_allocated_mem n) m) = true ->
  P.for_all (within_allocated_mem
               (If mres
                Then f
                Else n)) m.
Proof. destruct mres; simpl; intros; assumption. Qed.

Hint Resolve for_all_within_allocated_mem_If.

Lemma for_all_within_allocated_mem_Ifopt n m A (mres : option A) f :
  (Ifopt mres as p
   Then P.for_all (within_allocated_mem (f p)) m
   Else P.for_all (within_allocated_mem n) m) = true ->
  P.for_all (within_allocated_mem
               (Ifopt mres as p
                Then f p
                Else n)) m.
Proof. destruct mres; simpl; intros; assumption. Qed.

Hint Resolve for_all_within_allocated_mem_Ifopt.

Lemma for_all_within_allocated_mem_Ifdec n m `{Decidable mres} f :
  (Ifdec mres
   Then P.for_all (within_allocated_mem f) m
   Else P.for_all (within_allocated_mem n) m) = true ->
  P.for_all (within_allocated_mem
               (Ifdec mres
                Then f
                Else n)) m.
Proof. decisions; intros; assumption. Qed.

Hint Resolve for_all_within_allocated_mem_Ifdec.

Lemma for_all_within_allocated_mem_If_r n m (mres : bool) f :
  (If mres
   Then P.for_all (within_allocated_mem n) f
   Else P.for_all (within_allocated_mem n) m) = true ->
  P.for_all (within_allocated_mem n) (If mres
                                      Then f
                                      Else m).
Proof. destruct mres; simpl; intros; assumption. Qed.

Hint Resolve for_all_within_allocated_mem_If_r.

Lemma for_all_within_allocated_mem_Ifopt_r n m A (mres : option A) f :
  (Ifopt mres as p
   Then P.for_all (within_allocated_mem n) (f p)
   Else P.for_all (within_allocated_mem n) m) = true ->
  P.for_all (within_allocated_mem n) (Ifopt mres as p
                                      Then f p
                                      Else m).
Proof. destruct mres; simpl; intros; assumption. Qed.

Hint Resolve for_all_within_allocated_mem_Ifopt_r.

Lemma for_all_within_allocated_mem_Ifdec_r n m `{Decidable mres} f :
  (Ifdec mres
   Then P.for_all (within_allocated_mem n) f
   Else P.for_all (within_allocated_mem n) m) = true ->
  P.for_all (within_allocated_mem n) (Ifdec mres
                                      Then f
                                      Else m).
Proof. decisions; intros; assumption. Qed.

Hint Resolve for_all_within_allocated_mem_Ifdec_r.

(*
Lemma for_all_within_allocated_mem_realloc r_n d d0 :
  P.for_all (within_allocated_mem (fst r_n)) (snd r_n) = true ->
  P.for_all
    (within_allocated_mem
       (Ifopt M.find d (snd r_n) as cblk
        Then If ` d0 <=? memCSize cblk Then fst r_n Else fst r_n + ` d0
        Else fst r_n + ` d0)) (snd (fst (FMap_realloc r_n d d0))).
Proof.
  unfold FMap_realloc; intros.
  rename d into addr.
  destruct d0, (M.find _ (snd r_n)) eqn:Heqe; simpl;
  [ destruct (_ <=? memCSize _) eqn:Heqe1; simpl | ];
  rename x into len;
  normalize; try apply_for_all.
  - rewrite <- remove_add.
    apply for_all_add_true; auto.
      simplify_maps.
    split; trivial.
      apply for_all_remove; auto.
    unfold within_allocated_mem in H0.
    nomega.
  - apply for_all_add_true; auto.
      unfold not; destruct 1.
      simplify_maps.
      apply_for_all.
      apply H0 in H6; destruct H6, H6.
      pose proof (allocations_have_size Hr_o _ _ H6).
      rewrite (proj1 H8) in H9.
      unfold within_allocated_mem in H7.
      nomega.
    split; trivial.
      apply for_all_remove; auto.
      eapply for_all_impl; eauto; nomega.
    nomega.
  + rewrite <- remove_add.
    apply for_all_add_true; auto.
      simplify_maps.
    split; trivial.
      apply for_all_remove; auto.
      eapply for_all_impl; eauto; nomega.
    nomega.
Qed.
*)

Ltac apply_for_all :=
  match goal with
  | [ H1 : is_true (P.for_all ?P ?m),
      H2 : M.MapsTo ?k ?e ?m |- _ ] =>
    let H3 := fresh "H3" in
    assert (H3 : Proper (eq ==> eq ==> eq) P) by auto;
    pose proof (proj1 (@P.for_all_iff _ P H3 m) H1 k e H2)
  | [ H1 : P.for_all ?P ?m = true,
      H2 : M.MapsTo ?k ?e ?m |- _ ] =>
    let H3 := fresh "H3" in
    assert (H3 : Proper (eq ==> eq ==> eq) P) by auto;
    pose proof (proj1 (@P.for_all_iff _ P H3 m) H1 k e H2)
  end.

Lemma for_all_within_allocated_mem_mapi : forall n m f,
  P.for_all (within_allocated_mem n) m = true ->
  (forall k blk, memCSize (f k blk) <=? memCSize blk) ->
  P.for_all (within_allocated_mem n) (M.mapi f m) = true.
Proof.
  intros.
  apply P.for_all_iff; auto; intros.
  do 2 simplify_maps; intros; subst; auto.
  specialize (H0 k cblk).
  apply_for_all.
  unfold within_allocated_mem in H2.
  nomega.
Qed.

Hint Resolve for_all_within_allocated_mem_mapi.

Corollary Proper_within : forall pos,
   Proper (eq ==> eq ==> eq)
          (fun b e => within_bool b (memCSize e) pos).
Proof. intros; relational; subst; reflexivity. Qed.

Definition withinMemBlock (pos : N) (b : N) (e : MemoryBlock) : Prop :=
  within b (memSize e) pos.
Arguments withinMemBlock pos b e /.

Definition withinMemBlockC (pos : N) (b : N) (e : MemoryBlockC) : bool :=
  within_bool b (memCSize e) pos.
Arguments withinMemBlockC pos b e /.

Global Program Instance withinMemBlock_Proper :
  Proper (N.eq ==> eq ==> eq ==> eq) withinMemBlock.
Obligation 1.
  relational; subst.
  rewrite H; reflexivity.
Qed.

Hint Extern 4 (Proper (eq ==> eq ==> eq) (withinMemBlock _)) =>
  apply withinMemBlock_Proper; reflexivity.

Global Program Instance withinMemBlockC_Proper :
  Proper (N.eq ==> eq ==> eq ==> eq) withinMemBlockC.
Obligation 1.
  relational; subst.
  rewrite H; reflexivity.
Qed.

Hint Extern 4 (Proper (eq ==> eq ==> eq) (withinMemBlockC _)) =>
  apply withinMemBlockC_Proper; reflexivity.

Open Scope lsignature_scope.

Global Program Instance withinMemBlock_AbsR :
  withinMemBlock [R eq ==> eq ==> MemoryBlock_AbsR ==> boolR]
  withinMemBlockC.
Obligation 1. relational; subst; simpl; split; swap_sizes; nomega. Qed.

Global Program Instance withinMemBlock_AbsR_applied (pos : N) :
  withinMemBlock pos [R eq ==> MemoryBlock_AbsR ==> boolR]
  withinMemBlockC pos.
Obligation 1. apply withinMemBlock_AbsR; reflexivity. Qed.

Notation "f \oo g" := (fun x y => f (g x y)) (at level 90).

Lemma withinMemAbsR : forall base blk cblk pos,
  withinMemBlock pos base blk
    -> MemoryBlock_AbsR blk cblk
    -> withinMemBlockC pos base cblk = true.
Proof. simpl; intros; swap_sizes; nomega. Qed.

Hint Resolve within_allocated_mem_Proper.
Hint Resolve withinMemBlock_Proper.
Hint Resolve withinMemBlockC_Proper.

End Within.


(** Experiments to find a nice representation of an annoted control-flow graph. *)
Require Import Wellfounded.

Set Implicit Arguments.

Module WellFounded.
  Record t (A : Type) : Type := new {
    lt : A -> A -> Prop;
    Hwf : well_founded lt}.
End WellFounded.

(*Module Context.
  Module T.
    Inductive t (S : Set) : Type :=
    | nil
    | cons (A : Type) (WF : WellFounded.t A) (C : t S).

    Fixpoint append S (C1 C2 : t S) : t S :=
      match C1 with
      | nil _ => C2
      | cons WF C1 => cons WF (append C1 C2)
      end.
  End T.

  Module I.
    Inductive t (S : Set) : T.t S -> Type :=
    | nil : t (T.nil S)
    | cons : forall A WF (C : T.t S) (a : A) (c : t C), t (T.cons (A := A) WF C).
  End I.

  Inductive lt S : {C : T.t S & I.t C} -> {C : T.t S & I.t C} -> Prop :=
  | lt_nil : forall A WF a C c,
    lt (existT _ _ (I.cons (A := A) WF (C := C) a c))
       (existT _ _ (I.nil S))
  | lt_head_lt : forall A WF a1 a2 C1 C2 c1 c2,
    WellFounded.lt WF a1 a2 ->
    lt (existT _ _ (I.cons (A := A) WF (C := C1) a1 c1))
       (existT _ _ (I.cons (A := A) WF (C := C2) a2 c2))
  | lt_head_eq : forall A WF a C1 C2 c1 c2,
    lt (existT _ _ c1)
       (existT _ _ c2) ->
    lt (existT _ _ (I.cons (A := A) WF (C := C1) a c1))
       (existT _ _ (I.cons (A := A) WF (C := C2) a c2)).

  Lemma lt_wf (S : Set) : well_founded (lt (S := S)).
    intro x.
    constructor; intros y H.
  Admitted.
End Context.*)

(** The shape of positions of the loop entry points *)
Module Shape.
  Inductive t : Type :=
  | nil
  | loop (A : Type) (WF : WellFounded.t A) (shape_in shape_next : t)
  | jcc (shape_true shape_false shape_next : t).
End Shape.

(** A state of the program's loop variants. This type has a well-founded order. *)
Module Path.
  Inductive t : Shape.t -> Type :=
  | nil :
    t Shape.nil
  | loop_in : forall A WF shape_in shape_next (a : A) (path : t shape_in),
    t (Shape.loop (A := A) WF shape_in shape_next)
  | loop_next : forall A WF shape_in shape_next (a : A) (path : t shape_next),
    t (Shape.loop (A := A) WF shape_in shape_next)
  | jcc_true : forall shape_true shape_false shape_next (path : t shape_true),
    t (Shape.jcc shape_true shape_false shape_next)
  | jcc_false : forall shape_true shape_false shape_next (path : t shape_false),
    t (Shape.jcc shape_true shape_false shape_next)
  | jcc_next : forall shape_true shape_false shape_next (path : t shape_next),
    t (Shape.jcc shape_true shape_false shape_next).
End Path.

(** The stack of the loop entry points a program is depending on. *)
Module Context.
  Inductive t (S : Set) : Type :=
  | nil
  | cons (A : Type) (WF : WellFounded.t A) (L : S -> Type) (context : t S).

  Fixpoint append S (C1 C2 : t S) : t S :=
    match C1 with
    | nil _ => C2
    | cons WF L C1 => cons WF L (append C1 C2)
    end.
End Context.

Module CFG.
  Inductive t (S : Set) : Context.t S -> Shape.t -> (S -> Type) -> (S -> Type) -> Type :=
  | nop : forall context L,
    t context Shape.nil L L
  | op : forall context shape Lin L Lout,
    (forall s, {s' : S & Lin s -> L s'}) ->
    t context shape L Lout ->
    t context shape Lin Lout
  | jcc : forall context shape_true shape_false shape_next
      Lin Lin_true Lin_false Lmerge Lout,
    (forall s, (Lin s -> Lin_true s) + (Lin s -> Lin_false s)) ->
    t context shape_true Lin_true Lmerge -> t context shape_false Lin_false Lmerge -> t context shape_next Lmerge Lout ->
    t context (Shape.jcc shape_true shape_false shape_next) Lin Lout
  | loop : forall context shape_in shape_next Lin L Lout A WF,
    t (Context.cons (A := A) WF Lin context) shape_in Lin L -> t context shape_next L Lout ->
    t context (Shape.loop (A := A) WF shape_in shape_next) Lin Lout
  | goto : forall context1 A WF context2 Lin L Lout,
    t (Context.append context1 (Context.cons (A := A) WF L context2)) Shape.nil Lin Lout.

  (*Inductive t (S : Set) : (S -> Type) -> (S -> Type) -> Type :=
  | op : forall (f : S -> S) (Lin L Lout : S -> Type)
    (fl : forall s, Lin s -> L (f s)),
    t S L Lout ->
    t S Lin Lout
  | jcc : forall (c : S -> bool) (Lin Lin_true Lin_false Lmerge Lout : S -> Type)
    (fl : forall s, if c s then Lin s -> Lin_true s else Lin s -> Lin_false s),
    t S Lin_true Lmerge -> t S Lin_false Lmerge -> t S Lmerge Lout ->
    t S Lin Lout.*)

  Fixpoint eval S Lin Lout (p : t S Lin Lout)
    (s : S) (l : Lin s) {struct p} : {s' : S & Lout s'}.
    destruct p as [Lin L Lout f p
      | Lin Lin_true Lin_false Lmerge Lout f p_true p_false p].
    - exact (
        let (_, fl) := f s in
        eval _ _ _ p _ (fl l)).

    - exact (
        match f s with
        | inl fl_true =>
          let (s, l) := eval _ _ _ p_true _ (fl_true l) in
          eval _ _ _ p _ l
        | inr fl_false =>
          let (s, l) := eval _ _ _ p_false _ (fl_false l) in
          eval _ _ _ p _ l
        end).
  Defined.
End CFG.