Require Import Arith AutoSep Malloc SinglyLinkedList.
Import SinglyLinkedList.SinglyLinkedList.

(* Requests that the server may receive.
 * (W is the type of machine words.) *)
Inductive req :=
| ValueIsGe (index valueLowerBound : W)
(* Test if the value stored at this index is at least as large as this value. *)

| MaxInRange (lowerBound upperBound : W)
(* Find the maximum value within the given range of values. *)

| CollectBelow (indexLowerBound valueUpperBound : W)
(* Collect a list of all values satisfying the given bounds on index and value. *).

(* Mathematical function to represent requests as lists of machine words.
 * (Dollar-sign operator is for machine word constants.) *)
Definition encode (r : req) : list W :=
  match r with
    | ValueIsGe a b => $0 :: a :: b :: nil
    | MaxInRange a b => $1 :: a :: b :: nil
    | CollectBelow a b => $2 :: a :: b :: nil
  end.

Fixpoint encodeAll (rs : list req) : list W :=
  match rs with
    | nil => nil
    | r :: rs' => encode r ++ encodeAll rs'
  end.

(* Helper functions to express semantics of requests *)

Definition valueIsGe (data : list W) (index lower : W) : W :=
  if le_lt_dec (length data) (wordToNat index)
    then $0
    else if wlt_dec (Array.sel data index) lower then $0 else $1.

