Require Import Iron.Language.SystemF2.Preservation.
Require Export Iron.Language.SystemF2.Step.
Require Export Iron.Language.SystemF2.SubstExpExp.
Require Export Iron.Language.SystemF2.SubstTypeExp.
Require Import Iron.Language.SystemF2.TyJudge.
Require Export Iron.Language.SystemF2.Exp.

(* Big Step Evaluation.
   This is also called 'Natural Semantics'.
   It provides a relation between the expression to be reduced
   and its final value. *)
Inductive EVAL : exp -> exp -> Prop :=
 | EVDone
   :  forall v2
   ,  wnfX  v2
   -> EVAL   v2 v2

 | EVLAMAPP
   : forall x1 x12 t2 v3
   ,  EVAL x1 (XLAM x12)     -> EVAL (substTX 0 t2 x12) v3
   -> EVAL (XAPP x1 t2) v3

 | EVLamApp
   :  forall x1 t11 x12 x2 v2 v3
   ,  EVAL x1 (XLam t11 x12) -> EVAL x2 v2 -> EVAL (substXX 0 v2 x12) v3
   -> EVAL (XApp x1 x2) v3.

Hint Constructors EVAL.

(* A terminating big-step evaluation always produces a wnf.
   The fact that the evaluation terminated is implied by the fact
   that we have a finite proof of EVAL to pass to this lemma. *)
Lemma eval_produces_wnfX
 :  forall x1 v1
 ,  EVAL   x1 v1
 -> wnfX  v1.
Proof.
 intros. induction H; eauto.
Qed.
Hint Resolve eval_produces_wnfX.

(* Big to Small steps
   Convert a big-step evaluation into a list of individual
   machine steps. *)
Lemma steps_of_eval
 :  forall x1 t1 x2
 ,  TYPE nil nil x1 t1
 -> EVAL  x1 x2
 -> STEPS x1 x2.
Proof.
 intros x1 t1 v2 HT HE. gen t1.

 (* Induction over the form of (EVAL x1 x2) *)
 induction HE.
 Case "EVDone".
  intros. apply ESNone.

 Case "EVLAMAPP".
  intros. inverts HT.
  lets E1: IHHE1 H3. clear IHHE1.
  lets T1: preservation_steps H3 E1. inverts keep T1.
  lets T2: subst_type_exp H4 H5.
   simpl in T2.
  lets E2: IHHE2 T2.
  eapply ESAppend.
   apply steps_APP1. eauto.
  eapply ESAppend.
   eapply ESStep.
    eapply ESLAMAPP. auto.

 Case "EVLamApp".
  intros. inverts HT.
  lets E1: IHHE1 H3.
  lets E2: IHHE2 H5.
  lets T1: preservation_steps H3 E1. inverts keep T1.
  lets T2: preservation_steps H5 E2.
  lets T3: subst_exp_exp H8 T2.
  lets E3: IHHE3 T3.
  eapply ESAppend.
    eapply steps_app1. eauto.
   eapply ESAppend.
    eapply steps_app2. eauto. eauto.
   eapply ESAppend.
    eapply ESStep.
     eapply ESLamApp. eauto.
   eauto.
Qed.

(* Small to Big steps
   Convert a list of individual machine steps to a big-step
   evaluation. The main part of this is the expansion lemma, which
   we use to build up the overall big-step evaluation one small-step
   at a time. The other lemmas are used to feed it small-steps.
 *)

(* Given an existing big-step evalution, we can produce a new one
   that does an extra step before returning the original value.
 *)
Lemma eval_expansion
 :  forall ke te x1 t1 x2 v3
 ,  TYPE ke te x1 t1
 -> STEP x1 x2 -> EVAL x2 v3
 -> EVAL x1 v3.
Proof.
 intros. gen ke te t1 v3.

 (* Induction over the form of (STEP x1 x2) *)
 induction H0; intros.

 Case "XApp".
  SCase "value app".
   eapply EVLamApp.
   eauto.
   apply EVDone. auto. auto.

  SCase "x1 steps".
   inverts H. inverts H1.
    inverts H.
    eapply EVLamApp; eauto.

  SCase "x2 steps".
   inverts H1. inverts H2.
   inverts H1.
   eapply EVLamApp; eauto.

 Case "XAPP".
  SCase "type app".
   eapply EVLAMAPP.
   eauto.
   inverts H.
   auto.

  SCase "x1 steps".
   inverts H. inverts H1.
    inverts H.
    eapply EVLAMAPP; eauto.
Qed.

(* Convert a list of small steps to a big-step evaluation. *)
Lemma eval_of_stepsl
 :  forall x1 t1 v2
 ,  TYPE nil nil x1 t1
 -> STEPSL x1 v2 -> value v2
 -> EVAL   x1 v2.
Proof.
 intros.
 induction H0; eauto using eval_expansion.
Qed.

(* Convert a multi-step evaluation to a big-step evaluation.
   We use stepsl_of_steps to flatten out the append constructors
   in the multi-step evaluation, leaving a list of individual
   small-steps.
 *)
Lemma eval_of_steps
 :  forall x1 t1 v2
 ,  TYPE nil nil x1 t1
 -> STEPS x1 v2 -> value v2
 -> EVAL  x1 v2.
Proof.
 eauto using eval_of_stepsl, stepsl_of_steps.
Qed.


Require Import
        Bedrock.Word
        Coq.NArith.NArith
        Coq.Arith.Arith
        Coq.Numbers.Natural.Peano.NPeano
        Coq.Logic.Eqdep_dec
        Fiat.Narcissus.Common.Specs
        Fiat.Narcissus.BinLib.Core
        compcert.lib.Integers.

Import Byte.

Record ByteString :=
  { padding : nat;
    front : word padding;
    paddingOK : (padding < 8)%nat;
    numBytes : nat;
    byteString : Vector.t byte numBytes (* The bytestring. *)
  }.

Definition length_ByteString (bs : ByteString) := numBytes bs.

Definition wordToByte (w : word 8) : byte :=
  repr (BinInt.Z.of_N (wordToN w)).

Definition byteToWord (i : byte) : word 8 :=
  match intval i with
  | 0%Z => wzero 8
  | Zpos p => posToWord 8 p
  | _ => wzero 8
  end.

Definition ByteString_enqueue
         (b : bool)
         (bs : ByteString)
  : ByteString.
  refine (if (eq_nat_dec (padding bs) 7) then
            {| front := WO;
               byteString := Vector.append (byteString bs)
                                           (Vector.cons _ (wordToByte (WS b _)) _ (@Vector.nil _)) |}
  else
    {| front := WS b (front bs);
       padding := S (padding bs);
       byteString := byteString bs |}).
  abstract omega.
  abstract (pose proof (front bs) as w; generalize dependent (padding bs);
            intros ?? w; subst; exact w).
  abstract (pose proof (paddingOK bs); omega).
Defined.

Fixpoint word_dequeue {sz}
           (w : word (S sz))
  : bool * word sz :=
  match sz return word (S sz) -> bool * word sz with
  | 0 => fun w => (whd w, WO)
  | S sz' =>
    fun w => let (b, w') := word_dequeue (wtl w) in
             (b, WS (whd w) w')
  end w.

Fixpoint CharList_dequeue
         {numBytes}
         (l : Vector.t byte (S numBytes))
  : bool * (Vector.t byte numBytes) * word 7 :=
  let (b, w') := word_dequeue (byteToWord (Vector.hd l)) in
  match numBytes return
        Vector.t byte (S numBytes) -> _ with
  | S numBytes' =>
    fun l =>
      match CharList_dequeue (Vector.tl l) with
      | (b', l'', tail) =>
        (b, Vector.cons _ (wordToByte (WS b' w')) _ l'', tail)
      end
  | 0 => fun _ => (b, Vector.nil _, w')
  end l.

Definition ByteString_dequeue
         (bs : ByteString)
  : option (bool * ByteString).
  refine (match padding bs as n return
                word n
                -> (n < 8)%nat
                -> _ with
          | 0 =>
            match numBytes bs as nb return
                  Vector.t byte nb
                  -> _ with
            | S n' =>
              fun l _ _ =>
                match CharList_dequeue l with
                | (b', l'', tail) =>
                  Some (b', {| front := tail;
                               byteString := l'' |})
                end
            | _ => fun _ _ _ => None
            end (byteString bs)
          | S n =>
            fun front' lt_n =>
              match numBytes bs as nb return
                    Vector.t byte nb
                    -> _ with
              | S n' =>
                fun l =>
                  match CharList_dequeue l with
                  | (b', l'', tail) =>
                    let (b, w') := word_dequeue front' in
                    Some (b', {| front := w';
                                 byteString := Vector.append l''
                                                             (Vector.cons _ (wordToByte (WS b tail)) _ (@Vector.nil _))
                              |})
                  end
              | _ => fun _ =>
                       let (b, w') := word_dequeue front' in
                       Some (b, {| front := w';
                                   byteString := Vector.nil _ |})
              end (byteString bs)
          end (front bs) (paddingOK bs)).
  abstract omega.
  abstract omega.
  abstract omega.
Defined.

Fixpoint ByteString_enqueue_word
           {n}
           (w : word n)
           (bs : ByteString) :=
  match n return word n -> ByteString with
  | 0 => fun _ => bs
  | S n' => fun w =>
              (ByteString_enqueue (whd w) (ByteString_enqueue_word (wtl w) bs))
  end w.

Definition ByteString_enqueue_char (bs : ByteString) (b : byte)
  := ByteString_enqueue_word (byteToWord b) bs.

Definition ByteString_enqueue_ByteString
           (bs bs' : ByteString)
  : ByteString :=
  let bs'' := Vector.fold_left ByteString_enqueue_char bs (byteString bs') in
  ByteString_enqueue_word (front bs') bs''.

Definition ByteString_id : ByteString.
  refine {| front := WO; byteString := Vector.nil _ |}.
  abstract omega.
Defined.

Definition CharStringToByteString
           (bs : ByteString)
  : Core.ByteString :=
  {| Core.padding := padding bs;
     Core.front := front bs;
     Core.paddingOK := paddingOK bs;
     Core.byteString := map byteToWord (Vector.to_list (byteString bs))
  |}.

Definition ByteStringToCharString
           (bs : Core.ByteString)
  : ByteString :=
  {| padding := Core.padding bs;
     front := Core.front bs;
     paddingOK := Core.paddingOK bs;
     byteString := Vector.map wordToByte (Vector.of_list (Core.byteString bs))
  |}.

Lemma byteToWord_wordToByte_eq :
  forall w, byteToWord (wordToByte w) = w.
Proof.
  Local Transparent Byte.repr.
  intros; shatter_word w.
  destruct x; destruct x0; destruct x1; destruct x2; destruct x3; destruct x4; destruct x5; destruct x6;
    reflexivity.
  Local Opaque Byte.repr.
Qed.

Lemma wordToByte_byteToWord_eq :
  forall b, wordToByte (byteToWord b) = b.
Proof.
  Local Transparent Byte.repr.
  destruct b.
  destruct intval0; simpl; intros; intuition eauto.
  - compute; apply Byte.mkint_eq; reflexivity.
  - repeat first [compute in intrange0; destruct intrange0; congruence
                 | destruct p as [p | p | ]; simpl
                 | compute; apply Byte.mkint_eq; reflexivity].
  - compute in intrange0; destruct p; destruct intrange0; congruence.
    Local Opaque Byte.repr.
Qed.

Lemma Vector_to_list_map {A B}
: forall n (v : Vector.t A n) (f : A -> B),
    Vector.to_list (Vector.map f v) = map f (Vector.to_list v).
Proof.
  induction v; simpl; intros; eauto.
  unfold Vector.to_list in *.
  rewrite IHv; reflexivity.
Qed.

Lemma Vector_to_list_of_list_eq {A}
  : forall (v : list A),
    Vector.to_list (Vector.of_list v) = v.
Proof.
  induction v; simpl.
  reflexivity.
  replace (a :: v) with (a :: Vector.to_list (Vector.of_list v)).
  reflexivity.
  rewrite IHv; reflexivity.
Qed.

Lemma CharStringToByteString_ByteStringToCharString_eq :
  forall bs, CharStringToByteString (ByteStringToCharString bs) = bs.
Proof.
  unfold CharStringToByteString, ByteStringToCharString; destruct bs; simpl;
    f_equal.
  rewrite Vector_to_list_map, Vector_to_list_of_list_eq.
  clear; induction byteString0; simpl; eauto.
  rewrite byteToWord_wordToByte_eq.
  rewrite IHbyteString0; reflexivity.
Qed.

Lemma ByteString_f_equal
  : forall bs bs'
           (p_eq : padding bs' = padding bs)
           (numBytes_eq : numBytes bs' = numBytes bs),
    front bs = eq_rect (padding bs') (fun t : nat => word t) (front bs') (padding bs) p_eq
    -> byteString bs = eq_rect (numBytes bs') _ (byteString bs') (numBytes bs) numBytes_eq
    -> bs = bs'.
Proof.
  destruct bs; destruct bs'; simpl; intros.
  subst.
  f_equal.
  apply le_uniqueness_proof.
Qed.

Lemma length_Vector_to_list {A B}
  : forall (f : A -> B) n (v : Vector.t A n),
    n = length (map f (Vector.to_list v)).
Proof.
  induction v; simpl; eauto.
Qed.

Lemma eq_rect_Vector_cons {A}
  : forall n m a v H H',
    eq_rect (S n) (Vector.t A) (VectorDef.cons A a n v) (S m) H =
    Vector.cons _ a _ (eq_rect n (Vector.t A) v _ H').
Proof.
  intros.
  destruct H'; simpl; symmetry;
    apply Eqdep_dec.eq_rect_eq_dec; intros; eauto using Peano_dec.eq_nat_dec.
Qed.

Lemma ByteStringToCharString_CharStringToByteString_eq :
  forall bs, ByteStringToCharString (CharStringToByteString bs) = bs.
Proof.
  unfold CharStringToByteString, ByteStringToCharString; destruct bs; simpl;
    eapply ByteString_f_equal; simpl.
  apply Eqdep_dec.eq_rect_eq_dec; intros; eauto using Peano_dec.eq_nat_dec.
  instantiate (1 := length_Vector_to_list byteToWord _ byteString0).
  clear; induction byteString0; simpl.
  - apply Eqdep_dec.eq_rect_eq_dec; intros; eauto using Peano_dec.eq_nat_dec.
  - unfold Vector.to_list in *; rewrite IHbyteString0; clear.
    erewrite eq_rect_Vector_cons; f_equal.
    apply wordToByte_byteToWord_eq.
    Grab Existential Variables.
    reflexivity.
Qed.

Lemma ByteString_enqueue_ByteString_ByteStringToCharString
  : forall bs bs',
    ByteString_enqueue_ByteString (ByteStringToCharString bs)
                                  (ByteStringToCharString bs')
    = ByteStringToCharString (Core.ByteString_enqueue_ByteString bs bs').
Proof.
Admitted.

Lemma length_ByteString_ByteStringToCharString_eq
  : forall bs,
    length_ByteString (ByteStringToCharString bs) =
    Core.length_ByteString bs.
Proof.
Admitted.

Lemma CharStringToByteString_ByteString_id_eq
  : CharStringToByteString ByteString_id = Core.ByteString_id.
Proof.
Admitted.

Instance ByteStringQueueMonoid : Monoid ByteString.
Proof.
  refine {| mappend := ByteString_enqueue_ByteString;
            bin_measure := length_ByteString;
            mempty := ByteString_id |}.
  - abstract (intros; rewrite <- (ByteStringToCharString_CharStringToByteString_eq b),
                      <- (ByteStringToCharString_CharStringToByteString_eq b'),
                      ByteString_enqueue_ByteString_ByteStringToCharString,
                      !length_ByteString_ByteStringToCharString_eq,
                      ByteString_enqueue_ByteString_measure;
              reflexivity).
  - abstract (intros; rewrite <- (ByteStringToCharString_CharStringToByteString_eq ByteString_id),
                      <- (ByteStringToCharString_CharStringToByteString_eq l),
                      ByteString_enqueue_ByteString_ByteStringToCharString,
                      CharStringToByteString_ByteString_id_eq,
                      ByteString_enqueue_ByteString_id_left; reflexivity).
  - abstract (intros; rewrite <- (ByteStringToCharString_CharStringToByteString_eq ByteString_id),
                      <- (ByteStringToCharString_CharStringToByteString_eq l),
                      ByteString_enqueue_ByteString_ByteStringToCharString,
                      CharStringToByteString_ByteString_id_eq,
                      ByteString_enqueue_ByteString_id_right; reflexivity).
  - abstract (intros; rewrite <- (ByteStringToCharString_CharStringToByteString_eq l),
                     <- (ByteStringToCharString_CharStringToByteString_eq m),
                     <- (ByteStringToCharString_CharStringToByteString_eq n),
                     !ByteString_enqueue_ByteString_ByteStringToCharString,
                     ByteString_enqueue_ByteString_assoc; reflexivity).
Defined.

Lemma ByteString_enqueue_ByteStringToCharString_eq
  : forall (b : bool) (b' : Core.ByteString),
    ByteString_enqueue b (ByteStringToCharString b') =
    ByteStringToCharString (Core.ByteString_enqueue b b').
Proof.
Admitted.

Lemma ByteString_enqueue_ByteStringToCharString_eq'
  : forall (b : bool) (b' : ByteString),
    Core.ByteString_enqueue b (CharStringToByteString b') =
    CharStringToByteString (ByteString_enqueue b b').
Proof.
Admitted.

Lemma ByteString_dequeue_ByteStringToCharString_eq
  : forall (b' : Core.ByteString),
    ByteString_dequeue (ByteStringToCharString b') =
    Ifopt (Core.ByteString_dequeue b')
    as bbs
         Then Some (fst bbs, ByteStringToCharString (snd bbs))
         Else None.
Proof.
Admitted.

Lemma ByteString_dequeue_ByteStringToCharString_eq'
  : forall (b' : ByteString),
    Core.ByteString_dequeue (CharStringToByteString b') =
    Ifopt (ByteString_dequeue b')
    as bbs
         Then Some (fst bbs, CharStringToByteString (snd bbs))
         Else None.
Proof.
Admitted.

Instance ByteString_QueueMonoidOpt
  : QueueMonoidOpt ByteStringQueueMonoid bool.
Proof.
refine {| B_measure f := 1;
          enqueue_opt := ByteString_enqueue;
          dequeue_opt := ByteString_dequeue |}.
  - abstract eauto.
  - abstract (simpl; intros; rewrite <- (ByteStringToCharString_CharStringToByteString_eq b'),
                             ByteString_enqueue_ByteStringToCharString_eq,
                             !length_ByteString_ByteStringToCharString_eq,
                             length_ByteString_enqueue';
              reflexivity).
  - abstract (simpl; intros; rewrite <- (ByteStringToCharString_CharStringToByteString_eq b) in *;
              rewrite ByteString_dequeue_ByteStringToCharString_eq in H;
              destruct (Core.ByteString_dequeue (CharStringToByteString b)) eqn : ?; simpl in *;
              try discriminate; injections;
              destruct p; apply ByteString_measure_dequeue_Some in Heqo;
              simpl in Heqo;
              rewrite length_ByteString_ByteStringToCharString_eq; simpl in *;
              rewrite <- Heqo;
              rewrite <- length_Vector_to_list, <- length_ByteString_ByteStringToCharString_eq,
              ByteStringToCharString_CharStringToByteString_eq; reflexivity).
  - simpl; intros; rewrite <- (ByteStringToCharString_CharStringToByteString_eq b),
                   <- (ByteStringToCharString_CharStringToByteString_eq b') in *;
    rewrite <- (ByteStringToCharString_CharStringToByteString_eq b'').
    rewrite ByteString_dequeue_ByteStringToCharString_eq in H;
    destruct (Core.ByteString_dequeue (CharStringToByteString b)) eqn : ?; simpl in *;
      try discriminate; destruct p; simpl in *.
    injection H; intros; subst.
    apply ByteString_dequeue_mappend_opt with (b'' := CharStringToByteString b'') in Heqo;
          simpl in *.
    admit.
  - abstract (simpl; intros; rewrite <- (ByteStringToCharString_CharStringToByteString_eq b'),
                             <- (ByteStringToCharString_CharStringToByteString_eq b''),
                             !ByteString_enqueue_ByteString_ByteStringToCharString,
                             ByteString_enqueue_ByteStringToCharString_eq,
                             ByteString_enqueue_ByteString_enqueue_ByteString,
                             !ByteStringToCharString_CharStringToByteString_eq,
                             ByteString_enqueue_ByteStringToCharString_eq',
                             <- ByteString_enqueue_ByteString_ByteStringToCharString,
                             !ByteStringToCharString_CharStringToByteString_eq;
              reflexivity).
  - abstract (simpl; intros; rewrite <- (ByteStringToCharString_CharStringToByteString_eq ByteString_id),
                             ByteString_enqueue_ByteStringToCharString_eq,
                             ByteString_dequeue_ByteStringToCharString_eq;
              replace (CharStringToByteString ByteString_id)
              with Core.ByteString_id;
              [rewrite ByteString_dequeue_head_opt; reflexivity
              | unfold ByteString_id, Core.ByteString_id, CharStringToByteString; simpl;
                f_equal;
                apply le_uniqueness_proof]).
  - abstract reflexivity.
  - intros ? ? ? ?.
    simpl; intros; rewrite <- (ByteStringToCharString_CharStringToByteString_eq b),
                   <- (ByteStringToCharString_CharStringToByteString_eq b'),
                   !ByteString_dequeue_ByteStringToCharString_eq in *.
    destruct (Core.ByteString_dequeue (CharStringToByteString b)) eqn : ?;
      simpl in *; try discriminate.
    destruct (Core.ByteString_dequeue (CharStringToByteString b')) eqn : ?;
      simpl in *; try discriminate.
    destruct p; destruct p0.
    simpl in *; rewrite <- H in H0.
    rewrite (ByteString_dequeue_opt_inj (CharStringToByteString b) (CharStringToByteString b') Heqo).
    reflexivity.
    rewrite Heqo0; repeat f_equal.
    injection H0; eauto.
    assert (ByteStringToCharString b3 = ByteStringToCharString b1) by congruence.
    rewrite <- (CharStringToByteString_ByteStringToCharString_eq b3),
    <-  (CharStringToByteString_ByteStringToCharString_eq b1), H1.
    reflexivity.
Defined.

Definition build_aligned_ByteString
           {numBytes}
           (v : Vector.t byte numBytes)
  : ByteString.
  refine {| front := WO;
            byteString := v |}.
  abstract omega.
Defined.

Definition byteToInt32 (b : byte) : int.
  refine {| intval := Byte.intval b |}.
  pose proof (Byte.intrange b).
  abstract (intuition auto; etransitivity; [apply H1 | reflexivity]).
Defined.

Lemma DecodeBindOpt_assoc:
  forall (A B C D : Type)
         (a_opt : option (A * B))
         (f : A -> B -> option (C * B))
         (g : C -> B -> option (D * B)),
    (`(c, b) <- (`(a, b) <- a_opt; f a b); g c b) =
    (`(a, b) <- a_opt;
      `(c, b) <- f a b;
      g c b).
Proof.
  destruct a_opt as [ [? ?] | ]; simpl; intros.
  - destruct (f a b) as [ [? ?] | ]; reflexivity.
  - reflexivity.
Qed.

Lemma DecodeBindOpt_under_bind:
  forall (A B C : Type) (a_opt : option (A * B)) (f f' : A -> B -> option (C * B)),
  (forall (a : A) (b : B), f a b = f' a b) -> (`(a, b) <- a_opt;
                                                 f a b ) = (`(a, b) <- a_opt;
                                                              f' a b).
Proof.
  destruct a_opt as [ [? ?] | ]; simpl; intros; eauto.
Qed.

Lemma byteString_f_equal
  : forall bs bs'
           (padding_eq : padding bs' = padding bs)
           (numBytes_eq : numBytes bs' = numBytes bs),
    front bs = (@eq_rect nat (padding bs') (fun t => word t) (front bs') _ padding_eq)
    -> byteString bs = @eq_rect nat (numBytes bs') (Vector.t byte) (byteString bs') _ numBytes_eq
    -> bs = bs'.
Proof.
  destruct bs; destruct bs'; simpl; intros.
  subst.
  f_equal.
  apply Core.le_uniqueness_proof.
Qed.

Require Import
        Coq.Strings.String
        Coq.Vectors.Vector.

Lemma vector_append_assoc {A} {n}
  : forall (v : Vector.t A n) {n'} (v' : Vector.t A n')
           {n''} (v'' : Vector.t A n''),
    append (append v v') v'' = cast (append v (append v' v'')) (Core.plus_assoc' n n' n'').
Proof.
  induction v; simpl.
  - induction v'; simpl.
    + induction v''; simpl.
      reflexivity.
      rewrite <- IHv''; eauto.
    + intros; rewrite <- IHv'.
      reflexivity.
  - intros; rewrite IHv; repeat f_equal.
    eapply Eqdep_dec.eq_proofs_unicity; intros;
      omega.
Qed.

Lemma build_aligned_ByteString_append
      {numBytes'}
  : forall (v' : Vector.t byte numBytes') {numBytes} (v : Vector.t byte numBytes),
    build_aligned_ByteString (Vector.append v v') = ByteString_enqueue_ByteString (build_aligned_ByteString v) (build_aligned_ByteString v').
Proof.
  simpl; intros; rewrite <- (ByteStringToCharString_CharStringToByteString_eq (build_aligned_ByteString v)),
                 <- (ByteStringToCharString_CharStringToByteString_eq (build_aligned_ByteString v')),
                 ByteString_enqueue_ByteString_ByteStringToCharString.
  unfold build_aligned_ByteString; simpl.
  unfold CharStringToByteString; simpl.
  erewrite <- massage_queue_into_ByteString.
  unfold ByteStringToCharString; simpl.
  assert (Datatypes.length
            (List.map byteToWord (to_list v) ++ List.map byteToWord (to_list v'))
          = numBytes0 + numBytes').
  rewrite app_length, <- !length_Vector_to_list; reflexivity.
  eapply byteString_f_equal with (numBytes_eq := H); simpl.
  apply Eqdep_dec.eq_rect_eq_dec; intros; eauto using Peano_dec.eq_nat_dec.
  induction v; simpl in *.
  induction v'.
  - apply Eqdep_dec.eq_rect_eq_dec; intros; eauto using Peano_dec.eq_nat_dec.
  - simpl in H; injection H; intros.
    simpl; rewrite eq_rect_Vector_cons with (H' := H0); simpl.
    f_equal.
    rewrite wordToByte_byteToWord_eq; eauto.
    eapply IHv'.
  -  simpl in H; injection H; intros.
     simpl; rewrite eq_rect_Vector_cons with (H' := H0); simpl.
     f_equal.
     rewrite wordToByte_byteToWord_eq; eauto.
     eapply IHv.
     Grab Existential Variables.
     reflexivity.
     omega.
Qed.

Lemma build_aligned_ByteString_cons
      {numBytes}
  : forall (v : Vector.t byte (S numBytes)),
    (build_aligned_ByteString v) = ByteString_enqueue_ByteString (build_aligned_ByteString (Vector.cons _ (Vector.hd v) _ (Vector.nil _))) (build_aligned_ByteString (Vector.tl v)).
Proof.
  intros; rewrite <- (build_aligned_ByteString_append (Vector.tl v)
                                                      (Vector.cons _ (Vector.hd v) _ (Vector.nil _))).
  pattern numBytes, v; apply VectorDef.caseS; simpl; intros; reflexivity.
Qed.

Require Import Fiat.Narcissus.Formats.WordOpt.

Lemma aligned_decode_char_eq
      {numBytes}
  : forall (v : Vector.t byte (S numBytes)),
    WordOpt.decode_word' (monoidUnit := ByteString_QueueMonoidOpt) 8 (build_aligned_ByteString v)
    = Some (byteToWord (Vector.hd v), build_aligned_ByteString (Vector.tl v)).
Proof.
  simpl; intros.
  etransitivity.
  apply DecodeBindOpt_under_bind; intros; set_evars; rewrite !DecodeBindOpt_assoc.
  repeat (unfold H; apply DecodeBindOpt_under_bind; intros; set_evars; rewrite !DecodeBindOpt_assoc).
  unfold H5; higher_order_reflexivity.
  simpl.
  pattern numBytes, v; eapply Vector.caseS; intros; simpl; clear v numBytes.
  replace (build_aligned_ByteString t) with (ByteString_enqueue_ByteString ByteString_id (build_aligned_ByteString t)).
  rewrite <- (wordToByte_byteToWord_eq h).
  generalize (byteToWord h); intro; rewrite byteToWord_wordToByte_eq.
  shatter_word w.
  pose proof (@dequeue_mappend_opt _ _ _ ByteString_QueueMonoidOpt).
  rewrite build_aligned_ByteString_cons; simpl.
  simpl in H7.
  erewrite H7 with (t := x6)
                     (b' := {| front := WS x (WS x0 (WS x1 (WS x2 (WS x3 (WS x4 (WS x5 WO))))));
                               byteString := Vector.nil _ |}); simpl.
  erewrite H7 with (t := x5)
                     (b' := {| front := WS x (WS x0 (WS x1 (WS x2 (WS x3 (WS x4 WO)))));
                               byteString := Vector.nil _ |}); simpl.
  erewrite H7 with (t := x4)
                     (b' := {| front := WS x (WS x0 (WS x1 (WS x2 (WS x3 WO))));
                               byteString := Vector.nil _ |}); simpl.
  erewrite H7 with (t := x3)
                     (b' := {| front := WS x (WS x0 (WS x1 (WS x2 WO)));
                               byteString := Vector.nil _ |}); simpl.
  erewrite H7 with (t := x2)
                     (b' := {| front := WS x (WS x0 (WS x1 WO));
                               byteString := Vector.nil _ |}); simpl.
  erewrite H7 with (t := x1)
                     (b' := {| front := WS x (WS x0 WO);
                               byteString := Vector.nil _ |}); simpl.
  erewrite H7 with (t := x0)
                     (b' := {| front := WS x WO;
                            byteString := Vector.nil _ |}); simpl.
  erewrite H7 with (t := x)
                     (b' := {| front := WO;
                            byteString := Vector.nil _ |}); simpl.
  reflexivity.
  unfold dequeue_opt.
  simpl.
  compute; repeat f_equal; apply Core.le_uniqueness_proof.
  compute; repeat f_equal; apply Core.le_uniqueness_proof.
  compute; repeat f_equal; apply Core.le_uniqueness_proof.
  compute; repeat f_equal; apply Core.le_uniqueness_proof.
  compute; repeat f_equal; apply Core.le_uniqueness_proof.
  compute; repeat f_equal; apply Core.le_uniqueness_proof.
  compute; repeat f_equal; apply Core.le_uniqueness_proof.
  unfold build_aligned_ByteString.
  unfold ByteString_dequeue; simpl.
  rewrite byteToWord_wordToByte_eq; simpl.
  repeat f_equal; apply Core.le_uniqueness_proof.
  apply (@mempty_left _ ByteStringQueueMonoid).
Qed.

Fixpoint Vector_split {A} (n m : nat) (v : Vector.t A (n + m)) :
  Vector.t A n * Vector.t A m :=
  match n return Vector.t A (n + m)
                 -> Vector.t A n * Vector.t A m with
  | 0 => fun v => (Vector.nil _, v)
  | S n' => fun v => let (v', v'') := Vector_split n' m (Vector.tl v) in
                     (Vector.cons _ (Vector.hd v) _ v', v'')
  end v.

Fixpoint VectorByteToWord {numBytes} (v : t byte numBytes) : word (8 * numBytes) :=
  match numBytes return
        t byte numBytes
        -> word (8 * numBytes) with
  | 0 => fun _ => WO
  | S numBytes' => fun v => eq_rect _ word (Core.append_word (VectorByteToWord (Vector.tl v)) (byteToWord (Vector.hd v)))
                                    (8 * S numBytes')  (sym_eq (NPeano.Nat.mul_succ_r _ _))
  end v.

Lemma SW_word_eq_rect_eq
  : forall (m n: nat)
           (b : bool)
           (a : word m) H H',
    SW_word b (eq_rect m word a n H) =
    eq_rect (S m) word (SW_word b a) (S n) H'.
Proof.
  destruct H; simpl; intros.
  apply Eqdep_dec.eq_rect_eq_dec; intros; eauto using Peano_dec.eq_nat_dec.
Qed.

Lemma Some_eq_rect_eq
  : forall n m w H b,
    eq_rect n (fun n : nat => option (word n * ByteString)) (Some  (w, b)) m H
    = Some (eq_rect n word w _ H, b).
Proof.
  destruct H; simpl; reflexivity.
Qed.

Lemma None_eq_rect_eq
  : forall n m H,
    eq_rect n (fun n : nat => option (word n * ByteString)) (None) m H
    = None.
Proof.
  destruct H; simpl; reflexivity.
Qed.

Require Import Fiat.Common.Equality.

Lemma WS_eq_rect_eq
  : forall n m b (w : word n) H H',
    WS b (eq_rect n word w m H)
    = eq_rect (S n) word (WS b w) (S m) H'.
Proof.
  destruct H; simpl; intros.
  apply Eqdep_dec.eq_rect_eq_dec; intros; eauto using Peano_dec.eq_nat_dec.
Qed.

Lemma eq_rect_decode_word
  : forall n m H b,
    eq_rect n (fun n0 : nat => option (word n0 * ByteString)) (decode_word' n b) m H =
    decode_word' m b.
Proof.
  induction n; simpl; intros; subst; simpl.
  - reflexivity.
  - reflexivity.
Qed.

Lemma decode_word_plus : forall n m (v : ByteString),
    WordOpt.decode_word' (n + m) v =
    (`(w, v') <- WordOpt.decode_word' (m + n) v;
      Some (eq_rect _ word w _ (Plus.plus_comm _ _), v')).
Proof.
  induction n; simpl; intros.
  - revert v; induction m; simpl; intros.
    + repeat f_equal; apply Eqdep_dec.eq_rect_eq_dec; intros; eauto using Peano_dec.eq_nat_dec.
    + destruct (ByteString_dequeue v) as [ [? ?] | ]; simpl; eauto.
      rewrite IHm, !DecodeBindOpt_assoc; apply DecodeBindOpt_under_bind; intros.
      simpl; eauto.
      repeat f_equal; clear.
      eapply SW_word_eq_rect_eq.
  - etransitivity.
    apply DecodeBindOpt_under_bind; intros.
    set_evars; rewrite IHn, !DecodeBindOpt_assoc.
    unfold H; reflexivity.
    simpl; replace (WordOpt.decode_word' (m + S n) v) with
      (`(w', v') <- WordOpt.decode_word' (S (m + n)) v; Some (eq_rect _ word w' _ (plus_n_Sm _ _), v')).
    + simpl; repeat (rewrite !DecodeBindOpt_assoc; apply DecodeBindOpt_under_bind; intros).
      simpl; repeat f_equal;  erewrite SW_word_eq_rect_eq; rewrite <- transport_pp; f_equal.
    + simpl; rewrite !DecodeBindOpt_assoc.
      etransitivity.
      apply DecodeBindOpt_under_bind; intros.
      set_evars; rewrite !DecodeBindOpt_assoc; simpl.
      unfold H; reflexivity.
      simpl.
      pose proof (IHn (S m) v); simpl in H.
      rewrite !DecodeBindOpt_assoc in H; simpl.
      destruct (ByteString_dequeue v) as [ [? ?] | ]; simpl in *.
      setoid_rewrite DecodeBindOpt_assoc in H; simpl.
      destruct (decode_word' (m + n) b0) as [ [? ?] | ]; simpl in *.
      assert (n + S m = m + S n) by omega.
      assert (eq_rect _ (fun n => option (word n * ByteString)) (decode_word' (n + S m) v) (m + S n) H0
              = eq_rect _ (fun n => option (word n * ByteString))
                        (Some (eq_rect (S (m + n)) word (SW_word b w) (n + S m) (PeanoNat.Nat.add_comm (S m) n), b1))
                        (m + S n) H0)
             by (intros; rewrite H; reflexivity).
      rewrite Some_eq_rect_eq in H1.
      rewrite <- transport_pp in H1.
      erewrite Eqdep_dec.eq_proofs_unicity with (p1 := (plus_n_Sm m n));
        intros; try omega.
      rewrite <- H1.
      rewrite eq_rect_decode_word; reflexivity.
      assert (n + S m = m + S n) by omega.
      rewrite <- eq_rect_decode_word with (H := H0), H; simpl.
      destruct H0; reflexivity.
      assert (n + S m = m + S n) by omega.
      rewrite <- eq_rect_decode_word with (H := H0), H; simpl.
      destruct H0; reflexivity.
Qed.

Lemma aligned_decode_char_eq'
          {numBytes numBytes'}
  : forall (v : Vector.t byte (S numBytes' + numBytes)),
    WordOpt.decode_word' (monoidUnit := ByteString_QueueMonoidOpt) (8 * (S numBytes')) (build_aligned_ByteString v)
    = let (v', v'') := Vector_split (S numBytes') numBytes v in
      Some (VectorByteToWord v', build_aligned_ByteString v'').
Proof.
  induction numBytes'.
  - intros; rewrite aligned_decode_char_eq.
    unfold Vector_split; simpl.
    repeat f_equal; generalize (byteToWord (Vector.hd v)); intro; shatter_word w.
    fold Nat.add.
    apply Eqdep_dec.eq_rect_eq_dec; eauto using Peano_dec.eq_nat_dec.
  - revert IHnumBytes'; generalize (S numBytes'); intros.
    match goal with
      |- ?k = _ =>
      replace k
      with (`(w, v') <-  Some (byteToWord (Vector.hd v), build_aligned_ByteString (Vector.tl v));
            `(w', v'') <- WordOpt.decode_word' (8 * n) v';
            Some (eq_rect _ word (Core.append_word w' w) _ (sym_eq (NPeano.Nat.mul_succ_r _ _)), v''))
    end.
    simpl.
    rewrite IHnumBytes'; simpl.
    destruct (Vector_split n numBytes (Vector.tl v)); simpl; repeat f_equal; clear.
    unfold DecodeBindOpt at 1; unfold If_Opt_Then_Else.
    assert (8 + 8 * n = 8 * S n) by omega.
    rewrite <- eq_rect_decode_word with (H := H).
    assert (8 * n + 8 = 8 + 8 * n) by omega.
    match goal with
      |- context [decode_word' ?m (build_aligned_ByteString ?b) ] =>
      replace (decode_word' m (build_aligned_ByteString b))
      with (`(w, v') <- Some (byteToWord (hd b), build_aligned_ByteString (tl b));
            `(w', v'') <- decode_word' (8 * n) v';
            Some (eq_rect _ word (append_word w' w) _ H0, v''))
    end.
    unfold DecodeBindOpt at 2; unfold BindOpt; unfold If_Opt_Then_Else.
    destruct (decode_word' (8 * n) (build_aligned_ByteString (tl v))) as [ [? ?] | ]; try reflexivity.
    unfold DecodeBindOpt; unfold If_Opt_Then_Else.
    simpl.
    rewrite Some_eq_rect_eq.
    rewrite <- transport_pp.
    repeat f_equal.
    apply Eqdep_dec.eq_proofs_unicity; try intros; omega.
    simpl; symmetry; apply None_eq_rect_eq.
    rewrite <- aligned_decode_char_eq.
    simpl.
    repeat (rewrite !DecodeBindOpt_assoc; simpl; apply DecodeBindOpt_under_bind; intros).
    clear.
    repeat f_equal.
    simpl in H0.
    revert a7 H0; generalize (n + (n + (n + (n + (n + (n + (n + (n + 0)))))))); clear; intros n0 w.
    induction w; simpl; intros.
    symmetry.
    apply Eqdep_dec.eq_rect_eq_dec; eauto using Peano_dec.eq_nat_dec.
    erewrite <- IHw; clear.
    erewrite WS_eq_rect_eq; reflexivity.
    Grab Existential Variables.
    omega.
Qed.

Definition LetIn {A B} (a : A) (k : A -> B) : B := let a' := a in k a'.

Notation "x <- y ; z" := (Bind y%comp (fun x => z%comp))
                           (at level 81, right associativity,
                            format "'[v' x  <-  y ; '/' z ']'") : comp_scope.

Notation "'Let' a ':=' b 'in' k" := (LetIn b (fun a => k))
                                    (at level 81, right associativity,
                                     format "'[v' 'Let'  a  ':=' b  'in' '/' k ']'").

Lemma VectorByteToWord_cons :
  forall n v h H,
    VectorByteToWord (Vector.cons byte h n v)
    = eq_rect _ _ (Core.append_word (VectorByteToWord v) (byteToWord h)) _ H.
Proof.
  induction v; simpl; intros.
  rewrite <- !Eqdep_dec.eq_rect_eq_dec; eauto using Peano_dec.eq_nat_dec.
  repeat f_equal; apply Eqdep_dec.eq_proofs_unicity; intros; omega.
Qed.

Lemma Vector_nth_tl {A} : forall n (v : Vector.t A (S n)) p,
    Vector.nth v (Fin.FS p) = Vector.nth (Vector.tl v) p.
Proof.
  intros ? ?; pattern n, v; apply Vector.rectS; simpl; intros.
  inversion p.
  reflexivity.
Qed.

Lemma Vector_nth_hd {A} : forall n (v : Vector.t A (S n)),
    Vector.nth v Fin.F1 = Vector.hd v.
Proof.
  intros ? ?; pattern n, v; apply Vector.rectS; simpl; reflexivity.
Qed.

Fixpoint decode_list'
         {A : Type}
         {cache : Cache}
         (n : nat)
         (A_decode: nat -> CacheDecode -> (A * CacheDecode))
         (cd : CacheDecode) {struct n}
  : (list A * CacheDecode) :=
  match n return (nat -> CacheDecode -> (A * CacheDecode))
                 -> _
  with
  | 0 => fun _ => ([ ], cd)
  | S n' => fun A_decode' => Let a := A_decode' 0 cd in
        Let a' := decode_list' n' (fun p => A_decode' (S p)) (snd a) in
                                            (fst a :: (fst a'), snd a')
  end A_decode.

(* Variable magic : forall (n : nat), Fin.t (4 * n).

Lemma decode_list_decode_list'_eq
  : forall n m (b : Vector.t byte ((4 * n) + m)) cd,
    decode_list (decode_int Int.wordsize) n (build_aligned_ByteString b) cd
    = Some (fst (decode_list' n (fun p cd =>
                                   (ofbytes (Vector.nth b (Fin.L m (magic p)))
                                            (Vector.nth b (Fin.FS (Fin.L m (magic _ p))))
                                            (Vector.nth b p)
                                            (Vector.nth b p), cd)) cd),
            (build_aligned_ByteString b),
            snd (decode_list' n (fun p cd =>
                                   (ofbytes (Vector.nth b p)
                                            (Vector.nth b p)
                                            (Vector.nth b p)
                                            (Vector.nth b p), cd)) cd)).
Admitted. *)


(* This code is copyrighted by its authors; it is distributed under  *)
(* the terms of the LGPL license (see LICENSE and description files) *)

(** * Modules *)

Set Implicit Arguments.

Require Export Monad.
Require Import Extensionality.

(** ** Notations *)

Reserved Notation "x >>>= f" (at level 42, left associativity).
Reserved Notation "x >>>- f" (at level 42, left associativity).

(** ** Definition of module of a monad. *)

Implicit Type X Y Z : Set.

Record Mod (P : Monad) : Type := {
  mod_carrier :> Set -> Set;
  mbind : forall X Y (f : X -> P Y) (x : mod_carrier X),
    mod_carrier Y;
  mbind_mbind : forall X Y Z
    (f : X -> P Y) (g : Y -> P Z) (x : mod_carrier X),
    mbind Z g (mbind Y f x) = mbind Z (fun u => f u >>= g) x;
  unit_mbind : forall X (x : mod_carrier X),
    mbind X (@unit P X) x = x
}.

Notation "x >>>= f" := (@mbind _ _ _ _ f x).

Hint Rewrite mbind_mbind unit_mbind : mod.

Hint Extern 1 (_ = _ :> @mod_carrier _ _ _) => autorewrite with mod : mod.

Ltac mod := intros; autorewrite with monad mod; auto with mod monad.

Definition mmap (P : Monad) (T : Mod P)
  X Y (f : X -> Y) (x : T X) : T Y :=
  x >>>= fun x => unit P (f x).

Notation "x >>>- f" := (@mmap _ _ _ _ f x).

Definition mlift (P : Monad) (T : Mod P) X Y (f : X -> Y) : T X -> T Y :=
  @mbind P T _ _ (fun x => unit P (f x)).

Definition mlift2 (P : Monad) (T : Mod P) X Y Z
  (f : X -> Y -> Z) (a : P X) (b : T Y) : T Z :=
  b >>>= (fun y => a >>= fun x => unit P (f x y)).

Section Mod_Facts.

Variable P : Monad.
Variable M : Mod P.

Lemma mbind_congr : forall X Y (f g : X -> P Y) (x y : M X),
  x = y -> (forall a, f a = g a) -> x >>>= f = y >>>= g.
Proof.
intros. subst y. replace g with f. reflexivity.
apply extensionality. trivial.
Qed.

Hint Resolve mbind_congr : mod.

Lemma unit_mbind_match : forall X (f : X -> P X) (x : M X),
  (forall a, f a = unit P a) -> x >>>= f = x.
Proof.
intros.
transitivity (x >>>= @unit P X).
apply mbind_congr; trivial.
auto with mod.
Qed.

Lemma mmap_mbind : forall X Y Z (f : X -> P Y) (g : Y -> Z) (x : M X),
  x >>>= f >>>- g = x >>>= (fun u => f u >>- g).
Proof.
unfold mmap; mod.
Qed.

Lemma mbind_mmap : forall X Y Z (f : X -> Y) (g : Y -> P Z) (x : M X),
  x >>>- f >>>= g = x >>>= fun u : X => g (f u).
Proof.
unfold mmap. mod.
Qed.

Lemma mmap_mmap : forall X Y Z (f : X -> Y) (g : Y -> Z) (x : M X),
  x >>>- f >>>- g = x >>>- fun u : X => g (f u).
Proof.
unfold mmap. mod.
Qed.

End Mod_Facts.

Hint Resolve unit_mbind_match mbind_congr : mod.
Hint Rewrite mmap_mbind mbind_mmap mmap_mmap : mod.

Record Mod_Hom (P : Monad) (S T : Mod P) : Type := {
  mod_hom_carrier :> forall X, S X -> T X;
  mod_hom_mbind : forall X Y (f : X -> P Y) (x : S X),
    mod_hom_carrier Y (x >>>= f) = mod_hom_carrier X x >>>= f
}.

Hint Rewrite mod_hom_mbind : mod.

(** ** Tautological module *)

Definition Taut_Mod (P : Monad) : Mod P :=
  Build_Mod P P (@bind P) (@bind_bind P) (@unit_bind P).

Coercion Taut_Mod : Monad >-> Mod.

(** ** Pull-back module *)

Section Pull_back.

Variable (P Q: Monad) (h : Monad_Hom P Q) (M : Mod Q).

Let bb X Y (f : X -> P Y) (x : M X) : M Y :=
  x >>>= fun u => h Y (f u).

Remark bb_bb : forall X Y Z (f : X -> P Y) (g : Y -> P Z) (x : M X),
  bb Z g (bb Y f x) = bb Z (fun u : X => f u >>= g) x.
Proof.
unfold bb; mod.
Qed.

Remark unit_bb : forall X (x : M X),
  bb X (unit P (X:=X)) x = x.
Proof.
unfold bb; mod.
Qed.

Definition PB : Mod P := Build_Mod P M bb bb_bb unit_bb.

End Pull_back.


Require Import
  Fiat.ADT
  Fiat.ADTNotation
  ByteString.Lib.TupleEnsembles
  ByteString.Lib.LibExt
  ByteString.Lib.Nomega
  ByteString.Lib.ADTInduction
  ByteString.Lib.Same_set
  ByteString.HeapState
  ByteString.Ens.Decidable
  ByteString.Ens.BindDep
  ByteString.Ens.TupleEnsemblesFinite.

Generalizable All Variables.

Open Scope string_scope.
Open Scope N_scope.

Definition Word8 := Ascii.ascii.
Definition Zero  := Ascii.zero.

Record MemoryBlock := {
  memSize : N;
  memData : EMap N Word8
}.

Definition MemoryBlock_Same (x y : MemoryBlock) : Prop :=
  memSize x = memSize y /\ Same (memData x) (memData y).

Global Program Instance MemoryBlock_Proper :
  Proper (eq ==> @Same _ _ ==> MemoryBlock_Same) Build_MemoryBlock.
Obligation 1. relational; split; simpl; subst; auto. Qed.

Ltac tsubst :=
  repeat
    match goal with
    | [ H : (_, _) = (_, _) |- _ ] => inv H
    | [ H : (_, _, _) = (_, _, _) |- _ ] => inv H
    | [ H : (_, _, _, _) = (_, _, _, _) |- _ ] => inv H
    | [ H : {| memSize := _
             ; memData := _ |} =
            {| memSize := _
             ; memData := _ |} |- _ ] => inv H
    end;
  subst.

Definition KeepKeys (P : N -> Prop) :
  EMap N Word8 -> EMap N Word8 :=
  Filter (fun k _ => P k).

Definition ShiftKeys (orig_base : N) (new_base : N) :
  EMap N Word8 -> EMap N Word8 :=
  Map_set (fun p => (fst p - orig_base + new_base, snd p)).

Definition FindFreeBlock (len : N) (heap : EMap N MemoryBlock) : Comp N :=
  { addr : N | All (fun addr' blk' =>
                      ~ overlaps addr' (memSize blk') addr len) heap }.

Definition FindBlock (base : N) (heap : EMap N MemoryBlock) :
  Comp (option MemoryBlock) :=
  { blk : option MemoryBlock
  | Ifopt blk as blk'
    Then Lookup base blk' heap
    Else ~ Member base heap }.

Definition FindBlockThatFits (off len : N) (heap : EMap N MemoryBlock) :
  Comp (option (N * MemoryBlock)) :=
  { mres : option (N * MemoryBlock)
  | match mres with
    | Some (addr', blk') =>
      Lookup addr' blk' heap /\ fits addr' (memSize blk') off len
    | None =>
      All (fun addr' blk' =>
             ~ fits addr' (memSize blk') off len) heap
    end }.

Definition CopyBlock sblk soff dblk doff len :=
  (* [s] is the source region to copy from *)
  let s := KeepKeys (within soff len) (memData sblk) in
  (* [d] is where the region will be copied *)
  let d := KeepKeys (not ∘ within doff len) (memData dblk) in
  Union _ d (ShiftKeys soff doff s).

Definition emptyS   := "empty".
Definition allocS   := "alloc".
Definition reallocS := "realloc".
Definition freeS    := "free".
Definition peekS    := "peek".
Definition pokeS    := "poke".
Definition memcpyS  := "memcpy".
Definition memsetS  := "memset".

Definition HeapSpec := Def ADT {
  (* Map of memory addresses to blocks, which contain another mapping from
     offsets to initialized bytes. *)
  rep := EMap N MemoryBlock,

  Def Constructor0 emptyS : rep := ret Empty,,

  (* Allocation returns the address for the newly allocated block.
     NOTE: conditions such as out-of-memory are not handled here; the final
     implementation must decide how to handle this operationally, such as by
     throwing an exception. It remains a further research question how to
     specify error handling at this level, when certain errors -- such as
     exhausting memory -- do not belong here, since a mathematical machine has
     no such limits. *)
  Def Method1 allocS (r : rep) (len : N | 0 < len) : rep * N :=
    addr <- FindFreeBlock (` len) r;
    ret (Update addr {| memSize := ` len
                      ; memData := Empty |} r, addr),

  (* Freeing an unallocated block is a no-op. *)
  Def Method1 freeS (r : rep) (addr : N) : rep * unit :=
    ret (Remove addr r, tt),

  (* Realloc is not required to reuse the same block. If the address does not
     identify an allociated region, a new memory block is returned without any
     bytes moved. If a block did exist previously, as many bytes as possible
     are copied to the new block. *)
  Def Method2 reallocS (r : rep) (addr : N) (len : N | 0 < len) : rep * N :=
    present <- FindBlock addr r;
    naddr   <- FindFreeBlock (` len) (Remove addr r);
    ret (
      Ifopt present as blk
      Then Update naddr {| memSize := ` len
                         ; memData := Filter (fun pos _ => pos < ` len)
                                             (memData blk) |} (Remove addr r)
      Else Update naddr {| memSize := ` len
                         ; memData := Empty |} r,
      naddr),

  (* Peeking an unallocated address allows anydefault value to be returned. *)
  Def Method1 peekS (r : rep) (addr : N) : rep * Word8 :=
    mres <- FindBlockThatFits addr 1 r;
    p <- { p : Word8
         | forall v base' blk', mres = Some (base', blk')
             -> Lookup (addr - base') v (memData blk')
             -> p = v };
    ret (r, p),

  (* Poking an unallocated address is a no-op. *)
  Def Method2 pokeS (r : rep) (addr : N) (w : Word8) : rep * unit :=
    ret (Map (fun base blk =>
                Ifdec within base (memSize blk) addr
                Then {| memSize := memSize blk
                      ; memData := Update (addr - base) w (memData blk) |}
                Else blk) r, tt),

  (* Data may only be copied from one allocated block to another (or within
     the same block), and the region must fit within both source and
     destination. Otherwise, the operation is a no-op. *)
  Def Method3 memcpyS (r : rep) (addr1 : N) (addr2 : N) (len : N) :
    rep * unit :=
      Ifdec 0 < len
      Then (
        ms <- FindBlockThatFits addr1 len r;
        ret (Ifopt ms as s
             Then
               Map (fun daddr dblk =>
                 Ifdec fits daddr (memSize dblk) addr2 len
                 Then {| memSize := memSize dblk
                       ; memData :=
                           let soff := addr1 - fst s in
                           let doff := addr2 - daddr in
                           CopyBlock (snd s) soff dblk doff len |}
                 Else dblk) r
             Else r, tt))
      Else ret (r, tt),

  (* Any attempt to memset bytes outside of an allocated block is a no-op. *)
  Def Method3 memsetS (r : rep) (addr : N) (len : N) (w : Word8) :
    rep * unit :=
    ret (Map (fun base blk =>
                Ifdec fits base (memSize blk) addr len
                Then {| memSize := memSize blk
                      ; memData := Define (within (addr - base) len) w
                                          (memData blk) |}
                Else blk) r, tt)

}%ADTParsing.

Definition empty : Comp (Rep HeapSpec) :=
  Eval simpl in callCons HeapSpec emptyS.

Definition alloc (r : Rep HeapSpec) (len : N | 0 < len) :
  Comp (Rep HeapSpec * N) :=
  Eval simpl in callMeth HeapSpec allocS r len.

Definition free (r : Rep HeapSpec) (addr : N) :
  Comp (Rep HeapSpec * unit) :=
  Eval simpl in callMeth HeapSpec freeS r addr.

Definition realloc (r : Rep HeapSpec) (addr : N) (len : N | 0 < len) :
  Comp (Rep HeapSpec * N) :=
  Eval simpl in callMeth HeapSpec reallocS r addr len.

Definition peek (r : Rep HeapSpec) (addr : N) :
  Comp (Rep HeapSpec * Word8) :=
  Eval simpl in callMeth HeapSpec peekS r addr.

Definition poke (r : Rep HeapSpec) (addr : N) (w : Word8) :
  Comp (Rep HeapSpec * unit) :=
  Eval simpl in callMeth HeapSpec pokeS r addr w.

Definition memcpy (r : Rep HeapSpec) (addr : N) (addr2 : N) (len : N) :
  Comp (Rep HeapSpec * unit) :=
  Eval simpl in callMeth HeapSpec memcpyS r addr addr2 len.

Definition memset (r : Rep HeapSpec) (addr : N) (len : N) (w : Word8) :
  Comp (Rep HeapSpec * unit) :=
  Eval simpl in callMeth HeapSpec memsetS r addr len w.

(**
 ** Theorems related to the Heap specification.
 **)

Ltac inspect :=
  repeat (unfold KeepKeys, ShiftKeys, CopyBlock,
                 FindFreeBlock, FindBlock, FindBlockThatFits in *;
          destruct_computations; simpl in *;
          repeat teardown; tsubst; simpl in *;
          decisions; eauto with sets;
          try congruence).

Ltac complete IHfromADT :=
  inspect;
  try match goal with
    [ H : (?X =? ?Y) = true |- _ ] => apply N.eqb_eq in H; subst
  end;
  try (eapply IHfromADT; eassumption);
  try solve [ eapply IHfromADT; try eassumption; inspect
            | try eapply IHfromADT; eassumption
            | inspect;
              try (unfold fits, within in *; inspect; nomega);
              eapply IHfromADT; try eassumption; inspect
            | discriminate ].

Theorem allocations_have_size : forall r : Rep HeapSpec, fromADT _ r ->
  forall addr blk, Lookup addr blk r -> 0 < memSize blk.
Proof.
  intros.
  generalize dependent blk.
  generalize dependent addr.
  ADT induction r; [inversion H0|..]; complete IHfromADT.
Qed.

Theorem allocations_correct_offsets : forall r : Rep HeapSpec, fromADT _ r ->
  forall addr blk, Lookup addr blk r ->
    All (fun off _ => off < memSize blk) (memData blk).
Proof.
  intros.
  generalize dependent blk.
  generalize dependent addr.
  ADT induction r; [inversion H0|..]; intros ???;
  complete IHfromADT.
Qed.

Ltac match_sizes H IHfromADT :=
  match goal with
  | [ H1 : Lookup ?A ?X ?R, H2 : Lookup ?B ?Y ?R |- _ ] =>
    specialize (IHfromADT _ _
                  H1 (allocations_have_size H _ _ H1) _
                  H2 (allocations_have_size H _ _ H2)); subst
  end; inspect; auto.

Ltac match_sizes_r H IHfromADT :=
  match goal with
  | [ H1 : Lookup ?A ?X ?R, H2 : Lookup ?B ?Y ?R |- _ ] =>
    try rewrite <- (IHfromADT _ _
                      H1 (allocations_have_size H _ _ H1) _
                      H2 (allocations_have_size H _ _ H2)) in *
  end; inspect; auto.

Ltac check_overlaps :=
  match goal with
    [ H1 : All (fun addr' blk' => ~ overlaps addr' (memSize blk') ?XA ?XL)
               (Remove ?YA ?R),
      H2 : ?XA <> ?YA,
      H3 : 0 < ?XL,
      H4 : Lookup ?XA ?B ?R,
      H5 : 0 < memSize ?B |- _ ] =>
    eapply All_Remove_Lookup_inv with (a':=XA) in H1; eauto;
    contradiction (overlaps_irr XA H5 H3)
  end.

Theorem allocations_functional : forall r : Rep HeapSpec, fromADT _ r ->
  Functional r.
Proof.
  unfold Functional; intros.
  pose proof (allocations_have_size H _ _ H0).
  pose proof (allocations_have_size H _ _ H1).
  generalize dependent blk2.
  generalize dependent blk1.
  generalize dependent addr.
  ADT induction r; [inversion H0|..]; inspect;
  try solve [ match_sizes H IHfromADT ];
  try discriminate;
  check_overlaps.
Qed.

Theorem all_block_maps_are_functional : forall r : Rep HeapSpec, fromADT _ r ->
  All (fun _ blk => Functional (memData blk)) r.
Proof.
  unfold All, Functional; intros.
  generalize dependent b.
  generalize dependent a.
  generalize dependent blk1.
  generalize dependent blk2.
  generalize dependent addr.
  ADT induction r; inspect.
  - unfold compose in *; nomega.
  - unfold compose in *; nomega.
  - apply N.add_cancel_r in H9.
    apply Nsub_eq in H9.
    + subst.
      clear H4.
      eapply IHfromADT; eauto.
    + nomega.
    + nomega.
  - inv H3; inv H4; congruence.
Qed.

Corollary allocations_functional_r : forall r : Rep HeapSpec, fromADT _ r ->
  forall addr1 blk, Lookup addr1 blk r ->
  forall addr2, ~ Member addr2 r -> addr1 <> addr2.
Proof.
  unfold not; intros; subst; ADT induction r;
  contradiction H1;
  exists blk; assumption.
Qed.

Ltac lookup_uid H :=
  match goal with
  | [ H1 : Lookup ?A ?X ?R, H2 : Lookup ?A ?Y ?R |- _ ] =>
    pose proof (allocations_functional H _ _ H1 _ H2); subst
  end; inspect; auto.

Theorem allocations_no_overlap : forall r : Rep HeapSpec, fromADT _ r ->
  forall addr1 blk1, Lookup addr1 blk1 r ->
  forall addr2 blk2, Lookup addr2 blk2 r
    -> addr1 <> addr2
    -> ~ overlaps addr1 (memSize blk1) addr2 (memSize blk2).
Proof.
  intros.
  pose proof (allocations_have_size H _ _ H0).
  pose proof (allocations_have_size H _ _ H1).
  generalize dependent blk2.
  generalize dependent addr2.
  generalize dependent blk1.
  generalize dependent addr1.
  ADT induction r; [inversion H0|..]; complete IHfromADT;
  try lookup_uid H; eapply All_Remove_Lookup_inv in H0'; eauto;
  try nomega; eapply allocations_functional_r in H0; eauto.
Qed.

Corollary allocations_unique_fits : forall r : Rep HeapSpec, fromADT _ r ->
  forall base blk addr len,
    Lookup base blk r ->
    fits base (memSize blk) addr len ->
    Unique (fun a' b' => fits_bool a' (memSize b') addr len) base r.
Proof.
  unfold Unique; intros; intros ???.
  apply Lookup_Remove_inv in H2; destruct H2.
  pose proof (allocations_no_overlap H _ H3 _ H0 H2); nomega.
Qed.

Corollary allocations_unique_within : forall r : Rep HeapSpec, fromADT _ r ->
  forall base blk addr,
    Lookup base blk r ->
    within base (memSize blk) addr ->
    Unique (fun a' b' => within_bool a' (memSize b') addr) base r.
Proof.
  unfold Unique; intros; intros ???.
  apply Lookup_Remove_inv in H2; destruct H2.
  pose proof (allocations_no_overlap H _ H3 _ H0 H2); nomega.
Qed.

Corollary find_partitions_a_singleton : forall r : Rep HeapSpec, fromADT _ r ->
  forall addr base blk,
    Lookup base blk r
      -> within base (memSize blk) addr
      -> Same (Filter (fun a b => within a (memSize b) addr) r)
              (Single base blk).
Proof.
  intros.
  pose proof (allocations_no_overlap H _ H0).
  pose proof (allocations_functional H _ _ H0).
  split; intros; inspect;
  destruct (N.eq_dec base a); subst; auto.
  - specialize (H2 _ _ H5 n); nomega.
  - specialize (H3 _ H5); nomega.
  - specialize (H2 _ _ H5 n); nomega.
Qed.

Corollary allocations_disjoint : forall r : Rep HeapSpec, fromADT _ r ->
  forall addr blk, Lookup addr blk r
    -> forall pos, within addr (memSize blk) pos
    -> forall addr' blk', Lookup addr' blk' r
         -> addr <> addr'
         -> ~ within addr' (memSize blk') pos.
Proof. intros; pose proof (allocations_no_overlap H _ H0 _ H2 H3); nomega. Qed.

Theorem heap_is_finite : forall r : Rep HeapSpec, fromADT _ r -> Finite _ r.
Proof. intros; ADT induction r; inspect; finite_preservation; nomega. Qed.

Lemma added : forall b e,
  b <= e -> Same_set _ (fun x : N => b <= x < N.succ e)
                       (Add _ (fun x : N => b <= x < e) e).
Proof.
  unfold Same_set, Included, Add, Ensembles.In.
  split; intros.
    destruct (N.eq_dec x e); subst.
      right; constructor.
    left; unfold Ensembles.In in *; nomega.
  inv H0; unfold Ensembles.In in *;
  destruct H1; nomega.
Qed.

Lemma not_added : forall b e,
  ~ b <= e -> Same_set _ (fun x : N => b <= x < N.succ e)
                         (fun x : N => b <= x < e).
Proof. unfold Same_set, Included, Add, Ensembles.In; nomega. Qed.

Lemma N_Finite : forall b e, Finite N (fun x : N => b <= x < e).
Proof.
  intros.
  induction e using N.peano_ind; intros.
    eapply Finite_downward_closed; eauto with sets.
    unfold Included, Ensembles.In; nomega.
  destruct (N.le_decidable b e).
    rewrite added; trivial.
    constructor; trivial.
    unfold Ensembles.In; nomega.
  rewrite not_added; trivial.
Qed.

Hint Extern 5 (Finite N (within _ _)) => apply N_Finite.

Theorem all_blocks_are_finite : forall r : Rep HeapSpec, fromADT _ r ->
  All (fun _ blk => Finite _ (memData blk)) r.
Proof.
  unfold All; intros.
  generalize dependent b.
  generalize dependent a.
  ADT induction r; inspect;
  finite_preservation;
  eauto; nomega.
Qed.


Set Implicit Arguments.

Require Import Platform.Cito.ADT.
Require Import Platform.Cito.RepInv Platform.Cito.WordMap.
Require Import Platform.Cito.Inv.

Lemma starL_in : forall A P x (ls : list A),
  NoDup ls
  -> In x ls
  -> exists ls', (P x * Bags.starL P ls' ===> Bags.starL P ls)
    /\ NoDup ls'
    /\ (forall y, In y ls' <-> y <> x /\ In y ls).
  induction 1; simpl; intuition subst.

  eexists; intuition idtac.
  apply Himp_refl.
  auto.
  congruence.
  tauto.
  congruence.
  auto.

  destruct H1; intuition.
  exists (x0 :: x1); intuition idtac.
  simpl.
  eapply Himp_trans; [ | apply Himp_star_frame; [
    apply Himp_refl | apply H3 ] ].
  generalize dependent (Bags.starL P); intros.
  sepLemma.
  constructor; auto.
  intro.
  apply H5 in H4.
  tauto.
  subst; simpl in *; intuition subst.
  auto.
  apply H5 in H6; intuition.
  simpl in *; intuition subst.
  apply H5 in H6; intuition.
  subst; simpl; tauto.
  right; apply H5.
  auto.
Qed.

Lemma starL_out : forall A P x (ls : list A),
  NoDup ls
  -> In x ls
  -> exists ls', (Bags.starL P ls ===> P x * Bags.starL P ls')
    /\ NoDup ls'
    /\ (forall y, In y ls' <-> y <> x /\ In y ls).
  induction 1; simpl; intuition subst.

  eexists; intuition idtac.
  apply Himp_refl.
  auto.
  congruence.
  tauto.
  congruence.
  auto.

  destruct H1; intuition.
  exists (x0 :: x1); intuition idtac.
  simpl.
  eapply Himp_trans; [ apply Himp_star_frame; [
    apply Himp_refl | apply H3 ] | ].
  generalize dependent (Bags.starL P); intros.
  sepLemma.
  constructor; auto.
  intro.
  apply H5 in H4.
  tauto.
  subst; simpl in *; intuition subst.
  auto.
  apply H5 in H6; intuition.
  simpl in *; intuition subst.
  apply H5 in H6; intuition.
  subst; simpl; tauto.
  right; apply H5.
  auto.
Qed.

Lemma starL_permute : forall A P (ls1 : list A),
  NoDup ls1
  -> forall ls2, NoDup ls2
    -> (forall x, In x ls1 <-> In x ls2)
    -> Bags.starL P ls1 ===> Bags.starL P ls2.
  induction 1.

  inversion_clear 1; simpl; intros.
  apply Himp_refl.
  exfalso; eapply H; eauto.

  intros.
  eapply starL_in in H1.
  Focus 2.
  apply H2.
  simpl; eauto.

  destruct H1; intuition.
  simpl.
  eapply Himp_trans; [ | apply H3 ].
  apply Himp_star_frame; try apply Himp_refl.
  apply IHNoDup; auto.
  intuition.
  simpl in *.
  apply H5; intuition.
  apply H2; auto.
  apply H5 in H4; intuition.
  simpl in *.
  apply H2 in H7.
  intuition.
Qed.


From Coq Require Import Program.

Require Export init.
Require Import generic univ utils.

(* Example of a datatype-generic map. *)

(* type definition needed for gmap *)
Definition Map : vec Type 2 -> Type :=
  fun vs => vhd vs -> vhd (vtl vs).

(* helper for defining sums *)
Definition doSum (A1 B1 : Type)
  : (A1 -> B1) -> forall (A2 B2 : Type), (A2 -> B2) -> (A1 + A2) -> (B1 + B2) :=
  fun f =>
    fun _ _ g sa =>
      match sa with
      | inl a => inl (f a)
      | inr b => inr (g b)
      end.

(* helper for defining prods *)
Definition doProd (A1 B1 : Type)
  : (A1 -> B1) -> forall (A2 B2 : Type), (A2 -> B2) -> (A1 * A2) -> (B1 * B2) :=
  fun f _ _ g sa => (f (fst sa), g (snd sa)).

Definition mapConst : tyConstEnv Map :=
  fun k c =>
    match c in const k
    return kit k Map (repeat (decodeClosed (Con c)))
    with
    | Nat => fun n => n
    | Unit => fun _ => tt
    | Prod => @doProd
    | Sum => @doSum
    end.

Program Definition mConst : NGen Map :=
  nGen
  (fun tt => tt)
  (fun n => n)
  (@doSum)
  (@doProd).

Definition gmap (k : kind) (t : ty k) : kit k Map (repeat (decodeClosed t)) :=
  ngen _ mConst.


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

Require Export Category.
Require Export Category_dup2.
Require Export Map0_dup1.
Require Export Setoid_dup2.

Set Implicit Arguments.
Unset Strict Implicit.

(* Functors de Category vers Category'' *)

Section funct_def0''.

Variables (C : Category) (D : Category'').

 Section funct_laws0''.

 Variables (FOb0'' : C -> D)
   (FMap0'' : forall a b : C, Map0'' (a --> b) (Hom'' (FOb0'' a) (FOb0'' b))).

 Definition Fcomp_law0'' :=
   forall (a b c : C) (f : a --> b) (g : b --> c),
   FMap0'' a c (f o g) =_S'' FMap0'' a b f o'' FMap0'' b c g.

 Definition Fid_law0'' :=
   forall a : C, FMap0'' a a (Id a) =_S'' Id'' (FOb0'' a).

 End funct_laws0''.

Structure Functor0'' : Type :=
  {FOb0'' :> C -> D;
   FMap0'' : forall a b : C, Map0'' (a --> b) (Hom'' (FOb0'' a) (FOb0'' b));
   Prf_Fcomp_law0'' : Fcomp_law0'' FMap0'';
   Prf_Fid_law0'' : Fid_law0'' FMap0''}.

Definition FMor0'' (F : Functor0'') (a b : C) (f : a --> b) :=
  FMap0'' F a b f.

End funct_def0''.

Section functor_prop0''.

Variables (C : Category) (D : Category'').

Definition Faithful_law0'' (F : Functor0'' C D) :=
  forall (a b : C) (f g : a --> b), FMor0'' F f =_S'' FMor0'' F g -> f =_S g.

Structure > Faithful0'' : Type :=
  {Faithful_functor0'' :> Functor0'' C D;
   Prf_isFaithful0'' :> Faithful_law0'' Faithful_functor0''}.

(* full *)

Definition Full_law0'' (F : Functor0'' C D)
  (H : forall a b : C, Hom'' (F a) (F b) -> (a --> b)) :=
  forall (a b : C) (h : Hom'' (F a) (F b)), h =_S'' FMor0'' F (H a b h).

Structure > Full0'' : Type :=
  {Full_functor0'' :> Functor0'' C D;
   Full_mor0'' :
    forall a b : C,
    Hom'' (Full_functor0'' a) (Full_functor0'' b) -> (a --> b);
   Prf_isFull0'' :> Full_law0'' Full_mor0''}.

End functor_prop0''.


(*! Branchless utf-8 decoder, from https://github.com/skeeto/branchless-utf8 !*)
Require Import
        Rupicola.Lib.Api
        Rupicola.Lib.Arrays
        Rupicola.Lib.InlineTables
        Rupicola.Lib.WordNotations
        Rupicola.Examples.Utf8.Utils.

Definition masks :=
  Eval cbv in List.map byte.of_Z [0x00; 0x7f; 0x1f; 0x0f; 0x07].
Definition mins :=
  Eval cbv in List.map byte.of_Z [4194304; 0; 128; 2048; 65536].
Definition shiftc :=
  Eval cbv in List.map byte.of_Z [0; 18; 12; 6; 0].
Definition shifte :=
  Eval cbv in List.map byte.of_Z [0; 6; 4; 2; 0].

Notation f x := (@F 5 x).
Definition lengths : list (Fin.t 5) :=
  Eval cbv in
    [f 1; f 1; f 1; f 1; f 1; f 1; f 1; f 1; f 1; f 1; f 1; f 1; f 1; f 1; f 1; f 1;
     f 0; f 0; f 0; f 0; f 0; f 0; f 0; f 0; f 2; f 2; f 2; f 2; f 3; f 3; f 4; f 0].

Definition utf8_decode (ptr: word) (bs: list byte) : word * word * word :=
  let/n b0 := ListArray.get bs 0 in
  let/n len := InlineTable.get lengths (b0 >>w 3) in

  let/n ptr := ptr +w len +w (len ==w 0) in

  let/n mask := InlineTable.get masks len in
  let/n c := (b0 &w mask) <<w 18 in
  let/n b1 := ListArray.get bs 1 in
  let/n c := c |w (b1 &w 0x3f) <<w 12 in
  let/n b2 := ListArray.get bs 2 in
  let/n c := c |w (b2 &w 0x3f) <<w 6 in
  let/n b3 := ListArray.get bs 3 in
  let/n c := c |w (b3 &w 0x3f) <<w 0 in

  let/n shiftc := InlineTable.get shiftc len in
  let/n c := c >>w shiftc in

  let/n min := InlineTable.get mins len in
  let/n e := (c <w min) <<w 6 in
  let/n e := e |w ((c >>w 11) ==w 0x1b) <<w 7 in
  let/n e := e |w (0x10FFFF <w c) <<w 8 in
  let/n e := e |w (b1 &w 0xc0) >>w 2 in
  let/n e := e |w (b2 &w 0xc0) >>w 4 in
  let/n e := e |w (b3       ) >>w 6 in
  let/n e := e ^w 0x2a in

  let/n shifte := InlineTable.get shifte len in
  let/n e := e >>w shifte in

  (c, e, ptr).

#[global]
Instance spec_of_utf8_decode : spec_of "utf8_decode" :=
  fnspec! "utf8_decode" data_ptr / (data : list byte) R ~> c e ptr,
    { requires tr mem :=
        Z.of_nat (length data) >= 4 /\
        (listarray_value AccessByte data_ptr data * R)%sep mem;
      ensures tr' mem' :=
        tr' = tr /\
        (c, e, ptr) = utf8_decode data_ptr data /\
        (listarray_value AccessByte data_ptr data * R)%sep mem' }.

Import UnsizedListArrayCompiler.

#[global]
Hint Rewrite @word_of_byte_of_fin : compiler_side_conditions.
#[local] Hint Resolve Fin_to_nat_lt : compiler_side_conditions.
#[local] Hint Extern 1 => simple apply word_of_byte_sru_lt : compiler_side_conditions.
#[local] Hint Extern 10 => cbn; lia : compiler_side_conditions.

Derive utf8_decode_br2fn SuchThat
       (defn! "utf8_decode" ("data") ~> "c", "e", "ptr"
         { utf8_decode_br2fn },
         implements utf8_decode)
       As utf8_decode_br2fn_ok.
Proof.
  Time compile.
Time Qed.

Definition utf8_decode_cbytes := Eval vm_compute in
  list_byte_of_string (ToCString.c_module
    [("dummy_main_to_make_impl_get_inlined", ([], [], cmd.skip));
     &,utf8_decode_br2fn]).


Require Export PredMonad.Reflection2.PredMonadState.

(***
 *** Hoare Logic using Predicate Monads
 ***)

Definition HoareF `{PredMonadState} `{OType} {ctx} :
  OExpr ctx ((St -o> Flip Prop) -o> (St -o> A -o> St -o> Prop)
                                    -o> PM A _ -o> PM A _) :=
  (efun pre =>
   efun post =>
   efun pm =>
   edo s_pre <- Embed getM;
     Embed assumingP
       @e@ (pre _ _ @e@ s_pre _ _)
       @e@ (edo x <- pm _ _;
              edo s_post <- Embed getM;
              edo unused
                  <- Embed assertP @e@ (post _ _ @e@ s_pre _ _
                                             @e@ x _ _ @e@ s_post _ _);
              Embed returnM @e@ x _ _)).

(*
FIXME: is this true?

Lemma HoareF_fixpoint_self `{PredMonadState} `{OType} {ctx}
      pre post (pm : OExpr ctx (PM A _)) :
  HoareF @e@ pre @e@ post @e@ (HoareF @e@ pre @e@ post @e@ pm)
  =e= HoareF @e@ pre @e@ post @e@ pm.
*)

Definition HoareExpr `{PredMonadState} `{OType} {ctx} :
  OExpr ctx ((St -o> Flip Prop) -o> (St -o> A -o> St -o> Prop) -o> PM A _) :=
  (efun pre =>
   efun post =>
   edo s_pre <- Embed getM ;
     (Embed assumingP)
       @e@ (pre _ _ @e@ s_pre _ _)
       @e@ (edo x <- Embed trueP;
              edo s_post <- Embed getM;
              edo unused
                  <- Embed assertP @e@ (post _ _ @e@ s_pre _ _
                                             @e@ x _ _ @e@ s_post _ _);
              Embed returnM @e@ x _ _)).


(* Copyright © 1998-2006
 * Henk Barendregt
 * Luís Cruz-Filipe
 * Herman Geuvers
 * Mariusz Giero
 * Rik van Ginneken
 * Dimitri Hendriks
 * Sébastien Hinderer
 * Bart Kirkels
 * Pierre Letouzey
 * Iris Loeb
 * Lionel Mamane
 * Milad Niqui
 * Russell O’Connor
 * Randy Pollack
 * Nickolay V. Shmyrev
 * Bas Spitters
 * Dan Synek
 * Freek Wiedijk
 * Jan Zwanenburg
 *
 * This work is free software; you can redistribute it and/or modify
 * it under the terms of the GNU General Public License as published by
 * the Free Software Foundation; either version 2 of the License, or
 * (at your option) any later version.
 *
 * This work is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License along
 * with this work; if not, write to the Free Software Foundation, Inc.,
 * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
 *)

Require Export CoRN.model.monoids.QSposmonoid.
Require Import CoRN.algebra.CGroups.

(**
** Example of a group: $\langle$#⟨#[Qpos],$(x,y) \mapsto xy/2$ #(x,y) ↦ xy/2#$\rangle$#⟩#
The positive rationals form with the operation  $(x,y) \mapsto xy/2$
#(x,y) ↦ xy/2# a CGroup.
*)

Lemma Qpos_multdiv2_is_CGroup : is_CGroup Qpos_multdiv2_as_CMonoid divmult4.
Proof.
 intro x.
 unfold is_inverse.
 split; simpl; field; auto with *.
Qed.

Definition Qpos_multdiv2_as_CGroup := Build_CGroup
 Qpos_multdiv2_as_CMonoid divmult4 Qpos_multdiv2_is_CGroup.


Set Universe Polymorphism.

Definition le@{i j} : Type@{j} :=
  (fun A : Type@{j} => A)
  (unit : Type@{i}).
Definition eq@{i j} : Type@{j} := let x := le@{i j} in le@{j i}.

Record Inj@{i j} (A : Type@{i}) (B : Type@{j}) : Type@{j} :=
  { inj : A }.

Monomorphic Universe u1.
Let ty1 : Type@{u1} := Set.
Check Inj@{Set u1}.
(* Would fail with univ inconsistency if the universe was minimized *)

Record Inj'@{i j} (A : Type@{i}) (B : Type@{j}) : Type@{j} :=
  { inj' : A; foo : Type@{j} := eq@{i j} }.
Fail Check Inj'@{Set u1}. (* Do not drop constraint i = j *)
Check Inj'@{Set Set}.


From PetitC Require Import Semantics TypedTree Values Memory Ids Star Tactics InbuiltFuncLemmas.
Import TypedTree.

From Coq Require Import ZArith Lia Program.Basics Lists.List Logic.FunctionalExtensionality.
Open Scope nat.

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

Lemma map_injective {X Y : Type} (f : X -> Y) (Hinj : forall x x', f x = f x' -> x = x')
      (xs xs' : list X) :
    map f xs = map f xs' ->
  xs = xs'.
Proof.
  generalize dependent xs'.
  induction xs; intros; destruct xs'; try discriminate.
  - reflexivity.
  - injection H; intros.
    f_equal.
    + apply Hinj. assumption.
    + apply IHxs. assumption.
Qed.

Lemma combine_injective_of_same_length {X Y : Type} (xs xs' : list X) (ys ys' : list Y) :
    length xs = length ys ->
    length xs' = length ys' ->
    combine xs ys = combine xs' ys' ->
  xs = xs' /\ ys = ys'.
Proof.
  generalize dependent xs'. generalize dependent ys. generalize dependent ys'.
  induction xs; intros;
  destruct xs'; destruct ys; destruct ys'; try discriminate.
  - split; reflexivity.
  - injection H. intros. injection H0. intros. injection H1. intros. subst.
    split; f_equal.
    + eapply proj1; apply IHxs; eassumption.
    + eapply proj2; apply IHxs; eassumption.
Qed.

Lemma cast_reduction_deterministic : forall ty_from val_from ty_to val_to val_to',
    cast_reduction ty_from val_from ty_to val_to ->
    cast_reduction ty_from val_from ty_to val_to' ->
  val_to = val_to'.
Proof.
  intros.
  inv H; inv H0; reflexivity.
Qed.

Lemma int_arith_binop_reduction_deterministic : forall op lhs rhs result result',
    int_arith_binop_reduction op lhs rhs result ->
    int_arith_binop_reduction op lhs rhs result' ->
  result = result'.
Proof.
  intros. inv H; inv H0; reflexivity.
Qed.

Lemma comparison_reduction_determimnistic : forall comparison lhs rhs result result',
    comparison_reduction comparison lhs rhs result ->
    comparison_reduction comparison lhs rhs result' ->
  result = result'.
Proof.
  intros. inv H; inv H0; reflexivity.
Qed.

Lemma binop_reduction_deterministic :
  forall op lhs rhs result result',
      binop_reduction op lhs rhs result ->
      binop_reduction op lhs rhs result' ->
    result = result'.
Proof.
  intros.
  inv H; inv H0;
  try (inv H1; inv H2; inv H3; inv H5; inv H6; inv H7;
       reflexivity).
  - inv H1; inv H4;
    f_equal;
    apply int_value_to_Z_eq;
    etransitivity; eassumption || (symmetry; eassumption).
  - inv H1; inv H4;
    reflexivity.
  - inv H4; inv H10;
    inv H1; inv H2; inv H7; inv H8;
    reflexivity.
  - inv H1; inv H2; inv H5; inv H6;
    f_equal; apply int_value_to_Z_eq;
    eapply Z.mul_reg_l;
    try (etransitivity; eassumption || (symmetry; eassumption));
    unfold word_size; lia.
Qed.

Lemma short_circuit_reduction_first_deterministic : forall short_circuit_op lhs result result',
    short_circuit_reduction_first short_circuit_op lhs result ->
    short_circuit_reduction_first short_circuit_op lhs result' ->
  result = result'.
Proof.
  intros. inv H; inv H0; reflexivity.
Qed.

Lemma short_circuit_reduction_second_deterministic :
  forall short_circuit_op lhs rhs result result',
      short_circuit_reduction_second short_circuit_op lhs rhs result ->
      short_circuit_reduction_second short_circuit_op lhs rhs result' ->
    result = result'.
Proof.
  intros. inv H; inv H0; reflexivity.
Qed.

Lemma short_circuit_reduction_not_first_and_second :
  forall short_circuit_op lhs rhs result result',
      short_circuit_reduction_first short_circuit_op lhs result ->
      short_circuit_reduction_second short_circuit_op lhs rhs result' ->
    False.
Proof.
  intros. inv H; inv H0.
Qed.

Lemma bool_to_value_injective : forall b b',
    bool_to_value b = bool_to_value b' ->
  b = b'.
Proof.
  intros [|] [|]; reflexivity || discriminate.
Qed.

Lemma incr_or_decr_reduction_deterministic : forall ty incr_or_decr val result result',
    incr_or_decr_reduction ty incr_or_decr val result ->
    incr_or_decr_reduction ty incr_or_decr val result' ->
  result = result'.
Proof.
  intros.
  inv H; inv H0; repeat f_equal.
  - apply int_value_to_Z_eq.
    etransitivity; eassumption || (symmetry; eassumption).
  - apply bool_to_value_injective; symmetry; assumption.
Qed.

Lemma write_deterministic : forall mem ptr value mem' mem'',
    write mem ptr value mem' ->
    write mem ptr value mem'' ->
  mem' = mem''.
Proof.
  intros.
  inv H; inv H0; repeat f_equal.
  rewrite H1 in H8. injection H8. intros. subst. reflexivity.
Qed.

Lemma read_deterministic : forall mem ptr value value',
    read mem ptr value ->
    read mem ptr value' ->
  value = value'.
Proof.
  intros.
  inv H; inv H0.
  - rewrite H1 in H5. injection H5. intros. subst. reflexivity.
  - rewrite H1 in H7. injection H7. intros. subst.
    rewrite H2 in H8. injection H8. intros. subst. reflexivity.
Qed.

Lemma expr_head_reduction_determinisntic :
  forall var_ptrs state expr state' expr' state'' expr'',
      expr_head_reduction var_ptrs (state, expr) (state', expr') ->
      expr_head_reduction var_ptrs (state, expr) (state'', expr'') ->
    state' = state'' /\ expr' = expr''.
Proof.
  intros.
  inv H; inv H0.
  - split; try reflexivity; repeat f_equal.
    eapply cast_reduction_deterministic; eassumption.
  - split; reflexivity.
  - split; try reflexivity; repeat f_equal.
    eapply binop_reduction_deterministic; eassumption.
  - split; try reflexivity; repeat f_equal.
    apply bool_to_value_injective in H4. subst.
    eapply short_circuit_reduction_first_deterministic; eassumption.
  - split; try reflexivity; repeat f_equal.
    apply bool_to_value_injective in H4. subst.
    exfalso. eapply short_circuit_reduction_not_first_and_second; eassumption.
  - split; try reflexivity; repeat f_equal.
    apply bool_to_value_injective in H4. subst.
    exfalso. eapply short_circuit_reduction_not_first_and_second; eassumption.
  - split; try reflexivity; repeat f_equal.
    apply bool_to_value_injective in H4.
    apply bool_to_value_injective in H5. subst.
    eapply short_circuit_reduction_second_deterministic; eassumption.
  - split; try reflexivity; repeat f_equal.
    apply bool_to_value_injective. symmetry. assumption.
  - assert (Hbefore : before = before0).
    { eapply read_deterministic; eassumption. }
    subst.
    assert (Hafter : after = after0).
    { eapply incr_or_decr_reduction_deterministic; eassumption. }
    subst.
    split; try reflexivity; repeat f_equal.
    eapply write_deterministic; eassumption.
  - split; try reflexivity; repeat f_equal.
    eapply write_deterministic; eassumption.
  - assert (Heq : mem' = mem'0 /\ out' = out'0 /\ returned = returned0);
    try (destruct Heq as [Heq0 [Heq1 Heq2]]; subst; split; reflexivity).
    assert (Hargs : args = args0).
    { apply list_to_list_annotated_expr_injective in H5.
      apply map_injective in H5;
      try (intros [] [] H; injection H; intros; subst; reflexivity).
      apply combine_injective_of_same_length in H5; try assumption.
      destruct H5. symmetry. assumption. }
    subst.
    eapply inbuilt_func_deterministic; eassumption.
  - split; try reflexivity; repeat f_equal.
    rewrite H2 in H1. injection H1. intros. subst. reflexivity.
Qed.

Definition reducible (expr : annotated_expr) : Prop :=
  (exists var_ptrs state state' expr',
    expr_head_reduction var_ptrs (state, expr) (state', expr')).

Lemma expr_head_reduction_context_injective : forall ctx expr expr',
    expr_context ctx ->
    ctx expr = ctx expr' ->
  expr = expr'.
Proof.
  intros.
  generalize dependent expr'. generalize dependent expr0.
  revert H. generalize dependent ctx.
  apply (expr_context_mutual_ind
    (fun ctx => forall expr expr', ctx expr = ctx expr' -> expr = expr')
    (fun ctx => forall expr expr', ctx expr = ctx expr' -> expr = expr')
    (fun ctx => forall expr expr', ctx expr = ctx expr' -> expr = expr'));
  intros;
  assumption || apply H0; injection H1 as H1; assumption.
Qed.

Ltac inv_context :=
  match goal with
  | H : expr_context _ |- _      => inv H; try discriminate; try reflexivity
  | H : lvalue_context _ |- _    => inv H; try discriminate; try reflexivity
  | H : list_expr_context _ |- _ => inv H; try discriminate; try reflexivity
  end.

Ltac destruct_reducible :=
  match goal with
  | H : reducible _ |- _ =>
    let var_ptrs := fresh "var_ptrs" in
    let state := fresh "state" in
    let state' := fresh "state" in
    let expr := fresh "expr" in
    destruct H as [var_ptrs [state [state' [expr H]]]];
    inv H; try discriminate; try reflexivity
  end.

Lemma not_arg_exprs_eq_subst_call : forall ctx arg_vals arg_rich_types func_id arg_exprs return_ty,
    list_expr_context ctx ->
    list_to_list_annotated_expr (map (fun '(val, ty) => Const val <: ty)
                                     (combine arg_vals arg_rich_types))
    = ctx (Call func_id arg_exprs <: return_ty) ->
  False.
Proof.
  intros. generalize dependent arg_vals. generalize dependent arg_rich_types.
  induction H; intros;
  destruct arg_vals; destruct arg_rich_types; try discriminate.
  - inv H; discriminate.
  - injection H0. intros. subst.
    eapply IHlist_expr_context. eassumption.
Qed.

Lemma not_arg_exprs_eq_subst_head_reducible :
  forall ctx arg_vals arg_rich_types var_ptrs state state' expr expr',
      list_expr_context ctx ->
      expr_head_reduction var_ptrs (state, expr) (state', expr') ->
      list_to_list_annotated_expr (map (fun '(val, ty) => Const val <: ty)
                                      (combine arg_vals arg_rich_types))
      = ctx expr ->
    False.
Proof.
  intros. generalize dependent arg_vals. generalize dependent arg_rich_types.
  induction H; intros;
  destruct arg_vals; destruct arg_rich_types; try discriminate.
  - inv H; try discriminate.
    inv H0; discriminate.
  - injection H1. intros. subst.
    eapply IHlist_expr_context. eassumption.
Qed.

Lemma expr_head_reduction_context_unique : forall ctx expr ctx' expr',
    reducible expr ->
    reducible expr' ->
    expr_context ctx ->
    expr_context ctx' ->
    ctx expr = ctx' expr' ->
  ctx = ctx'.
Proof.
  (* this takes a few minutes and a few gigabytes of ram *)
  intros. revert H3. revert H2. revert H0. revert H. revert expr'. revert ctx'. revert expr0.
  revert H1. revert ctx.
  apply (expr_context_mutual_ind
    (fun ctx => forall expr ctx' expr', reducible expr -> reducible expr' ->
      expr_context ctx' -> ctx expr = ctx' expr' -> ctx = ctx')
    (fun ctx => forall expr ctx' expr', reducible expr -> reducible expr' ->
      lvalue_context ctx' -> ctx expr = ctx' expr' -> ctx = ctx')
    (fun ctx => forall expr ctx' expr', reducible expr -> reducible expr' ->
      list_expr_context ctx' -> ctx expr = ctx' expr' -> ctx = ctx'));
  intros;
  try (inv H3;
       try (injection H4; intros; subst;
           assert (Hctx : ctx = ctx0); try (rewrite Hctx; reflexivity);
           (apply (H0 expr0 ctx0 expr') || apply (H0 expr1 ctx0 expr')); assumption);
      inv_context; repeat destruct_reducible;
      fail);
  try (inv_context;
       try (injection H4; intros; subst;
            assert (Hctx : ctx = ctx0); try (rewrite Hctx; reflexivity);
            (apply (H0 expr0 ctx0 expr') || apply (H0 expr1 ctx0 expr')); assumption;
            fail);
       try (destruct_reducible; destruct H1 as [var_ptrs [state [state' [expr' H1]]]];
            injection H5; intros;
            exfalso; eapply not_arg_exprs_eq_subst_head_reducible; eassumption);
       try (inv H5; inv H3; destruct_reducible; fail);
       try (repeat destruct_reducible; inv_context; fail);
       try (inv H; repeat destruct_reducible; fail);
       try (inv_context; inv_context; repeat destruct_reducible; fail);
       try (inv H; inv H3; repeat destruct_reducible; fail);
       fail).
  repeat destruct_reducible;
  try (inv_context; inv_context; inv_context; fail);
  inv_context;
  injection H2; intros;
  exfalso;
  try (eapply (not_arg_exprs_eq_subst_head_reducible _ _ _ var_ptrs state0 state0) ||
       eapply (not_arg_exprs_eq_subst_head_reducible _ _ _ var_ptrs (mem, out) (mem', out)) ||
       eapply (not_arg_exprs_eq_subst_head_reducible _ _ _ var_ptrs (mem', out') (mem'0, out'0));
       eassumption || (econstructor; eassumption)).
  eapply (not_arg_exprs_eq_subst_head_reducible _ _ _ var_ptrs (mem, out) (mem', out'));
  eassumption || (econstructor; eassumption).
Qed.

Lemma expr_func_reduction_context_unique :
  forall ctx ctx' func_id return_ty arg_vals arg_rich_types
                  func_id' return_ty' arg_vals' arg_rich_types',
    expr_context ctx ->
    expr_context ctx' ->
    let arg_exprs := list_to_list_annotated_expr
      (map (fun '(val, ty) => Const val <: ty)
           (combine arg_vals arg_rich_types)) in
    let call_expr := Call func_id arg_exprs <: return_ty in
    let arg_exprs' := list_to_list_annotated_expr
      (map (fun '(val, ty) => Const val <: ty)
           (combine arg_vals' arg_rich_types')) in
    let call_expr' := Call func_id' arg_exprs' <: return_ty' in
    ctx call_expr = ctx' call_expr' ->
  ctx = ctx'.
Proof.
  intros. generalize dependent ctx'. generalize dependent ctx.
  apply (expr_context_mutual_ind
    (fun ctx => forall ctx',
      expr_context ctx' -> ctx call_expr = ctx' call_expr' -> ctx = ctx')
    (fun ctx => forall ctx',
      lvalue_context ctx' -> ctx call_expr = ctx' call_expr' -> ctx = ctx')
    (fun ctx => forall ctx',
      list_expr_context ctx' -> ctx call_expr = ctx' call_expr' -> ctx = ctx'));
  intros;
  unfold call_expr in *; unfold call_expr' in *;
  try (inv H1; try discriminate;
       try (inv H; try discriminate; inv H1; discriminate);
       try (inv H3; try discriminate; inv H1; discriminate);
       injection H2; intros; subst;
       assert (Hctx : ctx = ctx0); try (rewrite Hctx; reflexivity);
       apply H0; assumption).
  - unfold arg_exprs in *.
    inv H; try discriminate; try reflexivity.
    injection H0; intros.
    exfalso. eapply not_arg_exprs_eq_subst_call; eassumption.
  - inv H1; try discriminate.
    + injection H2; intros.
      unfold arg_exprs' in *.
      exfalso. eapply not_arg_exprs_eq_subst_call.
      * eassumption.
      * symmetry. eassumption.
    + injection H2. intros. subst.
      assert (Hctx : ctx = ctx0); try (rewrite Hctx; reflexivity).
      apply H0; assumption.
Qed.

Lemma expr_func_reduction_context_injective :
  forall ctx,
    expr_context ctx ->
  forall func_id return_ty arg_vals arg_rich_types
         func_id' return_ty' arg_vals' arg_rich_types',
    let arg_exprs := list_to_list_annotated_expr
      (map (fun '(val, ty) => Const val <: ty)
           (combine arg_vals arg_rich_types)) in
    let call_expr := Call func_id arg_exprs <: return_ty in
    let arg_exprs' := list_to_list_annotated_expr
      (map (fun '(val, ty) => Const val <: ty)
           (combine arg_vals' arg_rich_types')) in
    let call_expr' := Call func_id' arg_exprs' <: return_ty' in
    ctx call_expr = ctx call_expr' ->
  call_expr = call_expr'.
Proof.
  apply (expr_context_mutual_ind
    (fun ctx => forall func_id return_ty arg_vals arg_rich_types
                       func_id' return_ty' arg_vals' arg_rich_types',
        let arg_exprs := list_to_list_annotated_expr
          (map (fun '(val, ty) => Const val <: ty)
              (combine arg_vals arg_rich_types)) in
        let call_expr := Call func_id arg_exprs <: return_ty in
        let arg_exprs' := list_to_list_annotated_expr
          (map (fun '(val, ty) => Const val <: ty)
              (combine arg_vals' arg_rich_types')) in
        let call_expr' := Call func_id' arg_exprs' <: return_ty' in
        ctx call_expr = ctx call_expr' ->
      call_expr = call_expr')
  (fun ctx => forall func_id return_ty arg_vals arg_rich_types
                     func_id' return_ty' arg_vals' arg_rich_types',
        let arg_exprs := list_to_list_annotated_expr
          (map (fun '(val, ty) => Const val <: ty)
              (combine arg_vals arg_rich_types)) in
        let call_expr := Call func_id arg_exprs <: return_ty in
        let arg_exprs' := list_to_list_annotated_expr
          (map (fun '(val, ty) => Const val <: ty)
              (combine arg_vals' arg_rich_types')) in
        let call_expr' := Call func_id' arg_exprs' <: return_ty' in
        ctx call_expr = ctx call_expr' ->
      call_expr = call_expr')
  (fun ctx => forall func_id return_ty arg_vals arg_rich_types
                     func_id' return_ty' arg_vals' arg_rich_types',
        let arg_exprs := list_to_list_annotated_expr
          (map (fun '(val, ty) => Const val <: ty)
              (combine arg_vals arg_rich_types)) in
        let call_expr := Call func_id arg_exprs <: return_ty in
        let arg_exprs' := list_to_list_annotated_expr
          (map (fun '(val, ty) => Const val <: ty)
              (combine arg_vals' arg_rich_types')) in
        let call_expr' := Call func_id' arg_exprs' <: return_ty' in
        ctx call_expr = ctx call_expr' ->
      call_expr = call_expr'));
  intros;
  assumption || apply H0; injection H1 as H1; assumption.
Qed.

Lemma not_subst_call_expr_eq_subst_head_reducible :
  forall ctx,
    expr_context ctx ->
  forall ctx' arg_vals arg_rich_types func_id return_ty var_ptrs expr expr' state state',
    expr_context ctx' ->
    expr_head_reduction var_ptrs (state, expr) (state', expr') ->
    let arg_exprs := list_to_list_annotated_expr
      (map (fun '(val, ty) => Const val <: ty)
          (combine arg_vals arg_rich_types)) in
    let call_expr := Call func_id arg_exprs <: return_ty in
    ctx call_expr = ctx' expr ->
  False.
Proof.
  apply (expr_context_mutual_ind
    (fun ctx =>
      forall ctx' arg_vals arg_rich_types func_id return_ty var_ptrs expr expr' state state',
        expr_context ctx' ->
        expr_head_reduction var_ptrs (state, expr) (state', expr') ->
        let arg_exprs := list_to_list_annotated_expr
          (map (fun '(val, ty) => Const val <: ty)
              (combine arg_vals arg_rich_types)) in
        let call_expr := Call func_id arg_exprs <: return_ty in
        ctx call_expr = ctx' expr ->
      False)
    (fun ctx =>
      forall ctx' arg_vals arg_rich_types func_id return_ty var_ptrs expr expr' state state',
        lvalue_context ctx' ->
        expr_head_reduction var_ptrs (state, expr) (state', expr') ->
        let arg_exprs := list_to_list_annotated_expr
          (map (fun '(val, ty) => Const val <: ty)
              (combine arg_vals arg_rich_types)) in
        let call_expr := Call func_id arg_exprs <: return_ty in
        ctx call_expr = ctx' expr ->
      False)
    (fun ctx =>
      forall ctx' arg_vals arg_rich_types func_id return_ty var_ptrs expr expr' state state',
        list_expr_context ctx' ->
        expr_head_reduction var_ptrs (state, expr) (state', expr') ->
        let arg_exprs := list_to_list_annotated_expr
          (map (fun '(val, ty) => Const val <: ty)
              (combine arg_vals arg_rich_types)) in
        let call_expr := Call func_id arg_exprs <: return_ty in
        ctx call_expr = ctx' expr ->
      False));
  intros;
  try (inv H1; try discriminate;
       (inv H2; try discriminate; inv H; discriminate) ||
       (inv H; inv H2; inv H1; discriminate) ||
       (injection H3; intros; subst; eapply H0; eassumption) ||
       (inv H4; try discriminate; inv H2; discriminate) ||
       (inv H4; inv H1; try discriminate; inv H2; discriminate)).
  - unfold call_expr in *. inv H; try discriminate.
    + inv H0; discriminate.
    + injection H1. intros. subst.
      eapply not_arg_exprs_eq_subst_head_reducible; eassumption.
  - inv H1; try discriminate.
    + assert (H2' := H2).
      inv H2; try discriminate.
      injection H4. intros. subst.
      unfold call_expr in *. unfold arg_exprs in *.
      eapply not_arg_exprs_eq_subst_call; eassumption.
    + injection H3. intros.
      eapply H0; eassumption.
Qed.

Lemma assign_vars_deterministic : forall var_ptrs mem var_ids vals mem' mem'',
    assign_vars var_ptrs mem var_ids vals mem' ->
    assign_vars var_ptrs mem var_ids vals mem'' ->
  mem' = mem''.
Proof.
  intros.
  generalize dependent mem''.
  induction H; intros.
  - inv H0. reflexivity.
  - inv H0. inv H1. inv H10.
    rewrite H2 in H0. injection H0. intros. subst.
    assert (Heq : mem' = mem'0).
    { apply IHassign_vars. assumption. }
    subst.
    eapply write_deterministic; eassumption.
Qed.

Lemma allocate_vars_deterministic :
  forall mem var_ptrs var_ids mem' var_ptrs' mem'' var_ptrs'',
      allocate_vars mem var_ptrs var_ids mem' var_ptrs' ->
      allocate_vars mem var_ptrs var_ids mem'' var_ptrs'' ->
    (mem', var_ptrs') = (mem'', var_ptrs'').
Proof.
  intros.
  generalize dependent var_ptrs''. generalize dependent mem''.
  induction H; intros.
  - inv H0. reflexivity.
  - inv H1.
    apply IHallocate_vars in H6.
    injection H6. intros. subst.
    rewrite <- H0 in H9.
    injection H9. intros. subst. reflexivity.
Qed.

Lemma call_var_ptrs_and_mem_deterministic :
  forall var_ptrs mem arg_var_ids arg_vals var_ptrs' mem' var_ptrs'' mem'',
    call_var_ptrs_and_mem
      var_ptrs mem arg_var_ids arg_vals var_ptrs' mem' ->
    call_var_ptrs_and_mem
      var_ptrs mem arg_var_ids arg_vals var_ptrs'' mem'' ->
  (var_ptrs', mem') = (var_ptrs'', mem'').
Proof.
  intros.
  inv H. inv H0.
  assert (Heq : (mem'0, var_ptrs') = (mem'1, var_ptrs'')).
  { eapply allocate_vars_deterministic; eassumption. }
  injection Heq. intros. subst.
  f_equal.
  eapply assign_vars_deterministic; eassumption.
Qed.

Theorem continued_step_deterministic' :
  forall funcs var_ptrs var_ptrs' var_ptrs'' state state' state'' cont cont' cont'',
      continued_step funcs (var_ptrs, state, cont) (var_ptrs', state', cont') ->
      continued_step funcs (var_ptrs, state, cont) (var_ptrs'', state'', cont'') ->
    (var_ptrs', state', cont') = (var_ptrs'', state'', cont'').
Proof.
  intros; inv H; inv H0; try reflexivity;
  try (f_equal; f_equal; inv_context; inv H8; discriminate);
  try (apply bool_to_value_injective in H3; subst; reflexivity).
  - assert (Hctx: ctx0 = ctx).
    { eapply expr_head_reduction_context_unique;
      eassumption || (repeat eexists); eassumption. }
    subst.
    apply expr_head_reduction_context_injective in H4; try assumption. subst.
    f_equal; f_equal.
    + eapply proj1. eapply expr_head_reduction_determinisntic; eassumption.
    + f_equal. eapply proj2. eapply expr_head_reduction_determinisntic; eassumption.
  - eapply not_subst_call_expr_eq_subst_head_reducible in H2; try eassumption.
    destruct H2.
  - symmetry in H3.
    eapply not_subst_call_expr_eq_subst_head_reducible in H3; try eassumption.
    destruct H3.
  - assert (H3' := H3).
    eapply expr_func_reduction_context_unique in H3'; try assumption. subst.
    apply expr_func_reduction_context_injective in H3; try assumption.
    injection H3. intros. subst.
    rewrite H6 in H4. injection H4. intros. subst.
    apply list_to_list_annotated_expr_injective in H0.
    apply map_injective in H0.
    + apply combine_injective_of_same_length in H0; try assumption.
      destruct H0. subst.
      f_equal.
      assert (Heq : (var_ptrs', mem') = (var_ptrs'', mem'0)).
      { eapply call_var_ptrs_and_mem_deterministic; eassumption. }
      injection Heq. intros. subst. reflexivity.
    + intros. destruct x. destruct x'. injection H1. intros. subst. reflexivity.
Qed.

Fixpoint csubst (outer inner : continuation_after_cmd) :
                       continuation_after_cmd :=
  match outer with
  | KStop => inner
  | KSeq cmd cont                 => KSeq cmd (csubst cont inner)
  | KWhileAfterCmd expr cmd cont  => KWhileAfterCmd expr cmd (csubst cont inner)
  | KCall ctx var_ptrs cont       => KCall ctx var_ptrs (esubst cont inner)
  end

with esubst (outer : continuation_after_expr) (inner : continuation_after_cmd) :
                   continuation_after_expr :=
  match outer with
  | KExpr cont                    => KExpr (csubst cont inner)
  | KIf cmd cmd' cont             => KIf cmd cmd' (csubst cont inner)
  | KWhileAfterExpr expr cmd cont => KWhileAfterExpr expr cmd (csubst cont inner)
  end.

Lemma Skip_KStop_final funcs var_ptrs state :
  final (continued_step funcs) (var_ptrs, state, ContinuedCmd Skip KStop).
Proof.
  intros y H. inv H.
Qed.

Lemma continued_step_deterministic funcs :
  deterministic (continued_step funcs).
Proof.
  intro. intros.
  destruct x. destruct y. destruct y'. destruct p. destruct p0. destruct p1.
  eapply continued_step_deterministic'; eassumption.
Qed.

Lemma continued_step_same_continuation_of_continued_step_SKip_KStop funcs nb_steps var_ptrs state
                                                                    var_ptrs' state' cmd cont :
  star_count (continued_step funcs) nb_steps (var_ptrs, state, ContinuedCmd cmd cont)
                                             (var_ptrs', state', ContinuedCmd Skip KStop) ->
  exists nb_steps' var_ptrs'' state'', nb_steps' <= nb_steps /\
    star_count (continued_step funcs) nb_steps' (var_ptrs, state, ContinuedCmd cmd cont)
                                                (var_ptrs'', state'', ContinuedCmd Skip cont).
Proof. Admitted.

Lemma continued_step_KStop_of_continued_step_Skip_same_cont
        funcs nb_steps var_ptrs var_ptrs' state state' cmd cont :
  star_count (continued_step funcs) nb_steps (var_ptrs, state, ContinuedCmd cmd cont)
                                             (var_ptrs', state', ContinuedCmd Skip cont) ->
  exists nb_steps' var_ptrs'' state'', nb_steps' <= nb_steps /\
    star_count (continued_step funcs) nb_steps' (var_ptrs, state, ContinuedCmd cmd KStop)
                                                (var_ptrs'', state'', ContinuedCmd Skip KStop).
Proof. Admitted.

Lemma continued_step_csubst_of_continued_step
        nb_steps funcs var_ptrs state var_ptrs' state' cmd cmd' cont cont' sub_cont :
  star_count (continued_step funcs) nb_steps
    (var_ptrs, state, ContinuedCmd cmd cont)
    (var_ptrs', state', ContinuedCmd cmd' cont) ->
  star_count (continued_step funcs) nb_steps
    (var_ptrs, state, ContinuedCmd cmd (csubst cont sub_cont))
    (var_ptrs', state', ContinuedCmd cmd' (csubst cont' sub_cont)).
Proof. Admitted.

Lemma continued_step_KStop_and_cont_of_continued_step_Skip_same_cont
        funcs nb_steps var_ptrs var_ptrs' state state' cmd cont :
  star_count (continued_step funcs) nb_steps (var_ptrs, state, ContinuedCmd cmd cont)
                                             (var_ptrs', state', ContinuedCmd Skip cont) ->
  exists nb_steps' var_ptrs'' state'', nb_steps' <= nb_steps /\
    star_count (continued_step funcs) nb_steps' (var_ptrs, state, ContinuedCmd cmd KStop)
                                                (var_ptrs'', state'', ContinuedCmd Skip KStop) /\
    star_count (continued_step funcs) nb_steps' (var_ptrs, state, ContinuedCmd cmd cont)
                                                (var_ptrs'', state'', ContinuedCmd Skip cont).
Proof.
  intros.
  destruct (continued_step_KStop_of_continued_step_Skip_same_cont _ _ _ _ _ _ _ _ H)
    as [nb_steps' [var_ptrs'' [state'' [Hle Hstar_count]]]].
  exists nb_steps'. exists var_ptrs''. exists state''.
  repeat split; try assumption.
  assert (Heq_subst : cont = csubst KStop cont). { reflexivity. }
  rewrite Heq_subst.
  apply continued_step_csubst_of_continued_step.
  assumption.
Qed.

Lemma continued_step_KStop_and_cont_of_continued_step_Skip_KStop
        funcs nb_steps var_ptrs var_ptrs' state state' cmd cont :
  star_count (continued_step funcs) nb_steps (var_ptrs, state, ContinuedCmd cmd cont)
                                             (var_ptrs', state', ContinuedCmd Skip KStop) ->
  exists nb_steps' var_ptrs'' state'', nb_steps' <= nb_steps /\
    star_count (continued_step funcs) nb_steps' (var_ptrs, state, ContinuedCmd cmd KStop)
                                                (var_ptrs'', state'', ContinuedCmd Skip KStop) /\
    star_count (continued_step funcs) nb_steps' (var_ptrs, state, ContinuedCmd cmd cont)
                                                (var_ptrs'', state'', ContinuedCmd Skip cont).
Proof.
  intros.
  destruct (continued_step_same_continuation_of_continued_step_SKip_KStop _ _ _ _ _ _ _ _ H)
      as [nb_steps' [var_ptrs'' [state'' [Hle Hstar_count]]]].
  destruct
    (continued_step_KStop_and_cont_of_continued_step_Skip_same_cont _ _ _ _ _ _ _ _ Hstar_count)
    as [nb_steps0 [var_ptrs0 [state0 [Hineq [Hstar_count0 Hstar_count1]]]]].
  exists nb_steps0. exists var_ptrs0. exists state0.
  repeat split; try assumption. lia.
Qed.

Lemma continued_step_KExpr_of_continued_step_KStop
  nb_steps funcs var_ptrs var_ptrs' state state' expr :
    star_count (continued_step funcs) nb_steps
                    (var_ptrs, state, ContinuedExpr expr (KExpr KStop))
                    (var_ptrs', state', ContinuedCmd Skip KStop) ->
    exists val ty,
      star_count (continued_step funcs) (nb_steps-1)
                      (var_ptrs, state, ContinuedExpr expr (KExpr KStop))
                      (var_ptrs', state', ContinuedExpr (Const val <: ty) (KExpr KStop)).
Proof. Admitted.

Lemma continued_step_KStop_and_cont_of_continued_step_Expr_const_KStop
        funcs nb_steps var_ptrs var_ptrs' state state' expr cont :
  star_count (continued_step funcs) nb_steps
                    (var_ptrs, state, ContinuedExpr expr cont)
                    (var_ptrs', state', ContinuedCmd Skip KStop) ->
  exists nb_steps' var_ptrs'' state'' val ty, nb_steps' <= nb_steps /\
    star_count (continued_step funcs) nb_steps'
                      (var_ptrs, state, ContinuedExpr expr (KExpr KStop))
                      (var_ptrs'', state'', ContinuedExpr (Const val <: ty) (KExpr KStop)) /\
    star_count (continued_step funcs) nb_steps'
                      (var_ptrs, state, ContinuedExpr expr cont)
                      (var_ptrs'', state'', ContinuedExpr (Const val <: ty) cont).
Proof. Admitted.