Definition wmax (w w' : W) : W :=
  if wlt_dec w' w then w else w'.

Fixpoint maxInRange (lower upper : W) (data : list W) : W :=
  match data with
    | nil => O
    | w :: ws =>
      let max := maxInRange lower upper ws in
        if wlt_dec w lower
          then max
          else if wlt_dec upper w
            then max
            else wmax w max
  end.

Fixpoint collectBelow (upper : W) (data acc : list W) : list W :=
  match data with
    | nil => acc
    | w :: ws =>
      if wlt_dec upper w
        then collectBelow upper ws acc
        else collectBelow upper ws (w :: acc)
  end.

(* Mathematical function to compute the proper response to a request,
 * in terms of a transformation on a list of output values. *)
Definition response (data : list W) (acc : list W) (r : req) : list W :=
  match r with
    | ValueIsGe index lower => valueIsGe data index lower :: acc
    | MaxInRange lower upper =>
      maxInRange lower upper data :: acc
    | CollectBelow lower upper =>
      collectBelow upper (skipn (wordToNat lower) data) acc
  end.

Definition responseAll (data : list W) (rs : list req) (acc : list W) :=
  fold_left (response data) rs acc.

Definition mainS := SPEC("cmd", "cmdLen", "data", "dataLen") reserving 15
  Al r, Al d,
  PRE[V] array (encodeAll r) (V "cmd") * array d (V "data") * mallocHeap
    * [| V "cmdLen" = length (encodeAll r) |] * [| V "dataLen" = length d |]
    * [| goodSize (length (encodeAll r) + 3) |]
  POST[R] array (encodeAll r) (V "cmd") * array d (V "data") * mallocHeap
    * sll (responseAll d r nil) R.

Definition m := bimport [[ "malloc"!"malloc" @ [mallocS] ]]
  bmodule "m" {{
    bfunction "main"("cmd", "cmdLen", "data", "dataLen",
                     "output", "position", "posn", "lower", "upper",
                     "index", "value", "res", "node") [mainS]
      "output" <- 0;;
      "position" <- 0;;

      [Al rdone, Al r, Al d, Al out,
       PRE[V] array (rdone ++ encodeAll r) (V "cmd") * array d (V "data") * mallocHeap
         * sll out (V "output") * [| V "position" = length rdone |]
         * [| V "cmdLen" = (length rdone + length (encodeAll r))%nat |] * [| V "dataLen" = length d |]
         * [| goodSize (length rdone + length (encodeAll r) + 3) |]
       POST[R] array (rdone ++ encodeAll r) (V "cmd") * array d (V "data") * mallocHeap
         * sll (responseAll d r out) R]
      While ("position" < "cmdLen") {
        Match "cmd" Size "cmdLen" Position "position" {
          (* ValueIsGe *)
          Case (0 ++ "posn" ++ "lower")
            "res" <- 0;;

            [Al rdone, Al r, Al out,
              After prefix Approaching all
                PRE[V] array (rdone ++ encodeAll (ValueIsGe (V "posn") (V "lower") :: r)) (V "cmd")
                  * mallocHeap * sll out (V "output") * [| V "position" = natToW (length rdone + 3) |]
                  * [| V "cmdLen" = (length rdone + 3 + length (encodeAll r))%nat |]
                  * [| V "dataLen" = length all |]
                  * [| V "res" = valueIsGe prefix (V "posn") (V "lower") |]
                  * [| goodSize (length rdone + 3 + length (encodeAll r) + 3) |]
                POST[R] array (rdone ++ encodeAll (ValueIsGe (V "posn") (V "lower") :: r)) (V "cmd")
                  * mallocHeap * sll (responseAll all (ValueIsGe (V "posn") (V "lower") :: r) out) R ]
            For "index" Holding "value" in "data" Size "dataLen"
              Where ((Index = "posn") && (Value >= "lower")) {
              "res" <- 1
            };;

            "node" <-- Call "malloc"!"malloc"(0)
            [Al rdone, Al r, Al d, Al out,
              PRE[V, MR] array (rdone ++ encodeAll r) (V "cmd") * array d (V "data") * mallocHeap
                * sll out (V "output") * [| V "position" = length rdone |]
                * [| V "cmdLen" = (length rdone + length (encodeAll r))%nat |] * [| V "dataLen" = length d |]
                * [| goodSize (length rdone + length (encodeAll r) + 3) |]
                * MR =?> 2 * [| MR <> 0 |]
              POST[R] array (rdone ++ encodeAll r) (V "cmd") * array d (V "data") * mallocHeap
                * sll (responseAll d r (V "res" :: out)) R];;

            "node" *<- "res";;
            "node" + 4 *<- "output";;
            "output" <- "node"
          end;;

          (* MaxInRange *)
          Case (1 ++ "lower" ++ "upper")
            "res" <- 0;;

            [Al rdone, Al r, Al out,
              After prefix Approaching all
                PRE[V] array (rdone ++ encodeAll (MaxInRange (V "lower") (V "upper") :: r)) (V "cmd")
                  * mallocHeap * sll out (V "output") * [| V "position" = natToW (length rdone + 3) |]
                  * [| V "cmdLen" = (length rdone + 3 + length (encodeAll r))%nat |]
                  * [| V "dataLen" = length all |]
                  * [| V "res" = maxInRange (V "lower") (V "upper") prefix |]
                  * [| goodSize (length rdone + 3 + length (encodeAll r) + 3) |]
                POST[R] array (rdone ++ encodeAll (MaxInRange (V "lower") (V "upper") :: r)) (V "cmd")
                  * mallocHeap * sll (responseAll all (MaxInRange (V "lower") (V "upper") :: r) out) R ]
            For "index" Holding "value" in "data" Size "dataLen"
              Where (("lower" <= Value) && (Value <= "upper") && (Value >= "res")) {
              "res" <- "value"
            };;

            "node" <-- Call "malloc"!"malloc"(0)
            [Al rdone, Al r, Al d, Al out,
              PRE[V, MR] array (rdone ++ encodeAll r) (V "cmd") * array d (V "data") * mallocHeap
                * sll out (V "output") * [| V "position" = length rdone |]
                * [| V "cmdLen" = (length rdone + length (encodeAll r))%nat |] * [| V "dataLen" = length d |]
                * [| goodSize (length rdone + length (encodeAll r) + 3) |]
                * MR =?> 2 * [| MR <> 0 |]
              POST[R] array (rdone ++ encodeAll r) (V "cmd") * array d (V "data") * mallocHeap
                * sll (responseAll d r (V "res" :: out)) R];;

            "node" *<- "res";;
            "node" + 4 *<- "output";;
            "output" <- "node"
          end;;

          (* CollectBelow *)
          Case (2 ++ "lower" ++ "upper")
            [Al rdone, Al r, Al out,
              After prefix Approaching all
                PRE[V] array (rdone ++ encodeAll (CollectBelow (V "lower") (V "upper") :: r)) (V "cmd")
                  * mallocHeap
                  * sll (collectBelow (V "upper") (skipn (wordToNat (V "lower")) prefix) out) (V "output")
                  * [| V "position" = natToW (length rdone + 3) |]
                  * [| V "cmdLen" = (length rdone + 3 + length (encodeAll r))%nat |]
                  * [| V "dataLen" = length all |]
                  * [| goodSize (length rdone + 3 + length (encodeAll r) + 3) |]
                POST[R] array (rdone ++ encodeAll (CollectBelow (V "lower") (V "upper") :: r)) (V "cmd")
                  * mallocHeap * sll (responseAll all r
                    (collectBelow (V "upper")
                      (skipn (wordToNat (V "lower")) all) out)) R ]
            For "index" Holding "value" in "data" Size "dataLen"
              Where ((Index >= "lower") && (Value <= "upper")) {
              "node" <-- Call "malloc"!"malloc"(0)
              [Al rdone, Al r, Al d, Al out,
                PRE[V, MR] array (rdone ++ encodeAll (CollectBelow (V "lower") (V "upper") :: r)) (V "cmd")
                  * array d (V "data") * mallocHeap
                  * sll (collectBelow (V "upper")
                    (skipn (wordToNat (V "lower")) (firstn (wordToNat (V "index")) d)) out) (V "output")
                  * [| V "position" = natToW (length rdone + 3) |]
                  * [| V "cmdLen" = (length rdone + 3 + length (encodeAll r))%nat |]
                  * [| V "dataLen" = length d |]
                  * [| goodSize (length rdone + 3 + length (encodeAll r) + 3) |]
                  * [| (V "lower" <= V "index")%word |] * [| (V "value" <= V "upper")%word |]
                  * [| V "value" = Array.sel d (V "index") |]
                  * [| (V "index" < natToW (length d))%word |]
                  * MR =?> 2 * [| MR <> 0 |]
                POST[R] array (rdone ++ encodeAll (CollectBelow (V "lower") (V "upper") :: r)) (V "cmd")
                  * array d (V "data") * mallocHeap * sll (responseAll d r
                    (collectBelow (V "upper") (skipn (wordToNat (V "lower")) d) out)) R ];;

              "node" *<- "value";;
              "node" + 4 *<- "output";;
              "output" <- "node"
            }
          end
        } Default {
          Fail (* Impossible: the match was exhaustive w.r.t. the spec. *)
        }
      };;

      Return "output"
    end
  }}.

Lemma length_nil : forall A,
  0 = length (@nil A).
  reflexivity.
Qed.

Hint Resolve length_nil.

Lemma responseAll_nil : forall data rs acc,
  length (encodeAll rs) = 0
  -> responseAll data rs acc = acc.
  destruct rs as [ | [ ] ]; simpl; intuition.
Qed.

Hint Extern 1 (length _ = 0) =>
  match goal with
    | [ H : _ <= _ |- _ ] => eapply wle_goodSize in H; [ omega | | ];
      eapply goodSize_weaken; eauto
  end.

Hint Rewrite responseAll_nil using solve [ auto ] : Server.

Hint Rewrite natToW_plus : Server.

Lemma triple' : forall (x : W) y,
  x ^+ natToW (S (S (S y))) = x ^+ $3 ^+ natToW y.
  intros; do 3 match goal with
                 | [ |- context[S ?X] ] => rewrite (natToW_S X)
               end; words.
Qed.

Lemma triple : forall (x : W) (ws : list W),
  x ^+ natToW (S (S (S (length ws)))) = x ^+ $3 ^+ natToW (length ws).
  intros; rewrite triple'; auto.
Qed.

Hint Rewrite triple : Server.

Lemma suffix_app' : forall (ls2 ls1 : list W),
  suffix (length ls1) (ls1 ++ ls2) = ls2.
  induction ls1; simpl; intuition.
Qed.

Lemma suffix_app : forall (ls1 ls2 : list W) (v : W),
  v = natToW (length ls1)
  -> goodSize (length ls1)
  -> suffix (wordToNat v) (ls1 ++ ls2) = ls2.
  intros; subst; rewrite wordToNat_natToW_goodSize; auto; apply suffix_app'.
Qed.

Ltac use_match := try rewrite suffix_app in * by (assumption || eapply goodSize_weaken; eauto);
  try match goal with
        | [ H : match encodeAll ?E with nil => False | _ => _ end |- _ ] =>
          destruct E as [ | [ ] ]; simpl in *; intuition (try discriminate); subst
      end; reveal_slots; evaluate hints.

Hint Rewrite app_length : Server.

Lemma valueIsGe_set : forall ls posn V lower,
  sel V "index" = length ls
  -> weqb (sel V "index") posn = true
  -> wleb lower (sel V "value") = true
  -> goodSize (length ls)
  -> $1 = valueIsGe (ls ++ sel V "value" :: nil) posn lower.
  intros; subst;
    match goal with
      | [ H : _ |- _ ] => apply wleb_true_fwd in H
    end;
    match goal with
      | [ H : _ |- _ ] => apply weqb_true_iff in H
    end;
    match goal with
      | [ H : _ = _ |- _ ] => rewrite H in *
    end; replace posn with (natToW (length ls)) by auto; unfold valueIsGe;
    autorewrite with Server; simpl; rewrite wordToNat_natToW_goodSize by auto;
      destruct (le_lt_dec (Datatypes.length ls + 1) (Datatypes.length ls)); try omega;
        rewrite sel_middle by auto; destruct (wlt_dec (sel V "value") lower); auto; nomega.
Qed.

Lemma not_done_yet : forall (pos len : W) (ws : list W) r,
  pos < len
  -> pos = natToW (length ws)
  -> len = length ws + length (encodeAll r)
  -> r <> nil.
  destruct r; intuition (try discriminate); subst; simpl in *;
    rewrite plus_0_r in *; nomega.
Qed.

Ltac finish := fold (@skipn W); fold (@firstn W); subst; eauto;
  try match goal with
        | [ _ : context[?a ++ ?b :: ?c :: ?d :: _] |- sel _ "position" = natToW (length _) ] =>
          instantiate (1 := a ++ b :: c :: d :: nil)
      end;
  repeat match goal with
           | [ H : sel _ _ = _ |- _ ] => rewrite H in *
           | [ H : Regs _ _ = sel _ _ |- _ ] => rewrite H in *
         end; try rewrite wordToNat_natToW_goodSize by (eapply goodSize_weaken; eauto);
  eauto; autorewrite with StreamParse Server; simpl; autorewrite with StreamParse Server; eauto; simpl;
    try solve [ auto
      | eapply goodSize_weaken; eauto
      | step hints
      | match goal with
          | [ _ : ~match encodeAll ?r with nil => _ | _ => _ end |- _ ] =>
            match goal with
              | [ _ : match encodeAll _ with nil => False | _ => _ end |- _ ] => fail 1
              | _ => assert (r <> nil) by (eapply not_done_yet; eauto);
                destruct r as [ | [ ] ]; simpl in *; tauto
            end
        end ].

Hint Extern 1 (natToW 1 = valueIsGe _ _ _) =>
  eapply valueIsGe_set; [ eassumption | eassumption | eassumption
    | match goal with
        | [ _ : context[?a ++ sel ?V "value" :: ?b] |- _ ] =>
          apply goodSize_weaken with (length (a ++ sel V "value" :: b)); [
            eapply containsArray_goodSize; eauto 10
            | finish ]
      end ].

Lemma join3 : forall A x y z ls' (ls : list A),
  ((ls ++ x :: y :: z :: nil) ++ ls') = ls ++ x :: y :: z :: ls'.
  induction ls; simpl; intuition.
Qed.

Hint Rewrite join3 : Server.

Lemma switch_sides : forall w n,
  wordToNat w = n
  -> natToW n = w.
  intros; subst; apply natToWord_wordToNat.
Qed.

Hint Immediate switch_sides.

Hint Extern 1 (weqb _ _ = true) => apply weqb_true_iff.
Hint Immediate wleb_true.

Lemma selN_beginning : forall (w : W) (ws' : list W) (ws : list W) i,
  (i < length ws)%nat
  -> Array.selN (ws ++ w :: ws') i = Array.selN ws i.
  induction ws; destruct i; simpl; intuition.
Qed.

Lemma sel_beginning : forall (ws : list W) (w : W) (ws' : list W) i,
  goodSize (length ws)
  -> i < natToW (length ws)
  -> Array.sel (ws ++ w :: ws') i = Array.sel ws i.
  unfold Array.sel; intros; apply selN_beginning; nomega.
Qed.

Lemma valueIsGe_skip : forall ws this posn lower,
  goodSize (length ws)
  -> (weqb (length ws) posn = true -> wleb lower this = true -> False)
  -> valueIsGe ws posn lower = valueIsGe (ws ++ this :: nil) posn lower.
  unfold valueIsGe; intros; autorewrite with Server; simpl.
  destruct (le_lt_dec (length ws) (wordToNat posn));
    destruct (le_lt_dec (length ws + 1) (wordToNat posn)); auto; try omega; [
      assert (wordToNat posn = length ws) by omega;
        replace posn with (natToW (length ws)) by auto;
          rewrite sel_middle by auto;
            destruct (wlt_dec this lower); eauto; elimtype False; eauto
      | destruct (eq_nat_dec (wordToNat posn) (length ws)); [
        replace posn with (natToW (length ws)) by auto;
          rewrite sel_middle by auto; nomega
        | rewrite sel_beginning; auto; nomega ] ].
Qed.

Hint Resolve valueIsGe_skip.

Hint Extern 1 (@eq W _ _) =>
  match goal with
    | [ |- ?G ] => has_evar G; fail 1
    | _ => words
  end.

Fixpoint maxInRange' (lower upper : W) (data : list W) (acc : W) : W :=
  match data with
    | nil => acc
    | w :: ws =>
      maxInRange' lower upper ws (if wlt_dec w lower
        then acc
        else if wlt_dec upper w
          then acc
          else wmax w acc)
  end.

Ltac ifs := repeat match goal with
                     | [ |- context[if ?E then _ else _] ] => destruct E; auto
                     | [ _ : context[if ?E then _ else _] |- _ ] => destruct E; auto
                   end.

Hint Rewrite roundTrip_0 : N.

Lemma wordToNat_inj : forall sz (w w' : word sz),
  wordToNat w = wordToNat w'
  -> w = w'.
  intros ? ? ? H; apply (f_equal (natToWord sz)) in H;
    repeat rewrite natToWord_wordToNat in *; auto.
Qed.

Lemma maxInRange'_alt : forall lower upper data acc,
  maxInRange' lower upper data acc
  = wmax (maxInRange lower upper data) acc.
  induction data; simpl; unfold wmax in *; intuition; [
    ifs; nomega
    | rewrite IHdata; clear IHdata; ifs; (try nomega; apply wordToNat_inj; nomega) ].
Qed.

Lemma maxInRange_alt : forall lower upper data,
  maxInRange lower upper data = maxInRange' lower upper data 0.
  intros; rewrite maxInRange'_alt; unfold wmax; ifs; apply wordToNat_inj; nomega.
Qed.

Lemma wle_lt : forall u v : W,
  u < v
  -> u <= v.
  intros; nomega.
Qed.

Hint Immediate wle_lt.

Lemma maxInRange'_skip : forall lower upper w ws acc,
  (wleb lower w = true
    -> wleb w upper = true
    -> wleb (maxInRange' lower upper ws acc) w = true
    -> False)
  -> maxInRange' lower upper ws acc = maxInRange' lower upper (ws ++ w :: nil) acc.
  induction ws; simpl; unfold wmax; intros; ifs; elimtype False; eauto using wleb_true.
Qed.

Lemma maxInRange_skip : forall lower upper w ws,
  (wleb lower w = true
    -> wleb w upper = true
    -> wleb (maxInRange lower upper ws) w = true
    -> False)
  -> maxInRange lower upper ws = maxInRange lower upper (ws ++ w :: nil).
  intros; repeat rewrite maxInRange_alt in *; apply maxInRange'_skip; auto.
Qed.

Hint Immediate maxInRange_skip.

Lemma maxInRange'_set : forall lower upper w ws acc,
  wleb lower w = true
  -> wleb w upper = true
  -> wleb (maxInRange' lower upper ws acc) w = true
  -> w = maxInRange' lower upper (ws ++ w :: nil) acc.
  induction ws; simpl; unfold wmax; intuition;
    ifs; repeat match goal with
                  | [ H : wleb _ _ = true |- _ ] => apply wleb_true_fwd in H
                end; try nomega; apply wordToNat_inj; nomega.
Qed.

Lemma maxInRange_set : forall lower upper w ws,
  wleb lower w = true
  -> wleb w upper = true
  -> wleb (maxInRange lower upper ws) w = true
  -> w = maxInRange lower upper (ws ++ w :: nil).
  intros; repeat rewrite maxInRange_alt in *; apply maxInRange'_set; auto.
Qed.

Hint Immediate maxInRange_set.

Lemma skipn_nil : forall A n,
  skipn n (@nil A) = nil.
  destruct n; reflexivity.
Qed.

Hint Rewrite skipn_nil : Server.

Lemma eq0_le : forall w : W,
  wordToNat w = 0
  -> w <= natToW 0.
  intros ? H; apply (f_equal natToW) in H;
    unfold natToW in H; rewrite natToWord_wordToNat in H; subst; nomega.
Qed.

Hint Immediate eq0_le.

Lemma le_any : forall (w : W) b,
  wordToNat w = 0
  -> w <= b.
  intros; pre_nomega; rewrite H; omega.
Qed.

Hint Immediate le_any.

Lemma wleb_false_fwd : forall u v,
  wleb u v = false
  -> v < u.
  unfold wleb; intros; ifs; try discriminate;
    assert (wordToNat u <> wordToNat v) by (intro; apply wordToNat_inj in H0; tauto); nomega.
Qed.

Hint Immediate wleb_false_fwd.

Lemma collectBelow_skip1 : forall upper this ws lower base,
  wleb this upper = false
  -> collectBelow upper (skipn lower (ws ++ this :: nil)) base
  = collectBelow upper (skipn lower ws) base.
  induction ws; destruct lower; simpl; intuition idtac; autorewrite with Server; auto;
    solve [ ifs; elimtype False; eauto
      | specialize (IHws 0); simpl in *; ifs ].
Qed.

Lemma skipn_all : forall A n (ls1 : list A),
  (length ls1 <= n)%nat
  -> skipn n ls1 = nil.
  induction n; destruct ls1; simpl; intuition.
Qed.

Lemma collectBelow_skip2 : forall upper this ws (lower : W) base,
  wleb (wordToNat lower) (length ws) = false
  -> goodSize (S (length ws))
  -> collectBelow upper (skipn (wordToNat lower) (ws ++ this :: nil)) base
  = collectBelow upper (skipn (wordToNat lower) ws) base.
  intros; repeat (rewrite skipn_all; simpl; auto);
    match goal with
      | [ H : _ |- _ ] => apply wleb_false_fwd in H
    end;
    match goal with
      | [ H : _ |- _ ] => apply lt_goodSize' in H; autorewrite with Server; simpl; auto
    end.
Qed.

Lemma collectBelow_skip : forall upper (lower : W) this base ws,
  (wleb lower (length ws) = true
    -> wleb this upper = true
    -> False)
  -> goodSize (S (length ws))
  -> collectBelow upper (skipn (wordToNat lower) (ws ++ this :: nil)) base
  = collectBelow upper (skipn (wordToNat lower) ws) base.
  intros; case_eq (wleb this upper); intros; try solve [ apply collectBelow_skip1; auto ];
    intros; case_eq (wleb lower (length ws)); intros; [
      elimtype False; eauto
      | apply collectBelow_skip2; auto; unfold natToW; rewrite natToWord_wordToNat; auto ].
Qed.

Hint Rewrite collectBelow_skip using assumption : Server.

Lemma skipn_app2 : forall A (ls2 : list A) n ls1,
  (n <= length ls1)%nat
  -> skipn n (ls1 ++ ls2) = skipn n ls1 ++ ls2.
  induction n; destruct ls1; simpl; intuition.
Qed.

Lemma collectBelow_set' : forall upper ws this acc,
  this <= upper
  -> collectBelow upper (ws ++ this :: nil) acc
  = this :: collectBelow upper ws acc.
  induction ws; simpl; intros; ifs; nomega.
Qed.

Lemma collectBelow_set : forall upper (lower : W) ws this acc,
  (wordToNat lower <= length ws)%nat
  -> this <= upper
  -> collectBelow upper (skipn (wordToNat lower) (ws ++ this :: nil)) acc
  = this :: collectBelow upper (skipn (wordToNat lower) ws) acc.
  intros; rewrite skipn_app2 by auto; apply collectBelow_set'; auto.
Qed.

Hint Extern 1 (collectBelow _ _ _ = _ :: _) => apply collectBelow_set; autorewrite with Server.

Lemma length_firstn_below : forall index (ls : list W),
  index < natToW (length ls)
  -> goodSize (length ls)
  -> length (firstn (wordToNat index) ls) = wordToNat index.
  intros; rewrite firstn_length; apply min_l; nomega.
Qed.

Lemma natToW_wordToNat : forall w : W,
  natToW (wordToNat w) = w.
  unfold natToW; intros; apply natToWord_wordToNat.
Qed.

Hint Rewrite natToW_wordToNat : Server.

Hint Rewrite length_firstn_below using (auto; eapply containsArray_goodSize; eauto 10) : Server.

Lemma le_wordToNat : forall u v : W,
  u <= v
  -> (wordToNat u <= wordToNat v)%nat.
  intros; nomega.
Qed.

Hint Immediate le_wordToNat.

Lemma lt_wordToNat : forall (u: W) v,
  u < natToW v
  -> goodSize v
  -> (wordToNat u < v)%nat.
  intros; nomega.
Qed.

Hint Extern 1 (wordToNat _ < _)%nat => apply lt_wordToNat;
  solve [ auto; eapply containsArray_goodSize; eauto 10 ].

Hint Extern 1 (_ = _ ++ _ :: _) => apply breakout.

Hint Immediate wleb_true_fwd.
Hint Rewrite sel_middle
  using solve [ auto; eapply goodSize_middle; eapply containsArray_goodSize; eauto 10 ] : Server.

Lemma wlt_S : forall (ls1 : list W) v ls2,
  goodSize (length (ls1 ++ v :: ls2))
  -> natToW (length ls1) < natToW (length ls1) ^+ natToW (S (length ls2)).
  intros; autorewrite with Server in *; rewrite <- natToW_plus; apply lt_goodSize; eauto.
Qed.

Hint Extern 1 (_ < _ ^+ _) => eapply wlt_S; eapply containsArray_goodSize; eauto 10.

Hint Rewrite wordToNat_natToW_goodSize
  using (eapply goodSize_middle; eapply containsArray_goodSize; eauto 10) : Server.

Lemma firstn_app1 : forall A (ls1 ls2 : list A),
  firstn (length ls1) (ls1 ++ ls2) = ls1.
  induction ls1; simpl; intuition.
Qed.

Hint Rewrite firstn_app1 : Server.

Lemma wle_refl : forall w : W, w <= w.
  intros; nomega.
Qed.

Hint Resolve wle_refl.

Theorem ok : moduleOk m.
Proof.
  vcgen; abstract (parse0; for0; post; evaluate hints; repeat (parse1 finish; use_match);
    multi_ex; sep hints; finish).
Qed.


(* Picinae: Platform In Coq for INstruction Analysis of Executables       ZZM7DZ
                                                                          $MNDM7
   Copyright (c) 2022 Kevin W. Hamlen            ,,A??=P                 OMMNMZ+
   The University of Texas at Dallas         =:$ZZ$+ZZI                  7MMZMZ7
   Computer Science Department             Z$$ZM++O++                    7MMZZN+
                                          ZZ$7Z.ZM~?                     7MZDNO$
                                        ?Z8ZO7.OM=+?                     $OMO+Z+
   Any use, commercial or otherwise       ?D=++M++ZMMNDNDZZ$$Z?           MM,IZ=
   requires the express permission of        MZZZZZZ+...=.8NOZ8NZ$7       MM+$7M
   the author.                                 ?NNMMM+.IZDMMMMZMD8O77     O7+MZ+
                                                     MMM8MMMMMMMMMMM77   +MMMMZZ
                                                     MMMMMMMMMMMZMDMD77$.ZMZMM78
                                                      MMMMMMMMMMMMMMMMMMMZOMMM+Z
   Implementation of separation logic.                 MMMMMMMMMMMMMMMMM^NZMMN+Z
                                                        MMMMMMMMMMMMMMM/.$MZM8O+
   To compile this module, first load and compile:       MMMMMMMMMMMMMM7..$MNDM+
   * Picinae_core                                         MMDMMMMMMMMMZ7..$DM$77
   * Picinae_theory                                        MMMMMMM+MMMZ7..7ZM~++
   Then compile this module with menu option                MMMMMMMMMMM7..ZNOOMZ
   Compile->Compile_buffer.                                  MMMMMMMMMM$.$MOMO=7
                                                              MDMMMMMMMO.7MDM7M+
                                                               ZMMMMMMMM.$MM8$MN
                                                               $ZMMMMMMZ..MMMOMZ
                                                                ?MMMMMM7..MNN7$M
                                                                 ?MMMMMZ..MZM$ZZ
                                                                  ?$MMMZ7.ZZM7DZ
                                                                    7MMM$.7MDOD7
                                                                     7MMM.7M77ZZ
                                                                      $MM78ZDZ7Z
                                                                        MM8D$7Z7
                                                                        MM7O$$+Z
                                                                         M 7N8ZD
 *)

Require Import Picinae_core.
Require Import Picinae_theory.
Require Import Program.Equality.
Require Import FunctionalExtensionality.
Require Import NArith.

(* This module implements separation logic for local reasoning about memory in
   Picinae.  Rather than define a separation operators as an Inductive datatype
   with associated inference rules (which would confine proof authors to using
   only those rules for local reasoning), we instead derive the soundness of
   separation logic's Frame Rule directly in Coq.  This allows proof authors to
   use Coq's entire proof logic for local reasoning by simply applying the
   Frame Rule as a theorem when desired. *)

(* Heaps are partial functions from addr to N.  The IL interpreter expresses
   memories m as total functions, so to make them act like heaps, we separately
   encode the heap's domain (h:hdomain), which we here express as a partial
   function from addr to unit.  For any addr 'a', if (h a = None) then address
   'a' is outside the heap; otherwise (h a = Some tt) and (m a) is its value.
   (This is more convenient than representing h as a total function from addr
   to bool, since it allows functions and theorems concerning partial functions
   to be applied to heaps and their domains.) *)
Definition hdom {A} (h: heap A) a := match h a with None => None | Some _ => Some tt end.
Definition hopp {A} (h: heap A) a := match h a with None => Some tt | Some _ => None end.

(* the restriction of heap h2 to the domain of h1: *)
Definition resth {A B} (h1: heap A) (h2: heap B) a :=
  match h1 a with None => None | Some _ => h2 a end.

(* disjointedness of heaps *)
Definition hdisj {A B} (h1: heap A) (h2: heap B) := forall a, h1 a = None \/ h2 a = None.

(* A "heapy value" is like a regular value, except that if it is a memory (VaM),
   then it holds a partial function instead of a total function. *)
Inductive hval := HVN (n:N) (w:bitwidth) | HVM (m: addr -> option N) (w:bitwidth).
Definition to_heap (m: addr -> N) a := Some (m a).
Definition to_hval (u:value) :=
  match u with VaN n w => HVN n w | VaM m w => HVM (to_heap m) w end.

Definition hstore (V:Type) := V -> hval.
Definition to_hstore {V} s (v:V) := to_hval (s v).

(* restriction of heapy values and heapy stores to a given domain: *)
Definition resthv {A} (h:heap A) (hu:hval) :=
  match hu with HVN n w => HVN n w | HVM h' w => HVM (resth h h') w end.
Definition resths {V A} (h:heap A) (hs:hstore V) v := resthv h (hs v).

(* Propositional operators from separation logic are here defined as Coq Props: *)

Definition hsprop (V:Type) := hstore V -> Prop.

(* Separating conjunction (sepconj _ P Q) is satisfied by heaps that can be
   partitioned into disjoint heaplets that satisfy P and Q respectively. *)
Definition sepconj V P Q : hsprop V :=
  fun hs => exists (h:hdomain), P (resths h hs) /\ Q (resths (hopp h) hs).

(* Separation logic for Picinae is complicated by the fact that Picinae stores
   can have many heaps (or none), not just one.  We therefore define heap
   propositions as properties satisfied by ALL heaps in the store. *)
Definition hprop V (P: heap N -> Prop): hsprop V :=
  fun hs => forall v m w (SV: hs v = HVM m w), P m.

Definition hfalse {A:Type} (_:A) := False.

Definition htrue {A:Type} (_:A) := True.

(* (pointsto a Q) is satisfied by heaps containing exactly one address a,
   which contains something satisfying Q. *)
Definition pointsto a Q (h: heap N) :=
  forall a0, match h a0 with None => a0<>a | Some n => a0=a /\ Q n end.

(* emp is satisfied by exactly and only the empty heap. *)
Definition emp (h: heap N) := forall a, h a = None.

(* Separating implication (sepimp P Q) is satisfied by heaps that, when joined
   with any disjoint, P-satisfying heap, become a heap that satisfies Q. *)
Definition sepimp (P Q: heap N -> Prop) (h: heap N) :=
  forall h' (DJ: hdisj h h'), P h' -> Q (updateall h h').

(* update-preserving heapy-store-properties are preserved by updating var v to
   heapy value hu. *)
Definition upd_pres {V} {_:EqDec V} (R: hsprop V) hs hu v :=
  R hs -> R (update hs v hu).

(* Helper lemmas concerning heaps and heap domains: *)

Lemma resth_hdom:
  forall {A B} (h1:heap A) (h2:heap B), resth (hdom h1) h2 = resth h1 h2.
Proof.
  intros. extensionality a. unfold hdom,resth. destruct (h1 a); reflexivity.
Qed.

Lemma hopp_hdom:
  forall {A} (h:heap A), hopp (hdom h) = hopp h.
Proof.
  intros. extensionality a. unfold hopp,hdom. destruct (h a); reflexivity.
Qed.

Lemma sub_htotal: forall h, h ⊆ htotal.
Proof. unfold pfsub. intros. destruct y. reflexivity. Qed.

Lemma hopp_mono:
  forall {A} (h1 h2: heap A) (SS: h1 ⊆ h2), hopp h2 ⊆ hopp h1.
Proof.
  unfold pfsub, hopp. intros. destruct y. specialize (SS x). destruct (h1 x).
    rewrite <- H, (SS a); reflexivity.
    reflexivity.
Qed.

Lemma updateall_comm:
  forall (h1 h2:hdomain), updateall h1 h2 = updateall h2 h1.
Proof.
  unfold updateall. intros. extensionality a.
  destruct (h1 a), (h2 a); try destruct u; try destruct u0; reflexivity.
Qed.

Lemma resth_subset:
  forall {A B} (h1: heap A) (h2: heap B), resth h1 h2 ⊆ h2.
Proof.
  unfold pfsub, resth. intros. destruct (h1 x). assumption. discriminate.
Qed.

Lemma resth_mono_l:
  forall {A B} (h1 h2: heap A) (h: heap B) (SS: h1 ⊆ h2), resth h1 h ⊆ resth h2 h.
Proof.
  unfold pfsub,resth. intros. specialize (SS x). destruct (h1 x).
    rewrite (SS a). assumption. reflexivity.
    discriminate.
Qed.

Lemma hopp_resth:
  forall {A B} (h1: heap A) (h2: heap B), hopp (resth h1 h2) = updateall (hopp h1) (hopp h2).
Proof.
  intros. extensionality a. unfold resth,hopp,updateall.
  destruct (h1 a), (h2 a); reflexivity.
Qed.

Lemma hopp_inv:
  forall h, hopp (hopp h) = h.
Proof.
  intro. extensionality a. unfold hopp. destruct (h a); try destruct u; reflexivity.
Qed.

Lemma resth_ident:
  forall (h1 h2:hdomain) (SS: h1 ⊆ h2), resth h1 h2 = h1.
Proof.
  unfold resth,pfsub. intros. extensionality a. specialize (SS a).
  destruct (h1 a), (h2 a); try destruct u; try destruct u0; try reflexivity.
  apply SS. reflexivity.
Qed.

Lemma resth_comm:
  forall (h1 h2: hdomain), resth h1 h2 = resth h2 h1.
Proof.
  intros. extensionality a. unfold resth.
  destruct (h1 a), (h2 a); try destruct u; try destruct u0; reflexivity.
Qed.

Lemma resthv_hdom:
  forall {A} (h:heap A) hv, resthv (hdom h) hv = resthv h hv.
Proof.
  intros. destruct hv. reflexivity. simpl. rewrite resth_hdom. reflexivity.
Qed.

Lemma resth_assoc:
  forall {A B C} (h1: heap A) (h2: heap B) (h3: heap C),
  resth h1 (resth h2 h3) = resth (resth h1 h2) h3.
Proof.
  intros. extensionality a. unfold resth.
  destruct (h1 a),(h2 a); reflexivity.
Qed.

Lemma resthv_assoc:
  forall {A B} (h1: heap A) (h2: heap B) hv, resthv h1 (resthv h2 hv) = resthv (resth h1 h2) hv.
Proof.
  intros. destruct hv. reflexivity. unfold resthv. rewrite resth_assoc. reflexivity.
Qed.

Lemma hdisj_mono:
  forall {A B} (h1 h2: heap A) (h3: heap B) (SS: h1 ⊆ h2) (DJ: hdisj h2 h3),
  hdisj h1 h3.
Proof.
  unfold hdisj. intros. specialize (SS a). destruct (h1 a).
    right. destruct (DJ a).
      rewrite (SS a0) in H. discriminate. reflexivity.
      assumption.
    left. reflexivity.
Qed.

Lemma resths_hdom:
  forall {V A} (h:heap A) (hs:hstore V), resths (hdom h) hs = resths h hs.
Proof.
  intros. extensionality a. unfold resths. rewrite resthv_hdom. reflexivity.
Qed.

Lemma resths_assoc:
  forall {V A B} (h1: heap A) (h2: heap B) (hs:hstore V),
  resths h1 (resths h2 hs) = resths (resth h1 h2) hs.
Proof.
  intros. extensionality v. unfold resths. rewrite resthv_assoc. reflexivity.
Qed.

Lemma to_hstore_update {V} {ED:EqDec V}:
  forall s (v:V) u, to_hstore (s[v:=u]) = (to_hstore s)[v := to_hval u].
Proof.
  intros. extensionality v0. unfold to_hstore,update. destruct (v0 == v); reflexivity.
Qed.

Lemma resths_update {V} {ED:EqDec V}:
  forall {A} (h:heap A) hs (v:V) hu, resths h (hs[v:=hu]) = (resths h hs)[v := resthv h hu].
Proof.
  intros. extensionality v0. unfold resths,update. destruct (v0 == v); reflexivity.
Qed.

Module Type PICINAE_SLOGIC_DEFS (IL: PICINAE_IL).

Import IL.

Definition sep := sepconj var.

(* In separation logic, Hoare triple {P}q{Q} asserts that executing q on any
   heap h that satisfyies P does not "go wrong" and yields a heap satisfying Q.
   "Going wrong" in this context means accessing memory outside of h's domain.
   (It does not mean type-mismatch, which is handled by the static semantics.)
   We therefore here define "go wrong" as "contracting the heap-domain of q
   that otherwise stays right does not cause q to go wrong". *)

Definition htrip_stmt P q Q :=
  forall s h s' x (PRE: P (resths h (to_hstore s))) (XS: exec_stmt htotal s q s' x),
    exec_stmt h s q s' x /\ Q (resths h (to_hstore s')).

Definition htrip_prog P p a n Q :=
  forall s h s' x (PRE: P (resths h (to_hstore s))) (XP: exec_prog htotal p a s n s' x),
    exec_prog h p a s n s' x /\ Q (resths h (to_hstore s')).

(* The key idea behind the following proofs is that executing any expression or
   statement with a restricted heap domain always yields a value or store in
   which nothing outside that domain has changed.  Output values therefore obey
   the following modeling relation: *)
Inductive hmodels (s:store) (h:hdomain) : value -> Prop :=
| HMN n w: hmodels s h (VaN n w)
| HMM m w v m' (SV: s v = VaM m' w) (FR: forall a, h a = None -> m a = m' a):
    hmodels s h (VaM m w).

Definition hmodels_store (h:hdomain) (s s':store) :=
  forall v, hmodels s h (s' v).

(* Our goal is to prove the soundness of the frame rule: {P}q{Q} -> {P*R}q{Q*R}.
   But only certain properties R satisfy this rule.  In particular, R must not
   depend upon variables and memory addresses assigned by q.  We define this
   "framing" meta-property below. *)

(* R "frames" q if for all variables v assigned by q, updating v to any value u
   that satisfies the modeling relation preserves R. *)

Definition frames_stmt (R: hsprop var) q :=
  forall s (h:hdomain) u (HM: hmodels s (hopp h) u),
  allassigns (upd_pres R (resths h (to_hstore s)) (resthv h (to_hval u))) q.

Definition frames_prog (R: hsprop var) (p:program) :=
  forall s a, match p s a with None => True | Some (_,q) => frames_stmt R q end.

(* Duals to the above:  We need duals to each of the above because if R contains
   a negation or implication, the framing requirement gets reversed for the
   negated sub-proposition or antecedent. *)

(* R "universally-frames" q if forall all variables v assigned by q, updating v
   to any value at all preserves R. *)

Definition frames'_stmt (R: hsprop var) q :=
  forall s (h:hdomain) u,
  allassigns (upd_pres R (resths h (to_hstore s)) (resthv h (to_hval u))) q.

Definition frames'_prog (R: hsprop var) (p:program) :=
  forall s a, match p s a with None => True | Some (_,q) => frames'_stmt R q end.

End PICINAE_SLOGIC_DEFS.

Module Type PICINAE_SLOGIC (IL: PICINAE_IL).

Import IL.
Include PICINAE_SLOGIC_DEFS IL.

(* Helper lemmas for breaking "frames" hypotheses down into their premises: *)

Parameter destruct_frames_stmt:
  forall R q (FR: frames_stmt R q),
  match q with
  | Nop | Jmp _ | Exn _ => True
  | Move v _ => forall s (h:hdomain) hu (HM: hmodels s (hopp h) hu), upd_pres R (resths h (to_hstore s)) (resthv h (to_hval hu)) v
  | Seq q1 q2 => frames_stmt R q1 /\ frames_stmt R q2
  | Rep _ q1 => frames_stmt R q1
  | If _ q1 q2 => frames_stmt R q1 /\ frames_stmt R q2
  end.

Parameter destruct_frames'_stmt:
  forall R q (FR: frames'_stmt R q),
  match q with
  | Nop | Jmp _ | Exn _ => True
  | Move v _ => forall s (h:hdomain) hu, upd_pres R (resths h (to_hstore s)) (resthv h (to_hval hu)) v
  | Seq q1 q2 => frames'_stmt R q1 /\ frames'_stmt R q2
  | Rep _ q1 => frames'_stmt R q1
  | If _ q1 q2 => frames'_stmt R q1 /\ frames'_stmt R q2
  end.

(* The IL semantics obey the modeling relation: *)

Parameter hmodels_refl:
  forall h s, hmodels_store h s s.

Parameter hmodels_trans:
  forall h s1 s2 s3, hmodels_store h s1 s2 -> hmodels_store h s2 s3 ->
  hmodels_store h s1 s3.

Parameter hmodels_mono:
  forall s h1 h2 u (SS: h1 ⊆ h2) (HM: hmodels s h1 u), hmodels s h2 u.

Parameter hmodels_exp:
  forall h s e u (E: eval_exp h s e u),
  hmodels s h u.

Parameter hmodels_stmt:
  forall h s q s' x (XS: exec_stmt h s q s' x),
  hmodels_store h s s'.

Parameter hmodels_prog:
  forall h p a s n s' x (XP: exec_prog h p a s n s' x),
  hmodels_store h s s'.

(* If R frames q, then executing q preserves R. *)

Parameter frames_rep:
  forall R e q (FR: frames_stmt R q), frames_stmt R (Seq q (Rep e q)).

Parameter framed_stmt:
  forall {A} (R: hsprop var) (h:heap A) s q s' x (FR: frames_stmt R q)
         (XS: exec_stmt (hopp h) s q s' x)
         (HS: hmodels_store (hopp h) s s') (PRE: R (resths h (to_hstore s))),
  R (resths h (to_hstore s')).

Parameter framed_prog:
  forall {A} (R: hsprop var) (h:heap A) p a s n s' x (FR: frames_prog R p)
         (XP: exec_prog (hopp h) p a s n s' x)
         (HS: hmodels_store (hopp h) s s') (PRE: R (resths h (to_hstore s))),
  R (resths h (to_hstore s')).

(* Main result: The frame rule of separation logic is sound.  In particular,
   if {P}q{Q} holds, and if R frames q, then {P*R}q{Q*R} holds. *)

Parameter stmt_frame:
  forall q (P Q R: hsprop var) (FR: frames_stmt R q)
         (HT: htrip_stmt P q Q),
  htrip_stmt (sep P R) q (sep Q R).

Parameter prog_frame:
  forall p a n (P Q R: hsprop var) (FR: frames_prog R p)
         (HT: htrip_prog P p a n Q),
  htrip_prog (sep P R) p a n (sep Q R).

(* At this point we have our main result, but it requires users to prove that
   R frames q in order to use it.  We here prove some general sufficiency
   conditions to help users prove this meta-property. *)

Parameter upd_pres_sep:
  forall P Q hs hu v
         (UP1: forall (h:hdomain), upd_pres P (resths h hs) (resthv h hu) v)
         (UP2: forall (h:hdomain), upd_pres Q (resths h hs) (resthv h hu) v),
  upd_pres (sep P Q) hs hu v.

(* P*Q (universally-)frames q if P and Q both (universally-)frame q. *)
Parameter frames_stmt_sep:
  forall P Q q (FR1: frames_stmt P q) (FR2: frames_stmt Q q),
  frames_stmt (sep P Q) q.

Parameter frames'_stmt_sep:
  forall P Q q (FR1: frames'_stmt P q) (FR2: frames'_stmt Q q),
  frames'_stmt (sep P Q) q.

Parameter frames_prog_sep:
  forall P Q p (FR1: frames_prog P p) (FR2: frames_prog Q p),
  frames_prog (sep P Q) p.

Parameter frames'_prog_sep:
  forall P Q p (FR1: frames'_prog P p) (FR2: frames'_prog Q p),
  frames'_prog (sep P Q) p.

(* htrue and hfalse (universally-)frame everything. *)
Parameter frames_stmt_htrue: forall q, frames_stmt htrue q.
Parameter frames'_stmt_htrue: forall q, frames'_stmt htrue q.
Parameter frames_prog_htrue: forall p, frames_prog htrue p.
Parameter frames'_prog_htrue: forall p, frames'_prog htrue p.
Parameter frames_stmt_hfalse: forall q, frames_stmt hfalse q.
Parameter frames'_stmt_hfalse: forall q, frames'_stmt hfalse q.
Parameter frames_prog_hfalse: forall p, frames_prog hfalse p.
Parameter frames'_prog_hfalse: forall p, frames'_prog hfalse p.

(* To prove that R (universally-)frames q, it sufficies to prove that R is
   update-preserving for all possible stores. *)
Parameter frames_stmt_anystore:
  forall R q, (forall s (h:hdomain) u v (HM: hmodels s (hopp h) u), upd_pres R (resths h (to_hstore s)) (resthv h (to_hval u)) v) ->
  frames_stmt R q.

Parameter frames'_stmt_anystore:
  forall R q, (forall s (h:hdomain) u v, upd_pres R (resths h (to_hstore s)) (resthv h (to_hval u)) v) ->
  frames'_stmt R q.

(* It follows that all heap-properties frame everything. *)
Parameter frames_stmt_hprop: forall R q, frames_stmt (hprop var R) q.
Parameter frames_prog_hprop: forall R p, frames_prog (hprop var R) p.

(* (P -> Q) frames q if P universally-frames q and Q frames q. *)
Parameter frames_stmt_impl:
  forall P Q q (FR1: frames'_stmt P q) (FR2: frames_stmt Q q),
  frames_stmt (fun hs => P hs -> Q hs) q.

Parameter frames'_stmt_impl:
  forall P Q q (FR1: frames'_stmt P q) (FR2: frames'_stmt Q q),
  frames'_stmt (fun hs => P hs -> Q hs) q.

Parameter frames_prog_impl:
  forall P Q p (FR1: frames'_prog P p) (FR2: frames_prog Q p),
  frames_prog (fun hs => P hs -> Q hs) p.

Parameter frames'_prog_impl:
  forall P Q p (FR1: frames'_prog P p) (FR2: frames'_prog Q p),
  frames'_prog (fun hs => P hs -> Q hs) p.

(* ~P frames and universally-frames q if P universally-frames q. *)
Parameter frames_stmt_not:
  forall P q (FR: frames'_stmt P q),
  frames_stmt (fun hs => ~ P hs) q.

Parameter frames'_stmt_not:
  forall P q (FR: frames'_stmt P q),
  frames'_stmt (fun hs => ~ P hs) q.

Parameter frames_prog_not:
  forall P p (FR: frames'_prog P p),
  frames_prog (fun hs => ~ P hs) p.

Parameter frames_prog'_not:
  forall P p (FR: frames'_prog P p),
  frames'_prog (fun hs => ~ P hs) p.

End PICINAE_SLOGIC.

Module PicinaeSLogic (IL: PICINAE_IL) : PICINAE_SLOGIC IL.

Import IL.
Include PICINAE_SLOGIC_DEFS IL.
Module PTheory := PicinaeTheory IL.
Import PTheory.

Lemma destruct_frames_stmt:
  forall R q (FR: frames_stmt R q),
  match q with
  | Nop | Jmp _ | Exn _ => True
  | Move v _ => forall s (h:hdomain) hu (HM: hmodels s (hopp h) hu), upd_pres R (resths h (to_hstore s)) (resthv h (to_hval hu)) v
  | Seq q1 q2 => frames_stmt R q1 /\ frames_stmt R q2
  | Rep _ q1 => frames_stmt R q1
  | If _ q1 q2 => frames_stmt R q1 /\ frames_stmt R q2
  end.
Proof.
  intros. destruct q; solve
  [ exact I
  | try split; intros s dom u HM; specialize (FR s dom u HM); inversion FR; assumption ].
Qed.

Lemma destruct_frames'_stmt:
  forall R q (FR: frames'_stmt R q),
  match q with
  | Nop | Jmp _ | Exn _ => True
  | Move v _ => forall s (h:hdomain) hu, upd_pres R (resths h (to_hstore s)) (resthv h (to_hval hu)) v
  | Seq q1 q2 => frames'_stmt R q1 /\ frames'_stmt R q2
  | Rep _ q1 => frames'_stmt R q1
  | If _ q1 q2 => frames'_stmt R q1 /\ frames'_stmt R q2
  end.
Proof.
  intros. destruct q; solve
  [ exact I
  | try split; intros s dom u; specialize (FR s dom u); inversion FR; assumption ].
Qed.

Lemma hmodels_refl:
  forall h s, hmodels_store h s s.
Proof.
  intros h s v. destruct (s v) eqn:SV.
    apply HMN.
    eapply HMM. exact SV. reflexivity.
Qed.

Lemma hmodels_trans:
  forall h s1 s2 s3, hmodels_store h s1 s2 -> hmodels_store h s2 s3 ->
  hmodels_store h s1 s3.
Proof.
  intros h s1 s2 s3 H1 H2 v.
  specialize (H2 v). inversion H2.
    apply HMN.
    specialize (H1 v0). inversion H1.
      rewrite SV in H3. discriminate.
      rewrite SV in H3. inversion H3. subst. eapply HMM. eassumption.
        intros. rewrite (FR a H). apply FR0. assumption.
Qed.

Lemma hmodels_mono:
  forall s h1 h2 u (SS: h1 ⊆ h2) (HM: hmodels s h1 u), hmodels s h2 u.
Proof.
  intros. inversion HM; subst.
    apply HMN.
    eapply HMM. exact SV. intros. apply FR. specialize (SS a tt). destruct (h1 a).
      destruct u. rewrite SS in H. discriminate. reflexivity.
      reflexivity.
Qed.

Theorem hmodels_exp:
  forall h s e u (E: eval_exp h s e u),
  hmodels s h u.
Proof.
  intros. revert s u E. induction e; intros; inversion E; subst; try apply HMN.
    destruct (s v) eqn:SV; econstructor. exact SV. reflexivity.

    apply IHe1 in E1. inversion E1; subst.
    eapply HMM. eassumption.
    intros. rewrite <- (FR _ H).
    destruct (N.lt_ge_cases a0 a). apply setmem_frame_low. assumption.
    destruct (N.le_gt_cases (a+w) a0). apply setmem_frame_high. assumption.
    rewrite <- (N.add_sub a0 a), N.add_comm, <- N.add_sub_assoc in H1 by assumption.
    apply N.add_lt_mono_l, W in H1.
    rewrite N.add_sub_assoc, N.add_comm, N.add_sub in H1 by assumption.
    apply proj1 in H1. rewrite H in H1. discriminate H1.

    destruct b; apply HMN.

    destruct u; apply HMN.

    apply IHe2 in E2. inversion E2; subst. apply HMN. destruct (vareq v0 v).
      subst v0. rewrite update_updated in SV. subst. apply IHe1 in E1. inversion E1; subst.
        eapply HMM. eassumption. intros. rewrite (FR a H). apply FR0. assumption.
      eapply HMM. rewrite update_frame in SV by assumption. eassumption. assumption.

    destruct n1; [ apply IHe3 | apply IHe2 ]; assumption.
Qed.

Theorem hmodels_stmt:
  forall h s q s' x (XS: exec_stmt h s q s' x),
  hmodels_store h s s'.
Proof.
  intros. dependent induction XS; intros; try solve [ apply hmodels_refl | assumption ].
    intro v'. destruct ((s[v:=u]) v') eqn:SV'. apply HMN. destruct (vareq v' v).
      subst v'. rewrite update_updated in SV'. subst. eapply hmodels_exp; eassumption.
      rewrite update_frame in SV' by assumption. eapply HMM. eassumption. reflexivity.
    eapply hmodels_trans; eassumption.
Qed.

Theorem hmodels_prog:
  forall h p a s n s' x (XP: exec_prog h p a s n s' x),
  hmodels_store h s s'.
Proof.
  intros. dependent induction XP; intros.
    apply hmodels_refl.
    eapply hmodels_trans. eapply hmodels_stmt. eassumption. eassumption.
    eapply hmodels_stmt. eassumption.
Qed.

Lemma frames_rep:
  forall R e q (FR: frames_stmt R q), frames_stmt R (Seq q (Rep e q)).
Proof.
  intros. intros s h u HM. apply AASeq.
    apply FR. assumption.
    apply AARep, FR. assumption.
Qed.

Lemma framed_stmt:
  forall {A} (R: hsprop var) (h:heap A) s q s' x (FR: frames_stmt R q)
         (XS: exec_stmt (hopp h) s q s' x)
         (HS: hmodels_store (hopp h) s s') (PRE: R (resths h (to_hstore s))),
  R (resths h (to_hstore s')).
Proof.
  intros. revert s s' x XS FR HS PRE.
  induction q using stmt_ind2; intros;
    inversion XS; clear XS; subst; try assumption;
    apply destruct_frames_stmt in FR.

    rewrite to_hstore_update, resths_update, <- resths_hdom, <- resthv_hdom. apply FR.
      rewrite hopp_hdom. eapply hmodels_exp. eassumption.
      rewrite resths_hdom. assumption.

    eapply IHq1; try eassumption. apply FR.

    eapply IHq2. eassumption.
      apply FR.
      eapply hmodels_stmt. eassumption.
      eapply IHq1; try eassumption.
        apply FR.
        eapply hmodels_stmt. eassumption.

    destruct c.
      eapply IHq2; try eassumption. apply FR.
      eapply IHq1; try eassumption. apply FR.

    eapply IHq2; try eassumption.
    apply Niter_invariant.
      intros s1 h1 u HM. apply AANop.
      intros q' FR' s1 h1 u HM. apply AASeq; [ apply FR | apply FR']; assumption.
Qed.

Lemma framed_prog:
  forall {A} (R: hsprop var) (h:heap A) p a s n s' x (FR: frames_prog R p)
         (XP: exec_prog (hopp h) p a s n s' x)
         (HS: hmodels_store (hopp h) s s') (PRE: R (resths h (to_hstore s))),
  R (resths h (to_hstore s')).
Proof.
  intros. revert a s s' x XP HS PRE. induction n; intros; inversion XP; clear XP; subst.
    assumption.
    eapply IHn. eassumption.
      eapply hmodels_prog. eassumption.
      eapply framed_stmt; try eassumption.
        specialize (FR s a). rewrite LU in FR. exact FR.
        eapply hmodels_stmt. eassumption.
    eapply framed_stmt; try eassumption. specialize (FR s a). rewrite LU in FR. exact FR.
Qed.

Theorem stmt_frame:
  forall q (P Q R: hsprop var) (FR: frames_stmt R q)
         (HT: htrip_stmt P q Q),
  htrip_stmt (sep P R) q (sep Q R).
Proof.
  unfold htrip_stmt. intros. destruct PRE as [dom' [PS RS]]. split.
    eapply exec_stmt_hmono.
      eapply resth_subset.
      apply HT. rewrite <- resths_assoc. exact PS. exact XS.
    exists dom'. rewrite !resths_assoc in *. split.
      eapply HT; eassumption.
      eapply framed_stmt; try eassumption; rewrite hopp_resth, hopp_inv, updateall_comm.
        eapply exec_stmt_hmono.
          etransitivity; [|apply subset_updateall]. eapply resth_subset.
          rewrite resth_comm. apply HT. exact PS. exact XS.
        eapply hmodels_stmt. eapply exec_stmt_hmono.
          etransitivity; [|apply subset_updateall]. eapply resth_subset.
          rewrite resth_comm. apply HT. exact PS. exact XS.
Qed.

Theorem prog_frame:
  forall p a n (P Q R: hsprop var) (FR: frames_prog R p)
         (HT: htrip_prog P p a n Q),
  htrip_prog (sep P R) p a n (sep Q R).
Proof.
  unfold htrip_prog. intros. destruct PRE as [h' [PS RS]]. split.
    eapply exec_prog_hmono.
      eapply resth_subset.
      apply HT. rewrite <- resths_assoc. exact PS. exact XP.
    exists h'. rewrite !resths_assoc in *. split.
      eapply HT; eassumption.
      eapply framed_prog; try eassumption; rewrite hopp_resth, hopp_inv, updateall_comm.
        eapply exec_prog_hmono.
          etransitivity; [|apply subset_updateall]. eapply resth_subset.
          rewrite resth_comm. apply HT. exact PS. exact XP.
        eapply hmodels_prog. eapply exec_prog_hmono.
          etransitivity; [|apply subset_updateall]. eapply resth_subset.
          rewrite resth_comm. apply HT. exact PS. exact XP.
Qed.

Lemma upd_pres_sep:
  forall P Q hs hu v
         (UP1: forall (h:hdomain), upd_pres P (resths h hs) (resthv h hu) v)
         (UP2: forall (h:hdomain), upd_pres Q (resths h hs) (resthv h hu) v),
  upd_pres (sep P Q) hs hu v.
Proof.
  unfold upd_pres, sep. intros. destruct H as [h [P1 Q2]].
  exists h. split; rewrite resths_update.
    apply UP1. assumption.
    apply UP2. assumption.
Qed.

(* P*Q frames q if P and Q both frame q. *)
Theorem frames_stmt_sep:
  forall P Q q (FR1: frames_stmt P q) (FR2: frames_stmt Q q),
  frames_stmt (sep P Q) q.
Proof.
  induction q; intros; unfold frames_stmt; intros; try solve [ constructor ];
  repeat match goal with [ H: frames_stmt _ (_ _) |- _ ] => apply destruct_frames_stmt in H end.
    apply AAMove, upd_pres_sep; intros dom0 H.
      rewrite resthv_assoc, resths_assoc. apply FR1.
        eapply hmodels_mono; [|eassumption]. apply hopp_mono. apply resth_subset.
        rewrite <- resths_assoc. assumption.
      rewrite resthv_assoc, resths_assoc. apply FR2.
        eapply hmodels_mono; [|eassumption]. apply hopp_mono. apply resth_subset.
        rewrite <- resths_assoc. assumption.
    apply AASeq; [ apply IHq1 | apply IHq2 ]; intros; solve [ apply FR1 | apply FR2 | assumption ].
    apply AAIf; [ apply IHq1 | apply IHq2 ]; intros; solve [ apply FR1 | apply FR2 | assumption ].
    apply AARep, IHq; intros; assumption.
Qed.

Theorem frames'_stmt_sep:
  forall P Q q (FR1: frames'_stmt P q) (FR2: frames'_stmt Q q),
  frames'_stmt (sep P Q) q.
Proof.
  unfold frames'_stmt. induction q; intros; try solve [ constructor ].
    apply AAMove, upd_pres_sep; intros h0 H.
      specialize (FR1 s (resth h0 h) u). inversion FR1.
        rewrite resths_assoc, resthv_assoc. apply PV. rewrite <- resths_assoc. assumption.
      specialize (FR2 s (resth h0 h) u). inversion FR2.
        rewrite resths_assoc, resthv_assoc. apply PV. rewrite <- resths_assoc. assumption.
    apply AASeq; [ apply IHq1 | apply IHq2 ]; intros; solve
    [ specialize (FR1 s0 h0 u0); inversion FR1; assumption
    | specialize (FR2 s0 h0 u0); inversion FR2; assumption ].
    apply AAIf; [ apply IHq1 | apply IHq2 ]; intros; solve
    [ specialize (FR1 s0 h0 u0); inversion FR1; assumption
    | specialize (FR2 s0 h0 u0); inversion FR2; assumption ].
    apply AARep, IHq; intros.
      specialize (FR1 s0 h0 u0). inversion FR1. assumption.
      specialize (FR2 s0 h0 u0). inversion FR2. assumption.
Qed.

Theorem frames_prog_sep:
  forall P Q p (FR1: frames_prog P p) (FR2: frames_prog Q p),
  frames_prog (sep P Q) p.
Proof.
  unfold frames_prog. intros. specialize (FR1 s a). specialize (FR2 s a). destruct (p s a) as [(sz,q)|].
    apply frames_stmt_sep; assumption.
    exact I.
Qed.

Theorem frames'_prog_sep:
  forall P Q p (FR1: frames'_prog P p) (FR2: frames'_prog Q p),
  frames'_prog (sep P Q) p.
Proof.
  unfold frames'_prog. intros. specialize (FR1 s a). specialize (FR2 s a). destruct (p s a) as [(sz,q)|].
    apply frames'_stmt_sep; assumption.
    exact I.
Qed.

Theorem frames_stmt_htrue: forall q, frames_stmt htrue q.
Proof.
  unfold htrue,frames_stmt. intros.
  induction q; constructor; try intro; try assumption.
Qed.

Theorem frames'_stmt_htrue: forall q, frames'_stmt htrue q.
Proof.
  unfold htrue,frames'_stmt. intros.
  induction q; constructor; try intro; try assumption.
Qed.

Theorem frames_prog_htrue: forall p, frames_prog htrue p.
Proof.
  unfold htrue,frames_prog. intros. destruct (p s a) as [(sz,q)|].
    apply frames_stmt_htrue.
    exact I.
Qed.

Theorem frames'_prog_htrue: forall p, frames'_prog htrue p.
Proof.
  unfold htrue,frames'_prog. intros. destruct (p s a) as [(sz,q)|].
    apply frames'_stmt_htrue.
    exact I.
Qed.

Theorem frames_stmt_hfalse: forall q, frames_stmt hfalse q.
Proof.
  unfold hfalse,frames_stmt. intros.
  induction q; constructor; try intro; try assumption.
Qed.

Theorem frames'_stmt_hfalse: forall q, frames'_stmt hfalse q.
Proof.
  unfold hfalse,frames'_stmt. intros.
  induction q; constructor; try intro; try assumption.
Qed.

Theorem frames_prog_hfalse: forall p, frames_prog hfalse p.
Proof.
  unfold hfalse,frames_prog. intros. destruct (p s a) as [(sz,q)|].
    apply frames_stmt_hfalse.
    exact I.
Qed.

Theorem frames'_prog_hfalse: forall p, frames'_prog hfalse p.
Proof.
  unfold hfalse,frames'_prog. intros. destruct (p s a) as [(sz,q)|].
    apply frames'_stmt_hfalse.
    exact I.
Qed.

Lemma frames_stmt_anystore:
  forall R q, (forall s (h:hdomain) u v (HM: hmodels s (hopp h) u), upd_pres R (resths h (to_hstore s)) (resthv h (to_hval u)) v) ->
  frames_stmt R q.
Proof.
  unfold frames_stmt. intros. induction q; intros; constructor; try assumption.
  apply H. assumption.
Qed.

Lemma frames'_stmt_anystore:
  forall R q, (forall s (h:hdomain) u v, upd_pres R (resths h (to_hstore s)) (resthv h (to_hval u)) v) ->
  frames'_stmt R q.
Proof.
  unfold frames'_stmt. intros. induction q; intros; constructor; try assumption.
  apply H.
Qed.

Theorem frames_stmt_hprop:
  forall R q, frames_stmt (hprop var R) q.
Proof.
  intros. apply frames_stmt_anystore. unfold upd_pres,hprop. intros. destruct (vareq v0 v).
    subst v0. rewrite update_updated in SV. destruct u.
      discriminate.
      inversion HM. injection SV as. subst. replace (resth h (to_heap _)) with (resth h (to_heap m')).
        eapply H. unfold resths,to_hstore. rewrite SV0. reflexivity.
        extensionality a. specialize (FR a). unfold resth. unfold hopp in FR. destruct (h a).
          unfold to_heap. destruct u. rewrite FR; reflexivity.
          reflexivity.
    rewrite update_frame in SV by assumption. eapply H. eassumption.
Qed.

(* (frames'_stmt (hprop R) q) is false for useful R's, so not worth proving
   anything about it.  This is because hprops are properties that are universally
   satisfied by all heaps in the store, and frames'_stmt requires that its
   proposition parameter R be satisfied by all values assigned to variables in q.
   Thus, if q contains any assignments at all, R would have to be universally
   true of all heaps in order for (frames'_stmt (hprop R) q) to be true.  This
   has taken me a long time to understand, so I prove it here to convince/remind
   myself. *)
Remark frames'_stmt_hprop_useless:
  forall R v e, (frames'_stmt (hprop var R) (Move v e)) -> (forall h, R h).
Proof.
  intros.
  specialize (H (fun _ => VaN 0 0) (hdom h) (VaM (fun a => match h a with None => 0 | Some n => n end) 0)).
  inversion H; subst. eapply PV. discriminate.
  rewrite update_updated. simpl. replace (resth _ _) with h. reflexivity.
  extensionality a. unfold to_heap, resth, hdom. destruct (h a); reflexivity.
Qed.

Theorem frames_prog_hprop:
  forall R p, frames_prog (hprop var R) p.
Proof.
  unfold frames_prog. intros. destruct (p s a) as [(sz,q)|].
    apply frames_stmt_hprop.
    exact I.
Qed.

Theorem frames_stmt_impl:
  forall P Q q (FR1: frames'_stmt P q) (FR2: frames_stmt Q q),
  frames_stmt (fun hs => P hs -> Q hs) q.
Proof.
  induction q; intros; unfold frames_stmt; intros; try solve [ constructor ].

    apply AAMove. unfold upd_pres. intros.
    apply destruct_frames'_stmt in FR1. apply destruct_frames_stmt in FR2.
    apply FR2. assumption. apply H.
    replace (resths _ _) with (resths h (to_hstore (s[v:=u])) [v := resthv h (to_hval (s v))]).
      apply FR1. rewrite to_hstore_update, resths_update. assumption.
      rewrite to_hstore_update, resths_update, update_cancel. extensionality v0. destruct (vareq v0 v).
        subst v0. rewrite update_updated. unfold to_hstore, resths. reflexivity.
        rewrite update_frame by assumption. reflexivity.

    apply AASeq; [ apply IHq1 | apply IHq2 ]; try assumption; solve
    [ apply destruct_frames'_stmt in FR1; apply FR1
    | apply destruct_frames_stmt in FR2; apply FR2 ].

    apply AAIf; [ apply IHq1 | apply IHq2 ]; try assumption; solve
    [ apply destruct_frames'_stmt in FR1; apply FR1
    | apply destruct_frames_stmt in FR2; apply FR2 ].

    apply AARep. apply IHq; try assumption.
      apply destruct_frames'_stmt in FR1; apply FR1.
      apply destruct_frames_stmt in FR2; apply FR2.
Qed.

Theorem frames'_stmt_impl:
  forall P Q q (FR1: frames'_stmt P q) (FR2: frames'_stmt Q q),
  frames'_stmt (fun hs => P hs -> Q hs) q.
Proof.
  induction q; intros; unfold frames'_stmt; intros; try solve [ constructor ].

    apply AAMove. unfold upd_pres. intros.
    apply destruct_frames'_stmt in FR1. apply destruct_frames'_stmt in FR2.
    apply FR2. apply H.
    replace (resths _ _) with (resths h (to_hstore (s[v:=u])) [v := resthv h (to_hval (s v))]).
      apply FR1. rewrite to_hstore_update, resths_update. assumption.
      rewrite to_hstore_update, resths_update, update_cancel. extensionality v0. destruct (vareq v0 v).
        subst v0. rewrite update_updated. unfold to_hstore, resths. reflexivity.
        rewrite update_frame by assumption. reflexivity.

    apply AASeq; [ apply IHq1 | apply IHq2 ]; try assumption; solve
    [ apply destruct_frames'_stmt in FR1; apply FR1
    | apply destruct_frames'_stmt in FR2; apply FR2 ].

    apply AAIf; [ apply IHq1 | apply IHq2 ]; try assumption; solve
    [ apply destruct_frames'_stmt in FR1; apply FR1
    | apply destruct_frames'_stmt in FR2; apply FR2 ].

    apply AARep. apply IHq; try assumption.
      apply destruct_frames'_stmt in FR1; apply FR1.
      apply destruct_frames'_stmt in FR2; apply FR2.
Qed.

Theorem frames_prog_impl:
  forall P Q p (FR1: frames'_prog P p) (FR2: frames_prog Q p),
  frames_prog (fun hs => P hs -> Q hs) p.
Proof.
  intros. intros s a. specialize (FR1 s a). specialize (FR2 s a). destruct (p s a) as [(sz,q)|].
    apply frames_stmt_impl; assumption.
    exact I.
Qed.

Theorem frames'_prog_impl:
  forall P Q p (FR1: frames'_prog P p) (FR2: frames'_prog Q p),
  frames'_prog (fun hs => P hs -> Q hs) p.
Proof.
  intros. intros s a. specialize (FR1 s a). specialize (FR2 s a). destruct (p s a) as [(sz,q)|].
    apply frames'_stmt_impl; assumption.
    exact I.
Qed.

Corollary frames_stmt_not:
  forall P q (FR: frames'_stmt P q),
  frames_stmt (fun hs => ~ P hs) q.
Proof.
  intros. apply frames_stmt_impl. assumption. apply frames_stmt_hfalse.
Qed.

Corollary frames'_stmt_not:
  forall P q (FR: frames'_stmt P q),
  frames'_stmt (fun hs => ~ P hs) q.
Proof.
  intros. apply frames'_stmt_impl. assumption. apply frames'_stmt_hfalse.
Qed.

Corollary frames_prog_not:
  forall P p (FR: frames'_prog P p),
  frames_prog (fun hs => ~ P hs) p.
Proof.
  intros. apply frames_prog_impl. assumption. apply frames_prog_hfalse.
Qed.

Corollary frames_prog'_not:
  forall P p (FR: frames'_prog P p),
  frames'_prog (fun hs => ~ P hs) p.
Proof.
  intros. apply frames'_prog_impl. assumption. apply frames'_prog_hfalse.
Qed.

End PicinaeSLogic.


(*
Coq does not have judgemental sigma eta conversion.
Assuming function extensionality, we develop eta conversion
inside a function, as part of a term whose type is judgementally
the same before and after the eta expansion.

This was surprisingly hard to prove.
*)

From IWTypes Require Import FunctionExtensionality.

Section sigma_eta.
Context {FunExt : FunExt}.

Definition sigma_eta_eq {A} (P : A -> Type) (x : sigT P)
  : x = existT P (projT1 x) (projT2 x)
  := match x with existT _ p1 p2 => eq_refl end.

Context {A B} (P : forall a : A, B a -> Type).

Definition sigma_eta_family f (a : A) : sigT (P a)
  := existT _ (projT1 (f a)) (projT2 (f a)).
Definition sigma_eta_family_eq f : f = sigma_eta_family f
  := funext (fun a => sigma_eta_eq (P a) (f a)).

Context (C : forall (p1 : forall a, B a), (forall a, P a (p1 a)) -> Type).
Definition Cf f := C (fun a => projT1 (f a)) (fun a => projT2 (f a)).
Context (make_C : forall f, Cf f).

Definition sigma_eta_family_funext f
  : make_C (sigma_eta_family f) = make_C f
  := let lemma
      : eq_rect (Cf (sigma_eta_family f)) (fun T => T)
          (make_C (sigma_eta_family f)) (Cf f)
          (f_equal Cf (eq_trans
           (eq_sym (sigma_eta_family_eq f))
           (sigma_eta_family_eq f))) =
        make_C f
      := match eq_sym (sigma_eta_family_eq f) as p in (_ = f')
         return
           eq_rect (Cf (sigma_eta_family f)) (fun T => T)
             (make_C (sigma_eta_family f)) (Cf f')
             (f_equal Cf (eq_trans p (sigma_eta_family_eq f'))) =
           make_C f'
         with eq_refl => f_equal
           (fun p2  =>
            eq_rect _ (fun T => T) _ _ (f_equal Cf (eq_trans eq_refl p2)))
           (funext_comp eq_refl)
         end in
     let cancel_paths {A} {a b : A} (p : a = b)
      : eq_trans (eq_sym p) p = eq_refl
      := match p in (_ = b) return eq_trans (eq_sym p) p = eq_refl
         with eq_refl => eq_refl end in
     match cancel_paths (sigma_eta_family_eq f) in (_ = p)
     return eq_rect _ (fun T => T) _ _ (f_equal Cf p) = _
     with eq_refl => lemma end.
End sigma_eta.


(** This file defines the kernel of a homomorphism [cong_ker], the
    image of a homomorphism [in_image_hom], and it proves the first
    isomorphism theorem [isomorphic_first_isomorphism]. The first
    identification theorem [id_first_isomorphism] follows. *)

Require Import
  HoTT.HSet
  HoTT.HIT.quotient
  HoTT.Classes.interfaces.canonical_names
  HoTT.Classes.theory.ua_isomorphic
  HoTT.Classes.theory.ua_subalgebra
  HoTT.Classes.theory.ua_quotient_algebra.

Import
  algebra_notations
  quotient_algebra_notations
  subalgebra_notations
  isomorphic_notations.

(** The following section defines the kernel of a homomorphism
    [cong_ker], and shows that it is a congruence.*)

Section cong_ker.
  Context
    {σ : Signature} {A B : Algebra σ} `{IsHSetAlgebra B}
    (f : ∀ s, A s → B s) `{!IsHomomorphism f}.

  Definition cong_ker (s : Sort σ) : Relation (A s)
    := λ (x y : A s), f s x = f s y.

(* Leave the following results about [cong_ker] opaque because they
   are h-props. *)

  Global Instance equiv_rel_ker (s : Sort σ)
    : EquivRel (cong_ker s).
  Proof.
    repeat constructor.
    - intros x y. exact inverse.
    - intros x y z. exact concat.
  Qed.

  Lemma path_ap_operation_ker_related {w : SymbolType σ}
    (β : Operation B w) (a b : FamilyProd A (dom_symboltype w))
    (R : for_all_2_family_prod A A cong_ker a b)
    : ap_operation β (map_family_prod f a)
      = ap_operation β (map_family_prod f b).
  Proof.
    induction w.
    - reflexivity.
    - destruct a as [x a], b as [y b], R as [r R].
      cbn. destruct r. by apply IHw.
  Qed.

  Global Instance ops_compatible_ker : OpsCompatible A cong_ker.
  Proof.
    intros u a b R.
    unfold cong_ker.
    destruct (path_homomorphism_ap_operation f u a)^.
    destruct (path_homomorphism_ap_operation f u b)^.
    by apply path_ap_operation_ker_related.
  Qed.

  Global Instance is_congruence_ker : IsCongruence A cong_ker
    := BuildIsCongruence A cong_ker.

End cong_ker.

(** The next section defines an "in image predicate", [in_image_hom].
    It gives rise to the homomorphic image of a homomorphism. *)

Section in_image_hom.
  Context
    `{Funext} {σ : Signature} {A B : Algebra σ}
    (f : ∀ s, A s → B s) {hom : IsHomomorphism f}.

  Definition in_image_hom (s : Sort σ) (y : B s) : HProp
    := merely (hfiber (f s) y).

  Lemma closed_under_op_in_image_hom {w : SymbolType σ}
    (α : Operation A w) (β : Operation B w) (P : OpPreserving f α β)
    : ClosedUnderOp B in_image_hom β.
  Proof.
    induction w.
    - exact (tr (α; P)).
    - intro y.
      refine (Trunc_rec _). intros [x p].
      apply (IHw (α x)).
      by destruct p.
  Qed.

  Lemma is_closed_under_ops_in_image_hom
    : IsClosedUnderOps B in_image_hom.
  Proof.
    intro u. eapply closed_under_op_in_image_hom, hom.
  Qed.

  Global Instance is_subalgebra_predicate_in_image_hom
    : IsSubalgebraPredicate B in_image_hom
    := BuildIsSubalgebraPredicate is_closed_under_ops_in_image_hom.
End in_image_hom.

(** The folowing section proves the first isomorphism theorem,
    [isomorphic_first_isomorphism] and the first identification
    theorem [id_first_isomorphism]. *)

Section first_isomorphism.
  Context
    `{Univalence} {σ} {A B : Algebra σ} `{IsHSetAlgebra B}
    (f : ∀ s, A s → B s) {hom : IsHomomorphism f}.

(** The homomorphism [def_first_isomorphism] is informally given by

    <<
      def_first_isomorphism s (class_of _ x) := f s x.
    >>
*)

  Definition def_first_isomorphism (s : Sort σ)
    : (A / cong_ker f) s → (B && in_image_hom f) s.
  Proof.
    refine (quotient_rec (cong_ker f s) (λ x, (f s x; tr (x; idpath))) _).
    intros x y p.
    now apply path_sigma_hprop.
  Defined.

  Lemma oppreserving_first_isomorphism {w : SymbolType σ}
    (α : Operation A w)
    (β : Operation B w)
    (γ : Operation (A / cong_ker f) w)
    (C : ClosedUnderOp B (in_image_hom f) β)
    (P : OpPreserving f α β)
    (G : ComputeOpQuotient A (cong_ker f) α γ)
    : OpPreserving def_first_isomorphism γ
        (op_subalgebra B (in_image_hom f) β C).
  Proof.
    induction w.
    - apply path_sigma_hprop.
      generalize dependent γ.
      refine (quotient_ind_prop (cong_ker f t) _ _). intros x G.
      destruct P.
      apply (classes_eq_related (cong_ker f t) _ _ (G tt)).
    - refine (quotient_ind_prop (cong_ker f t) _ _). intro x.
      apply (IHw (α x) (β (f t x)) (γ (class_of _ x))).
      + exact (P x).
      + intro a. exact (G (x,a)).
  Qed.

(* Leave [is_homomorphism_first_isomorphism] opaque because
   [IsHomomorphism] is an hprop when [B] is a set algebra. *)

  Global Instance is_homomorphism_first_isomorphism
    : IsHomomorphism def_first_isomorphism.
  Proof.
    intro u. apply (oppreserving_first_isomorphism u.#A).
    - apply hom.
    - apply compute_op_quotient.
  Qed.

  Definition hom_first_isomorphism
    : Homomorphism (A / cong_ker f) (B && in_image_hom f)
    := BuildHomomorphism def_first_isomorphism.

  Global Instance embedding_first_isomorphism (s : Sort σ)
    : IsEmbedding (hom_first_isomorphism s).
  Proof.
    apply isembedding_isinj_hset.
    refine (quotient_ind_prop (cong_ker f s) _ _). intro x.
    refine (quotient_ind_prop (cong_ker f s) _ _). intros y p.
    apply related_classes_eq.
    exact (p..1).
  Qed.

  Global Instance surjection_first_isomorphism (s : Sort σ)
    : IsSurjection (hom_first_isomorphism s).
  Proof.
    apply BuildIsSurjection.
    intros [x M].
    refine (Trunc_rec _ M). intros [y Y].
    apply tr.
    exists (class_of _ y).
    now apply path_sigma_hprop.
  Qed.

  Global Instance is_isomorphism_first_isomorphism
    : IsIsomorphism hom_first_isomorphism.
  Proof.
    intro s. apply isequiv_surj_emb; exact _.
  Qed.

  Theorem isomorphic_first_isomorphism
    : A / cong_ker f ≅ B && in_image_hom f.
  Proof.
    exact (BuildIsomorphic def_first_isomorphism).
  Defined.

(* The first identification theorem [id_first_isomorphism] is an
   h-prop, so we can leave it opaque. *)

  Corollary id_first_isomorphism : A / cong_ker f = B && in_image_hom f.
  Proof.
    exact (id_isomorphic isomorphic_first_isomorphism).
  Qed.
End first_isomorphism.

(** The next section gives a specialization of the first isomorphism
    theorem, where the homomorphism is surjective. *)

Section first_isomorphism_surjection.
  Context
    `{Univalence} {σ} {A B : Algebra σ} `{IsHSetAlgebra B}
    (f : ∀ s, A s → B s) `{!IsHomomorphism f} {S : ∀ s, IsSurjection (f s)}.

  Global Instance is_isomorphism_inc_first_isomorphism_surjection
    : IsIsomorphism (hom_inc_subalgebra B (in_image_hom f)).
  Proof.
    apply is_isomorphism_inc_improper_subalgebra. apply S.
  Qed.

(** The homomorphism [hom_first_isomorphism_surjection] is the
    composition of two isomorphisms, so it is an isomorphism. *)

  Definition hom_first_isomorphism_surjection
    : Homomorphism (A / cong_ker f) B
    := hom_compose
          (hom_inc_subalgebra B (in_image_hom f))
          (hom_first_isomorphism f).

  Theorem isomorphic_first_isomorphism_surjection : A / cong_ker f ≅ B.
  Proof.
    exact (BuildIsomorphic hom_first_isomorphism_surjection).
  Defined.

  Corollary id_first_isomorphism_surjection : (A / cong_ker f) = B.
  Proof.
    exact (id_isomorphic isomorphic_first_isomorphism_surjection).
  Qed.
End first_isomorphism_surjection.

(** The next section specializes the first isomorphism theorem to the
    case where the homomorphism is injective. It proves that an
    injective homomorphism is an isomorphism between its domain
    and its image. *)

Section first_isomorphism_inj.
  Context
    `{Univalence} {σ} {A B : Algebra σ} `{IsHSetAlgebra B}
    (f : ∀ s, A s → B s) `{!IsHomomorphism f} (inj : ∀ s, isinj (f s)).

  Global Instance is_isomorphism_quotient_first_isomorphism_inj
    : IsIsomorphism (hom_quotient (cong_ker f)).
  Proof.
    apply is_isomorphism_quotient. intros s x y p. apply inj, p.
  Qed.

(** The homomorphism [hom_first_isomorphism_inj] is the
    composition of two isomorphisms, so it is an isomorphism. *)

  Definition hom_first_isomorphism_inj
    : Homomorphism A (B && in_image_hom f)
    := hom_compose
          (hom_first_isomorphism f)
          (hom_quotient (cong_ker f)).

  Definition isomorphic_first_isomorphism_inj : A ≅ B && in_image_hom f
    := BuildIsomorphic hom_first_isomorphism_inj.

  Definition id_first_isomorphism_inj : A = B && in_image_hom f
    := id_isomorphic isomorphic_first_isomorphism_inj.

End first_isomorphism_inj.


(* This file is part of the Linear Logic formalization in Coq:
https://github.com/brunofx86/LL *)

(** ** Triadic System
This file specifies Andreoli's triadic system. Sequents are of the shape
<<
|-F- B ; M ; X
>>

where
 - [B] is the classical context
 - [M] contains only positive formulas
 - [X] is an "arrow" that can be:
  - [UP L], where L is a list of formulas (negative phase )
  - [DW F], where F is a formula (positive phase)

 *)

Require Export StrongInduction.
Require Export BDefinitions.
Require Export Permutation.
Require Import Coq.Relations.Relations.
Require Import Coq.Arith.EqNat.
Require Import Coq.Classes.Morphisms.
Require Import Coq.Setoids.Setoid.
Require Export Coq.Sorting.PermutSetoid.
Require Export Coq.Sorting.PermutEq.
Require Import Coq.Program.Equality.

Set Implicit Arguments.

(** Triadic System for LL *)

Reserved Notation " n '|-F-' B ';' L ';' X " (at level 80).

Inductive TriSystem: nat -> list lexp -> list lexp -> Arrow -> Prop :=
| tri_init1 : forall B A,  0 |-F- B ; [A ⁻] ; DW (A ⁺)
| tri_init2 : forall B B' A,  B =mul= (A ⁻) :: B' -> 0 |-F- B ; [] ; DW (A ⁺)
| tri_one : forall B, 0 |-F- B ; [] ; DW 1
| tri_tensor : forall B M N MN F G n m,
    MN =mul= M ++ N -> n |-F- B ; N ; DW F -> m |-F- B ; M ; DW G -> S (max n m) |-F- B ; MN ; DW (F ** G)
| tri_plus1 : forall B M F G n, n |-F- B ; M ; DW F -> S n |-F- B ; M ; DW (F ⊕ G)
| tri_plus2 : forall B M F G n, n |-F- B ; M ; DW G -> S n |-F- B ; M ; DW (F ⊕ G)
| tri_bang : forall B F n, n |-F- B ; [] ; UP [F] -> S n |-F- B ; [] ; DW (! F)
| tri_rel : forall B F L n, ReleaseF F = true -> n |-F- B ; L ; UP [F] ->  S n |-F- B ; L ; DW F
(*where " n '|-F-' B ';' L ';' X " := (SyncPhase n B L X)
with AsyncPhase : nat -> Multiset -> Multiset -> Arrow -> Prop := *)
| tri_top : forall B L M, 0 |-F- B ; L ; UP (Top :: M)
| tri_bot : forall B L M n, n |-F- B ; L ; UP M -> S n |-F- B ; L ; UP (Bot :: M)
| tri_par : forall B L M F G n, n |-F- B ; L ; UP (F::G::M) -> S n |-F- B ; L ; UP(F $ G :: M)
| tri_with : forall B L M F G n m,
    n |-F- B ; L ; UP (F :: M) -> m |-F- B ; L ; UP (G :: M) -> S (max n m) |-F- B ; L ; UP (F & G :: M)
| tri_quest : forall B L M F n, n |-F- B ++ [F] ; L ; UP M -> S n |-F- B ; L ; UP (? F :: M)
| tri_store : forall B L M F n, AsynchronousF F = false -> n |-F- B ; L ++ [F] ; UP M -> S n |-F- B ; L ; UP (F::M)
| tri_dec1 : forall B L L' F n,
    IsNegativeAtomF F = false ->
    L =mul= F :: L' -> n |-F- B ; L' ; DW F -> S n |-F- B ; L ; UP []
| tri_dec2 : forall B B' L  F n,
    IsNegativeAtomF F = false ->
    B =mul= F :: B' -> n |-F- B ; L ; DW F -> S n |-F- B ; L ; UP []
where " n '|-F-' B ';' L ';' X " := (TriSystem n B L X).

(* The [B] and [M] contexts can be substituted by equivalent multisets *)
Theorem TriExchange : forall B B' M M' X n, n |-F-  B ; M ; X -> B =mul= B' -> M =mul= M' -> n |-F- B' ; M' ; X.
Proof.
  intros.
  generalize dependent B.
  generalize dependent M.
  generalize dependent B'.
  generalize dependent M'.
  generalize dependent X.
  induction n using strongind;intros.
  + inversion H;subst.
    ++ apply MulSingleton in H1;subst.
       eapply tri_init1.
    ++
      apply meq_sym in H1.
      apply  multiset_meq_empty in H1;subst.
      eapply tri_init2.
      rewrite <- H0.
      apply H2.
    ++
      apply meq_sym in H1.
      apply  multiset_meq_empty in H1;subst.
      eapply tri_one.
    ++
      eapply tri_top.
  + inversion H0;subst.
    ++ (* tensor *)
      apply H  with (M':=N) (B':= B') in H5;auto.
      apply H  with (M':=M0) (B':= B') in H6;auto.
      apply tri_tensor with (F:=F)(G:=G) (N:=N)(M:=M0);auto.
      rewrite <- H1.
      assumption.
    ++ (* Oplus *)
      eapply H  with (M':=M') (B':=B')in H4;auto.
      eapply tri_plus1;auto.
    ++ (* Oplus 2*)
      eapply H  with (M':=M') (B':=B')in H4;auto.
      eapply tri_plus2;auto.
    ++ (* Bang *)
      apply meq_sym in H1.
      apply  multiset_meq_empty in H1;subst.
      eapply H  with (B':=B')in H4;auto.
      eapply tri_bang;auto.
    ++ (* Release *)
      eapply H  with (M':=M') (B':=B')in H5;auto.
      eapply tri_rel;auto.
    ++ (* Bottom *)
      eapply H  with (M':=M') (B':=B')in H4;auto.
      eapply tri_bot;auto.
    ++ (* Par *)
      eapply H  with (M':=M') (B':=B')in H4;auto.
      eapply tri_par;auto.
    ++ (* with *)
      eapply H  with (M':=M') (B':=B')in H4;auto.
      eapply H  with (M':=M') (B':=B')in H5;auto.
      eapply tri_with;auto.
    ++ (* ? *)
      eapply H  with (M':=M')(B':=B' ++ [F])in H4;auto.
      eapply tri_quest;auto.
    ++  (* store *)
      eapply H  with (M':=M' ++ [F]) (B':=B')in H5;auto.
      eapply tri_store;auto.
    ++  (* decide 1*)
      eapply H  with (M':= L' ) (B':=B')in H6;auto.
      eapply tri_dec1 with (F:=F);auto.
      rewrite <- H1.
      apply H5.
      assumption.
    ++ (* decide 2 *)
      eapply H  with (M':= M' ) (B':=B')in H6;auto.
      eapply tri_dec2 with (F:=F);auto.
      rewrite <- H2.
      apply H5.
Qed.

Generalizable All Variables.
Instance Tri_morph : Proper (meq ==> meq ==> eq ==> iff) (TriSystem n).
Proof.
  intros n A B Hab C D Hcd X Y Hxy; subst.
  split;intro.
  + apply TriExchange with (B:=A) (M:=C);auto.
  + apply TriExchange with (B:=B) (M:=D);auto.
Qed.
Instance Tri_morph' : Proper (meq ==> meq ==> @eq Arrow ==> iff) (TriSystem n).
Proof.
  intros n A B Hab C D Hcd X Y Hxy; subst.
  split;intro.
  + apply TriExchange with (B:=A) (M:=C);auto.
  + apply TriExchange with (B:=B) (M:=D);auto.
Qed.

Example myExample l' L1' L2' B M :
  (exists m : nat, m |-F- B; M; UP ((l' :: L1') ++ [⊤] ++ L2')) ->
  exists m : nat, m |-F- B; M; UP (l' :: L1' ++ [⊤] ++ L2').
Proof.
  intros.
  assert (l' :: L1' ++ [⊤] ++ L2' = (l' :: L1') ++ [⊤] ++ L2') by auto.
  rewrite H0.
Abort.


Definition id := nat.
Definition loc := nat. (* store locations *)

(* locally nameless for binders in terms (and eventually in types/qualifiers) *)
Inductive var : Type :=
| varF : id -> var (* free var (deBruijn level) *)
| varB : id -> var (* locally-bound variable (deBruijn index) *)
.

Notation "# i" := (varB i) (at level 0, right associativity).
Notation "$ i" := (varF i) (at level 0, right associativity).


Require Import floyd.proofauto.
Require Import sha.sha.
Require Import sha.SHA256.
Require Import sha.spec_sha.
Require Import sha.sha_lemmas.
Require Import sha.bdo_lemmas.
Local Open Scope logic.

Definition block_data_order_loop2 :=
   nth 1 (loops (fn_body f_sha256_block_data_order)) Sskip.

Fixpoint Xarray' (b: list int) (i k: nat) : list int :=
 match k with
 | O => nil
 | S k' => W (nthi b) (Z.of_nat i - 16 + (16-(Z.of_nat k)- Z.of_nat i) mod 16) ::
                 Xarray' b i k'
 end.

Definition Xarray (b: list int) (i: nat) := Xarray' b i 16.

Lemma Xarray_simpl:
   forall b, length b = 16%nat -> Xarray b 16 = b.
Proof.
intros.
assert (forall n, (n<=16)%nat -> Xarray' b 16 n = skipn (16-n) b);
 [ | apply H0; auto ].
induction n; intros.
clear H0. rewrite skipn_short by omega. reflexivity.

unfold Xarray'; fold Xarray'.
rewrite IHn by omega. clear IHn.
change (Z.of_nat 16) with 16%Z.

assert (H1: firstn 1 (skipn (16 - S n) b) =
            W (nthi b) (16 - 16 + (Z.of_nat (16 - S n) - 16) mod 16) :: nil). {
 unfold firstn.
 destruct (skipn (16 - S n) b) eqn:?.
 pose proof (skipn_length b (16 - S n)).
 rewrite Heql in H1.
 simpl length in H1.
 omega.
 f_equal.
 pose proof (nth_skipn 0 (16 - S n)%nat b Int.zero).
 rewrite Heql in H1.
 unfold nth at 1 in H1.
 subst.
 rewrite Z.sub_diag. rewrite Z.add_0_l.
 rewrite plus_0_l.
 rewrite Zminus_mod.
 rewrite Z.mod_same by omega. rewrite Z.sub_0_r.
 rewrite Z.mod_mod by omega.
 assert (0 <= (Z.of_nat (16 - S n))mod 16 < 16)%Z by (apply Z.mod_pos_bound; omega).
 rewrite W_equation.
 rewrite if_true by  omega.
 rewrite Z.mod_small.
 unfold nthi.
 rewrite Nat2Z.id.
 reflexivity.
 split; try omega.
 change (Z.of_nat (16 - S n) < Z.of_nat 16)%Z.
 apply Nat2Z.inj_lt.
 omega.
}
assert (H2 := skipn_skipn 1 (16 - S n) b).
replace (16 - S n + 1)%nat with (16 - n)%nat in H2 by omega.
rewrite <- H2.
rewrite <- (firstn_skipn 1 (skipn (16 - S n) b)) at 2.
rewrite H1.
unfold app.
rewrite Nat2Z.inj_sub by omega.
reflexivity.
Qed.

Lemma length_Xarray:
  forall b i, length (Xarray b i) = 16%nat.
Proof.
intros. reflexivity.
Qed.

Lemma nth_Xarray:
  forall b i k,
     (0 <= k < 16)%Z ->
  nthi (Xarray b i) k = W (nthi b) (Z.of_nat i - 16 + (k- Z.of_nat i) mod 16)%Z .
Proof.
intros.
unfold nthi at 1.
remember (Z.to_nat k) as k'.
rewrite <- (Nat2Z.id k') in Heqk'.
apply Z2Nat.inj in Heqk'; try omega.
subst k.
assert (k'<16)%nat by omega.
clear H.
do 16 (destruct k'; try reflexivity).
elimtype False; omega.
Qed.

Lemma extract_from_b:
  forall b i n,
    length b = 16%nat ->
    (16 <= i < 64) ->
    (0 <= n < 16) ->
    nthi (Xarray b (Z.to_nat i)) ((i + n) mod 16) = W (nthi b) (i - 16 + n).
Proof.
intros.
rewrite nth_Xarray by (apply Z.mod_pos_bound; omega).
f_equal.
f_equal.
rewrite Z2Nat.id by omega. auto.
rewrite Z2Nat.id by omega.
rewrite Zminus_mod.
rewrite Zmod_mod.
rewrite Zplus_mod.
rewrite <- Zminus_mod.
rewrite (Zmod_small n) by omega.
replace (i mod 16 + n - i) with (i mod 16 - i + n) by omega.
rewrite Zplus_mod.
rewrite Zminus_mod.
rewrite Zmod_mod.
rewrite Z.sub_diag.
rewrite (Zmod_small 0) by omega.
rewrite Z.add_0_l.
repeat rewrite Zmod_mod.
apply Zmod_small; omega.
Qed.

Global Opaque Xarray.

Lemma Xarray_update:
 forall i b,
  Zlength b = LBLOCKz ->
  16 <= i < 64 ->
   upd_Znth (i mod 16) (map Vint (Xarray b (Z.to_nat i)))
          (Vint (W (nthi b) i))
  = map Vint (Xarray b (Z.to_nat i+1)).
Proof.
intros.
unfold upd_Znth.
rewrite !sublist_map.
rewrite <- !map_cons, <- !map_app.
f_equal.
repeat match type of H0 with
| (64 <= _ < _)%Z => elimtype False; omega
| (?A <= _ < _)%Z =>
 assert (H9: i=A \/ (A+1 <= i < 64)%Z) by omega;
 clear H0; destruct H9 as [H0|H0];
 [subst i; reflexivity
 | simpl in H0 ]
end.
Qed.

Lemma W_unfold:
  forall i b,
  16 <= i < 64 ->
   W (nthi b) (i) =
    Int.add (W (nthi b) (i - 16 + 0))
             (Int.add
                (Int.add (sigma_0 (W (nthi b) (i - 16 + 1)))
                   (sigma_1 (W (nthi b) (i - 16 + 14))))
                (W (nthi b) (i - 16 + 9))).
Proof.
 intros.
 rewrite W_equation.
 rewrite if_false by omega.
  rewrite Z.add_0_r;
      rewrite (Int.add_commut (W (nthi b) (i - 16)));
      repeat rewrite <- Int.add_assoc; f_equal;
      rewrite Int.add_commut; repeat rewrite Int.add_assoc; f_equal;
        [do 2 f_equal; omega | ];
      f_equal; [do 2 f_equal; omega | f_equal; omega].
Qed.

Lemma sha256_block_data_order_loop2_proof:
  forall (Espec : OracleKind)
     (b: list int) ctx (regs: list int) kv Xv
     (Hregs: length regs = 8%nat),
     Zlength b = LBLOCKz ->
     semax (initialized _i Delta_loop1)
 (PROP ()
   LOCAL (temp _ctx ctx; temp _i (Vint (Int.repr 16));
               temp _a (Vint (nthi (Round regs (nthi b) (LBLOCKz-1)) 0));
               temp _b (Vint (nthi (Round regs (nthi b) (LBLOCKz-1)) 1));
               temp _c (Vint (nthi (Round regs (nthi b) (LBLOCKz-1)) 2));
               temp _d (Vint (nthi (Round regs (nthi b) (LBLOCKz-1)) 3));
               temp _e (Vint (nthi (Round regs (nthi b) (LBLOCKz-1)) 4));
               temp _f (Vint (nthi (Round regs (nthi b) (LBLOCKz-1)) 5));
               temp _g (Vint (nthi (Round regs (nthi b) (LBLOCKz-1)) 6));
               temp _h (Vint (nthi (Round regs (nthi b) (LBLOCKz-1)) 7));
               gvar  _K256 kv; lvar _X (tarray tuint LBLOCKz) Xv)
   SEP ( K_vector kv;
           data_at Tsh (tarray tuint LBLOCKz) (map Vint b) Xv))
  block_data_order_loop2
  (normal_ret_assert
    (PROP ()
     LOCAL(temp _ctx ctx;
                temp _a (Vint (nthi (Round regs (nthi b) 63) 0));
                temp _b (Vint (nthi (Round regs (nthi b) 63) 1));
                temp _c (Vint (nthi (Round regs (nthi b) 63) 2));
                temp _d (Vint (nthi (Round regs (nthi b) 63) 3));
                temp _e (Vint (nthi (Round regs (nthi b) 63) 4));
                temp _f (Vint (nthi (Round regs (nthi b) 63) 5));
                temp _g (Vint (nthi (Round regs (nthi b) 63) 6));
                temp _h (Vint (nthi (Round regs (nthi b) 63) 7));
                gvar  _K256 kv; lvar _X (tarray tuint LBLOCKz) Xv)
     SEP (K_vector kv;
            data_at_ Tsh (tarray tuint LBLOCKz) Xv))).
Proof.
intros.
unfold Delta_loop1.
unfold block_data_order_loop2; simpl nth.
rewrite semax_skip_seq.
match goal with
 | |- context [Ssequence ?s1 (Sloop (Ssequence (Sifthenelse ?e Sskip Sbreak) ?s2) ?s3)] =>
      fold (Sfor s1 e s2 s3)
 end.
abbreviate_semax.
change 16%nat with LBLOCK.

forward_for_simple_bound 64%Z
   (EX i:Z,
    PROP ((16 <= i)%Z )
    LOCAL  (temp _ctx ctx;
                  temp _a (Vint (nthi (Round regs (nthi b) (i - 1)) 0));
                  temp _b (Vint (nthi (Round regs (nthi b) (i - 1)) 1));
                  temp _c (Vint (nthi (Round regs (nthi b) (i - 1)) 2));
                  temp _d (Vint (nthi (Round regs (nthi b) (i - 1)) 3));
                  temp _e (Vint (nthi (Round regs (nthi b) (i - 1)) 4));
                  temp _f (Vint (nthi (Round regs (nthi b) (i - 1)) 5));
                  temp _g (Vint (nthi (Round regs (nthi b) (i - 1)) 6));
                  temp _h (Vint (nthi (Round regs (nthi b) (i - 1)) 7));
                  lvar _X (tarray tuint LBLOCKz) Xv;
                  gvar  _K256 kv)
     SEP (K_vector kv;
       data_at Tsh (tarray tuint LBLOCKz) (map Vint (Xarray b (Z.to_nat i))) Xv)).
*
forward. (* skip; *)
Exists 16.
entailer!.
rewrite Xarray_simpl; auto.
apply Zlength_length in H; auto.
*
Intros.
destruct H0 as [_ H2].
assert (H0: LBLOCKz <= i < 64) by (change LBLOCKz with 16%Z; omega).
clear H2 H1.
assert (H': length b = 16%nat) by (apply Zlength_length in H; auto).
assert (LBE := LBLOCK_zeq).
change LBLOCKz with 16%Z in H0.
change (tarray tuint LBLOCKz) with (tarray tuint 16).
change LBLOCKz with 16%Z in H.
forward.	(*s0 = X[(i+1)&0x0f]; *)
autorewrite with sublist. rewrite Zland_15.
forward. (* s0 = sigma0(s0); *)
rewrite extract_from_b by auto; rewrite Int.and_mone; rewrite <- sigma_0_eq.

forward. (* s1 = X[(i+14)&0x0f]; *)
autorewrite with sublist. rewrite Zland_15.

forward. (* s1 = sigma1(s1); *)
rewrite extract_from_b by auto; rewrite Int.and_mone; rewrite <- sigma_1_eq.

forward. (* T1 = X[i&0xf]; *)
autorewrite with sublist. rewrite Zland_15.
replace (nthi (Xarray b (Z.to_nat i)) (i mod 16))
  with (W (nthi b) (i - 16 + 0))
 by (replace (i mod 16) with ((i + 0) mod 16)
        by (rewrite Z.add_0_r; auto);
      rewrite extract_from_b; try omega; auto).

forward. (* t = X[(i+9)&0xf]; *)
autorewrite with sublist. rewrite Zland_15.
rewrite extract_from_b by (try assumption; try omega).

forward.  (* T1 += s0 + s1 + t; *)
pattern (i-16) at 1; rewrite <- (Z.add_0_r (i - 16)).
rewrite <- (W_unfold i b) by auto.

forward. (* X[i&0xf] = T1; *)
rewrite Zland_15.
rewrite Xarray_update by assumption.
unfold K_vector.
change CBLOCKz with 64%Z.
assert (LEN: Zlength K256 = 64%Z) by reflexivity.
forward.  (* Ki=K256[i]; *)
autorewrite with sublist.
rename b into bb.
assert (Hregs' := length_Round _ (nthi bb) (i-1) Hregs).
remember (Round regs (nthi bb) (i - 1)) as regs' eqn:H1.
(destruct regs' as [ | a [ | b [ | c [ | d [ | e [ | f [ | g [ | h [ | ]]]]]]]]];
  try now inversion Hregs'); [ clear Hregs' ].
change (nthi [a;b;c;d;e;f;g;h]) with (fun t => nth (Z.to_nat t) [a;b;c;d;e;f;g;h] Int.zero);
  cbv beta; simpl nth.
forward. (* T1 += h + Sigma1(e) + Ch(e,f,g) + Ki; *)
rewrite <- Sigma_1_eq, <- Ch_eq.
forward. 	(* T2 = Sigma0(a) + Maj(a,b,c); *)
rewrite <- Sigma_0_eq, <- Maj_eq.
repeat forward.
rewrite Z.add_simpl_r.
rewrite Z2Nat.inj_add by omega.
entailer!.
clear - H H0 H1.
rewrite Round_equation.
forget (W (nthi bb) i) as Wbbi.
rewrite if_false by omega.
rewrite <- H1; clear H1.
unfold rnd_function, nthi; simpl.
repeat split; try reflexivity.
 +
  repable_signed.
 +
  f_equal.
  rewrite <- Int.add_assoc; symmetry; rewrite <- Int.add_assoc.
  f_equal. f_equal.
  rewrite Int.add_commut. rewrite !Int.add_assoc. reflexivity.
 +
  f_equal. f_equal. rewrite Int.add_commut. f_equal.
*
 entailer!.
Qed.


Require Export SystemFR.ReducibilitySubtype.
Require Export SystemFR.ScalaDepSugar.

Opaque reducible_values.

Lemma subtype_top:
  forall ρ T,
    valid_interpretation ρ ->
    [ ρ ⊨ T <: T_top ].
Proof.
  repeat step || simp_red;
  eauto using reducible_values_closed.
Qed.

Lemma open_subtop_helper:
  forall Θ Γ T,
    [ Θ; Γ ⊨ T <: T_top ].
Proof.
  unfold open_subtype; intros; eauto using subtype_top.
Qed.

Lemma open_subtop:
  forall Γ T,
    [ Γ ⊫ T <: T_top ].
Proof.
  eauto using open_subtop_helper.
Qed.

Lemma open_subrefl:
  forall Γ T,
    [ Γ ⊫ T <: T ].
Proof.
  eauto using open_subtype_refl.
Qed.

Lemma subsing1:
  forall ρ T t,
    [ ρ ⊨ T_singleton T t <: T ].
Proof.
  unfold T_singleton; repeat step || simp_red.
Qed.

Opaque T_singleton. (* for open_subsing1 *)

Lemma open_subsing1:
  forall Θ Γ T t,
    [ Θ; Γ ⊨ T_singleton T t <: T ].
Proof.
  unfold open_subtype; intros; eapply subsing1;
    repeat step || rewrite substitute_singleton in * by eauto with wf;
    eauto.
Qed.

Lemma open_subsing_helper:
  forall Θ Γ T1 T2 t,
    [ Θ; Γ ⊨ T1 <: T2 ] ->
    [ Θ; Γ ⊨ T_singleton T1 t <: T2 ].
Proof.
  eauto using open_subsing1, open_subtype_trans.
Qed.

Lemma open_subsing:
  forall Γ T1 T2 t,
    [ Γ ⊫ T1 <: T2 ] ->
    [ Γ ⊫ T_singleton T1 t <: T2 ].
Proof.
  eauto using open_subsing_helper.
Qed.


(** * The properties TS, TtS and StT, StTt

of quadruples of operations T, Tt, S, St.

By Vladimir Voevodsky, started on Jan. 10, 2015 *)

Unset Automatic Introduction.

Require Export lBsystems.T_Tt .
Require Export lBsystems.S_St .

(** Mixed properties of domains of definitions of operations T, Tt, S, St *)

Lemma S_T_dom_comp { BB : lBsystem_carrier }
       { r : Tilde BB } { X1 X2 : BB }
       ( innr1 : S_dom r X1 ) ( inn12 : T_dom X1 X2 ) : S_dom r X2 .
Proof .
  intros .
  unfold S_dom in * .
  exact ( isabov_trans ( T_dom_isabove inn12 ) ( isover_ft' innr1 ) ) .

Defined.

Definition  S_Tt_dom_comp { BB : lBsystem_carrier }
           { r s : Tilde BB } { X1 : BB }
           ( innr1 : S_dom r X1 ) ( inn1s : Tt_dom X1 s ) : St_dom r s .
Proof .
  intros .
  exact ( S_T_dom_comp innr1 inn1s ) .

Defined.

Definition  Tt_S_dom_comp { BB : lBsystem_carrier }
           { r : Tilde BB } { X1 X2 : BB }
           ( inn1r : Tt_dom X1 r ) ( innr2 : S_dom r X2 ) : T_dom X1 X2 .
Proof .
  intros .
  refine ( T_dom_constr _ _ ) .
  exact ( T_dom_gt0 inn1r ) .

  exact ( isabove_trans innr2 ( T_dom_isabove inn1r ) ) .

Defined.

Definition Tt_St_dom_comp { BB : lBsystem_carrier }
           { r s : Tilde BB } { X1 : BB }
           ( inn1r : Tt_dom X1 r ) ( innrs : St_dom r s ) : Tt_dom X1 s .
Proof .
  intros .
  exact ( Tt_S_dom_comp inn1r innrs ) .

Defined.

(** Implications of the zeros and first properties of operations of type T, Tt, S and St
that are required for the formulation of the property TS and TtS. *)

Lemma T_dom_r1_12_to_Sr1_Sr2 { BB : lBsystem_carrier }
      { S : S_ops_type BB } ( Sax0 : S_ax0_type S ) ( Sax1a : S_ax1a_type S )
      ( Sax1b : S_ax1b_type S )
      { r : Tilde BB } { X1 X2 : BB }
      ( innr1 : S_dom r X1 ) ( inn12 : T_dom X1 X2 ) :
  T_dom ( S r X1 innr1 ) ( S r X2 ( S_T_dom_comp innr1 inn12 ) ) .
Proof.
  intros .
  refine ( T_dom_constr _ _ ) .
  rewrite Sax0 .
  exact ( minusgth0 _ _ ( S_dom_gt1 innr1 ) ) .

  destruct ( isabove_choice innr1 ) as [ isab | iseq ] .
  rewrite ( Sax1a _ _ innr1 isab ) .
  exact ( isabove_S_S_2 Sax0 Sax1a _ _ ( T_dom_isabove inn12 ) ) .

  rewrite ( ft_S Sax0 Sax1b ( ! iseq ) _ ) .
  exact ( Sax1b _ _ _ ) .

Defined.

Lemma Tt_dom_r1_1s_to_Sr1_Strs { BB : lBsystem_carrier }
      { S : S_ops_type BB } ( Sax0 : S_ax0_type S ) ( Sax1a : S_ax1a_type S )
      ( Sax1b : S_ax1b_type S )
      { St : St_ops_type BB } ( Stax1 : St_ax1_type S St )
      { r s : Tilde BB } { X1 : BB }
      ( innr1 : S_dom r X1 ) ( inn1s : Tt_dom X1 s ) :
  Tt_dom ( S r X1 innr1 ) ( St r s ( S_Tt_dom_comp innr1 inn1s ) ) .
Proof.
  intros .
  unfold Tt_dom .
  rewrite Stax1 .
  exact ( T_dom_r1_12_to_Sr1_Sr2 Sax0 Sax1a Sax1b _ _ ) .

Defined.

Lemma  S_dom_r1_12_to_r_T12 { BB : lBsystem_carrier }
       { T : T_ops_type BB } ( Tax1b : T_ax1b_type T )
       { r : Tilde BB } { X1 X2 : BB }
       ( innr1 : S_dom r X1 ) ( inn : T_dom X1 X2 ) :
  S_dom r ( T X1 X2 inn ) .
Proof .
  intros .
  unfold S_dom .
  exact ( isabove_trans ( Tax1b _ _ inn ) innr1 ) .

Defined.

Lemma St_dom_r1_1s_to_r_Tt1s { BB : lBsystem_carrier }
      { T : T_ops_type BB } ( Tax1b : T_ax1b_type T )
      { Tt : Tt_ops_type BB } ( Ttax1 : Tt_ax1_type T Tt )
      { r s : Tilde BB } { X1 : BB }
      ( innr1 : S_dom r X1 ) ( inn1s : Tt_dom X1 s ) :
  St_dom r ( Tt X1 s inn1s ) .
Proof .
  intros .
  unfold St_dom .
  rewrite Ttax1 .
  exact ( S_dom_r1_12_to_r_T12 Tax1b innr1 inn1s ) .

Defined.

(** Property TS *)

Definition TS_type { BB : lBsystem_carrier }
           { T : T_ops_type BB } ( Tax1b : T_ax1b_type T )
           { S : S_ops_type BB } ( Sax0 : S_ax0_type S ) ( Sax1a : S_ax1a_type S )
           ( Sax1b : S_ax1b_type S ) :=
  forall ( r : Tilde BB ) ( X1 X2 : BB ) ( innr1 : S_dom r X1 ) ( inn12 : T_dom X1 X2 ) ,
    T ( S r X1 innr1 ) ( S r X2 ( S_T_dom_comp innr1 inn12 ) )
      ( T_dom_r1_12_to_Sr1_Sr2 Sax0 Sax1a Sax1b innr1 inn12 ) =
    S r ( T X1 X2 inn12 ) ( S_dom_r1_12_to_r_T12 Tax1b innr1 inn12 ) .
Identity Coercion TS_to_Fun: TS_type >-> Funclass .

(** Property TtS *)

Definition TtS_type { BB : lBsystem_carrier }
           { T : T_ops_type BB } ( Tax1b : T_ax1b_type T )
           { Tt : Tt_ops_type BB } ( Ttax1 : Tt_ax1_type T Tt )
           { S : S_ops_type BB } ( Sax0 : S_ax0_type S ) ( Sax1a : S_ax1a_type S )
           ( Sax1b : S_ax1b_type S )
           { St : St_ops_type BB } ( Stax1 : St_ax1_type S St ) :=
  forall ( r s : Tilde BB ) ( X1 : BB ) ( innr1 : S_dom r X1 ) ( inn1s : Tt_dom X1 s ) ,
    Tt ( S r X1 innr1 ) ( St r s ( S_Tt_dom_comp innr1 inn1s ) )
       ( Tt_dom_r1_1s_to_Sr1_Strs Sax0 Sax1a Sax1b Stax1 innr1 inn1s ) =
    St r ( Tt X1 s inn1s ) ( St_dom_r1_1s_to_r_Tt1s Tax1b Ttax1 innr1 inn1s ) .
Identity Coercion TtS_to_Fun: TtS_type >-> Funclass .

(** Implications of the zeros and first properties of operations of type T, Tt, S and St
that are required for the formulation of the property STt and StTt. *)

Lemma S_dom_1r_r2_to_Tt1r_T12 { BB : lBsystem_carrier }
      { T : T_ops_type BB } ( Tax0 : T_ax0_type T ) ( Tax1a : T_ax1a_type T )
      { Tt : Tt_ops_type BB } ( Ttax1 : Tt_ax1_type T Tt )
      { r : Tilde BB } { X1 X2 : BB }
      ( inn1r : Tt_dom X1 r ) ( innr2 : S_dom r X2 ) :
  S_dom ( Tt X1 r inn1r ) ( T X1 X2 ( Tt_S_dom_comp inn1r innr2 ) ) .
Proof .
  intros .
  unfold S_dom .
  rewrite Ttax1 .
  exact ( isabove_T_T_2 Tax0 Tax1a _ _ innr2 ) .

Defined.

Lemma St_dom_1r_rs_to_Tt1r_Tt1s { BB : lBsystem_carrier }
      { T : T_ops_type BB } ( Tax0 : T_ax0_type T ) ( Tax1a : T_ax1a_type T )
      { Tt : Tt_ops_type BB } ( Ttax1 : Tt_ax1_type T Tt )
      { r s : Tilde BB } { X1 : BB }
      ( inn1r : Tt_dom X1 r ) ( innrs : St_dom r s ) :
  St_dom ( Tt X1 r inn1r ) ( Tt X1 s ( Tt_St_dom_comp inn1r innrs ) ) .
Proof.
  intros .
  unfold St_dom .
  rewrite Ttax1 .
  exact ( S_dom_1r_r2_to_Tt1r_T12 Tax0 Tax1a Ttax1 _ _ ) .

Defined.

Lemma  T_dom_1r_r2_to_1_Sr2 { BB : lBsystem_carrier }
       { S : S_ops_type BB } ( Sax1b : S_ax1b_type S )
       { r : Tilde BB } { X1 X2 : BB }
       ( inn1r : Tt_dom X1 r ) ( innr2 : S_dom r X2 ) : T_dom X1 ( S r X2 innr2 ) .
Proof.
  intros .
  refine ( T_dom_constr _ _ ) .
  exact ( T_dom_gt0 inn1r ) .

  exact ( isabov_trans ( Sax1b _ _ _ ) ( isover_ft' ( T_dom_isabove inn1r ) ) ) .

Defined.

Lemma  Tt_dom_1r_rs_to_1_Strs { BB : lBsystem_carrier }
       { S : S_ops_type BB } ( Sax1b : S_ax1b_type S )
       { St : St_ops_type BB } ( Stax1 : St_ax1_type S St )
       { r s : Tilde BB } { X1 : BB }
       ( inn1r : Tt_dom X1 r ) ( innrs : St_dom r s ) : Tt_dom X1 ( St r s innrs )  .
Proof .
  intros .
  unfold Tt_dom .
  rewrite Stax1 .
  exact ( T_dom_1r_r2_to_1_Sr2 Sax1b inn1r _ ) .

Defined.

(** Property STt *)

Definition STt_type { BB : lBsystem_carrier }
           { T : T_ops_type BB } ( Tax0 : T_ax0_type T ) ( Tax1a : T_ax1a_type T )
           { Tt : Tt_ops_type BB } ( Ttax1 : Tt_ax1_type T Tt )
           { S : S_ops_type BB } ( Sax1b : S_ax1b_type S ) :=
  forall ( r : Tilde BB ) ( X1 X2 : BB ) ( inn1r : Tt_dom X1 r ) ( innr2 : S_dom r X2 ) ,
    S ( Tt X1 r inn1r ) ( T X1 X2 ( Tt_S_dom_comp inn1r innr2 ) )
      ( S_dom_1r_r2_to_Tt1r_T12  Tax0 Tax1a Ttax1 inn1r innr2 ) =
    T X1 ( S r X2 innr2 ) ( T_dom_1r_r2_to_1_Sr2 Sax1b inn1r innr2 ) .
Identity Coercion STt_to_Fun: STt_type >-> Funclass .

(** Property StTt *)

Definition StTt_type { BB : lBsystem_carrier }
           { T : T_ops_type BB } ( Tax0 : T_ax0_type T ) ( Tax1a : T_ax1a_type T )
           { Tt : Tt_ops_type BB } ( Ttax1 : Tt_ax1_type T Tt )
           { S : S_ops_type BB } ( Sax1b : S_ax1b_type S )
           { St : St_ops_type BB } ( Stax1 : St_ax1_type S St ) :=
  forall ( r s : Tilde BB ) ( X1 : BB ) ( inn1r : Tt_dom X1 r ) ( innrs : St_dom r s ) ,
    St ( Tt X1 r inn1r ) ( Tt X1 s ( Tt_St_dom_comp inn1r innrs ) )
       ( St_dom_1r_rs_to_Tt1r_Tt1s Tax0 Tax1a Ttax1 inn1r innrs ) =
    Tt X1 ( St r s innrs ) ( Tt_dom_1r_rs_to_1_Strs Sax1b Stax1 inn1r innrs ) .
Identity Coercion StTt_to_Fun: StTt_type >-> Funclass .

(* End of the file lBsystems_TS_ST.v *)


From Coqprime Require Import PocklingtonRefl.
Local Open Scope positive_scope.

Lemma primo106:
  prime  71824034781593->
  prime  8241884923488954977149597.
Proof.
intro H.
apply (Pocklington_refl
     (Ell_certif
      8241884923488954977149597
      114751071122
      ((71824034781593,1)::nil)
      4120942461744477488574839
      0
      18
      81)
     ((Proof_certif _ H) :: nil)).
native_cast_no_check (refl_equal true).
Time Qed.