Require Export Java.

(* A variable is some defined object (eg. array or number) *)
Inductive var: Set :=
  | Vnone: var
  | Vbool: bool -> var
  | Vnum: jnum -> var
  | Varr: id -> var.

Inductive state: Set :=
  | Scur: (id -> var) -> (id -> option (list var)) -> nat -> state.

(* Definition state := id -> var. *)

Definition state_get (s: state) (i: id): var :=
  match s with
  | Scur user _ _ => user i
  end.

Definition state_get_num (s: state) (i: id): option jnum :=
  match s with
  | Scur user _ _ =>
    match user i with
    | Vnum n => Some n
    | _ => None
    end
  end.

Definition state_get_ptr (s: state) (i: id): option id :=
  match s with
  | Scur user mem _ =>
    match user i with
    | Varr idx => Some idx
    | _ => None
    end
  end.

Definition state_follow_ptr (s: state) (i: id): option (list var) :=
  match s with
  | Scur _ mem _ => mem i
  end.

Definition state_get_arr (s: state) (i: id): option (list var) :=
  match s with
  | Scur user mem _ =>
    match user i with
    | Varr idx => mem idx
    | _ => None
    end
  end.

Inductive aexp: Set :=
| ANum: nat -> aexp
| AId: id -> aexp
| APlus: aexp -> aexp -> aexp
| AMinus: aexp -> aexp -> aexp
| AMult: aexp -> aexp -> aexp
| ADiv: aexp -> aexp -> aexp
| AMod: aexp -> aexp -> aexp
| AOr: aexp -> aexp -> aexp
| AAnd: aexp -> aexp -> aexp
| AXor: aexp -> aexp -> aexp
| ACast: aexp -> nat -> aexp
| ALoad: id -> aexp -> aexp.

Inductive bexp : Type :=
  | BTrue : bexp
  | BFalse : bexp
  | BEq : aexp -> aexp -> bexp
  | BLe : aexp -> aexp -> bexp
  | BNot : bexp -> bexp
  | BAnd : bexp -> bexp -> bexp
  | BOr : bexp -> bexp -> bexp
  | BXor : bexp -> bexp -> bexp
  | BLoad : id -> aexp -> bexp.

Definition aeval_helper (f: jnum -> jnum -> jnum) (l r: option jnum): option jnum :=
  match l, r with
  | Some n1, Some n2 => Some (f n1 n2)
  | _, _ => None
  end.

Definition list_index {T: Type} (l: list T) (n: jnum): option T :=
  match nth_error l (jnum_to_nat n) with
  | Some n => Some n
  | _ => None
  end.

Definition list_insert {T: Type} (l: list T) (n: jnum) (val: T): list T :=
  let n' := jnum_to_nat n in
    (firstn n' l) ++ [val] ++ (skipn (n' + 1) l).

Fixpoint aeval (st: state) (a: aexp): option jnum :=
  match a with
  | ANum n => Some (nat_to_jnum n 8)
  | AId i => state_get_num st i
  | APlus l r => aeval_helper jnum_plus (aeval st l) (aeval st r)
  | AMinus l r => aeval_helper jnum_sub (aeval st l) (aeval st r)
  | AMult l r => aeval_helper jnum_mult (aeval st l) (aeval st r)
  | ADiv l r => aeval_helper jnum_div (aeval st l) (aeval st r)
  | AMod l r => aeval_helper jnum_mod (aeval st l) (aeval st r)
  | AOr l r => aeval_helper jnum_orb (aeval st l) (aeval st r)
  | AAnd l r => aeval_helper jnum_andb (aeval st l) (aeval st r)
  | AXor l r => aeval_helper jnum_xorb (aeval st l) (aeval st r)
  | ACast l r =>
    match (aeval st l) with
    | Some n => Some (jnum_promote n r)
    | None => None
    end
  | ALoad i a' =>
    match (state_get_arr st i), (aeval st a') with
    | Some arr, Some n =>
      match list_index arr n with
      | Some (Vnum n') => Some n'
      | _ => None
      end
    | _, _ => None
    end
  end.

Definition beval_helper (f: jnum -> jnum -> bool) (l r: option jnum): option bool :=
  match l, r with
  | Some n1, Some n2 => Some (f n1 n2)
  | _, _ => None
  end.

Definition beval_helper2 (f: bool -> bool -> bool) (l r: option bool): option bool :=
  match l, r with
  | Some n1, Some n2 => Some (f n1 n2)
  | _, _ => None
  end.

Fixpoint beval (st: state) (b : bexp) : option bool :=
  match b with
  | BTrue       => Some true
  | BFalse      => Some false
  | BEq a1 a2   => beval_helper jnum_eq (aeval st a1) (aeval st a2)
  | BLe a1 a2   => beval_helper jnum_leq (aeval st a1) (aeval st a2)
  | BNot b1     =>
    match (beval st b1) with
    | Some b' => Some (negb b')
    | _ => None
    end
  | BAnd b1 b2  => beval_helper2 andb (beval st b1) (beval st b2)
  | BOr b1 b2  => beval_helper2 orb (beval st b1) (beval st b2)
  | BXor b1 b2  => beval_helper2 xorb (beval st b1) (beval st b2)
  | BLoad i a' =>
    match (state_get_arr st i), (aeval st a') with
    | Some arr, Some n =>
      match list_index arr n with
      | Some (Vbool n') => Some n'
      | _ => None
      end
    | _, _ => None
    end
  end.

Definition Aeval (a: aexp): state -> var :=
  fun st =>
    match aeval st a with
    | Some n => Vnum n
    | None => Vnone
    end.

Definition Beval (a: bexp): state -> var :=
  fun st =>
    match beval st a with
    | Some n => Vbool n
    | None => Vnone
    end.

Definition Assertion := state -> Prop.

Definition assert_implies (P Q : Assertion) : Prop :=
  forall st, P st -> Q st.

Notation "P ->> Q" :=
  (assert_implies P Q) (at level 80) : hoare_spec_scope.
Open Scope hoare_spec_scope.

Notation "P <<->> Q" :=
  (P ->> Q /\ Q ->> P) (at level 80) : hoare_spec_scope.

Definition bassn b : Assertion :=
  fun st => (beval st b = Some true).

Lemma bexp_eval_true : forall b st,
  beval st b = Some true -> (bassn b) st.
Proof.
  intros b st Hbe.
  unfold bassn. assumption.  Qed.

Lemma bexp_eval_false : forall b st,
  beval st b = Some false -> ~ ((bassn b) st).
Proof.
  intros b st Hbe contra.
  unfold bassn in contra.
  rewrite -> contra in Hbe. inversion Hbe.  Qed.

Definition update (st : state) (x : id) (v : state -> var) : state :=
  match st with
  | Scur user mem n => Scur (fun x' => if eq_id_dec x x' then v st else user x') mem n
  end.

Definition assn_sub X v P : Assertion :=
  fun (st : state) =>
    P (update st X v).

Definition update_mem (st : state) (x : id) (v : option (list var)) : state :=
  match st with
  | Scur user mem n => Scur user (fun x' => if eq_id_dec x x' then v else mem x') n
  end.

Definition update_arr (st : state) (x : id) (idx: aexp) (v: state -> var) : state :=
  let ptr := state_get_ptr st x in
    match st, ptr, aeval st idx with
    | Scur user mem n, Some ptr', Some idx' =>
      match state_follow_ptr st ptr' with
      | Some arr => update_mem st ptr' (Some (list_insert arr idx' (v st)))
      | _ => st
      end
    | _, _, _ => st
    end.

Definition store_sub X idx v P : Assertion :=
  fun (st : state) =>
    P (update_arr st X idx v).

(*Definition store_sub X idx v P : Assertion :=
  fun (st : state) =>
    let ptr := state_get_ptr st X in
      match ptr, (aeval st idx) with
      | Some ptr', Some idx' =>
        match state_follow_ptr st ptr' with
        | Some arr => P (update_mem st ptr' (Some (list_insert arr idx' v)))
        | _ => True
        end
      | _, _ => True
      end.*)

Notation "P [ X |-> v ]" := (assn_sub X v P) (at level 10).
Notation "P [ X <-| idx |-> v ]" := (store_sub X idx v P) (at level 10).

Inductive com : Type :=
  | CSkip : com
  | CStore : id -> aexp -> (state -> var) -> com
  | CAss : id -> (state -> var) -> com
  | CSeq : com -> com -> com
  | CIf : bexp -> com -> com -> com
  | CWhile : bexp -> com -> com.

Notation "'SKIP'" :=
  CSkip.
Notation "x '::=' a" :=
  (CAss x a) (at level 60).
Notation "c1 ;; c2" :=
  (CSeq c1 c2) (at level 80, right associativity).
Notation "'WHILE' b 'DO' c 'END'" :=
  (CWhile b c) (at level 80, right associativity).
Notation "'IFB' c1 'THEN' c2 'ELSE' c3 'FI'" :=
  (CIf c1 c2 c3) (at level 80, right associativity).

Reserved Notation "c1 '/' st '||' st'" (at level 40, st at level 39).

Inductive ceval : com -> state -> state -> Prop :=
  | E_Skip : forall st,
      SKIP / st || st
  | E_Store  : forall st a1 x idx,
      (CStore x idx a1) / st || (update_arr st x idx a1)
  | E_Ass  : forall st a1 x,
      (x ::= a1) / st || (update st x a1)
  | E_Seq : forall c1 c2 st st' st'',
      c1 / st  || st' ->
      c2 / st' || st'' ->
      (c1 ;; c2) / st || st''
  | E_IfTrue : forall st st' b c1 c2,
      beval st b = Some true ->
      c1 / st || st' ->
      (IFB b THEN c1 ELSE c2 FI) / st || st'
  | E_IfFalse : forall st st' b c1 c2,
      beval st b = Some false ->
      c2 / st || st' ->
      (IFB b THEN c1 ELSE c2 FI) / st || st'
  | E_WhileEnd : forall b st c,
      beval st b = Some false ->
      (WHILE b DO c END) / st || st
  | E_WhileLoop : forall st st' st'' b c,
      beval st b = Some true ->
      c / st || st' ->
      (WHILE b DO c END) / st' || st'' ->
      (WHILE b DO c END) / st || st''

  where "c1 '/' st '||' st'" := (ceval c1 st st').

Tactic Notation "ceval_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "E_Skip" | Case_aux c "E_Ass" | Case_aux c "E_Store" | Case_aux c "E_Seq"
  | Case_aux c "E_IfTrue" | Case_aux c "E_IfFalse"
  | Case_aux c "E_WhileEnd" | Case_aux c "E_WhileLoop" ].

Definition hoare_triple
           (P:Assertion) (c:com) (Q:Assertion) : Prop :=
  forall st st',
       c / st || st'  ->
       P st  ->
       Q st'.

Notation "{{ P }}  c  {{ Q }}" :=
  (hoare_triple P c Q) (at level 90, c at next level)
  : hoare_spec_scope.

Theorem hoare_store : forall Q X idx a,
  {{Q [X <-| idx |-> a]}} (CStore X idx a) {{Q}}.
Proof.
  unfold hoare_triple.
  intros Q X idx a st st' HE HQ.
  inversion HE. subst.
  unfold store_sub in HQ. assumption.  Qed.

Theorem hoare_asgn : forall Q X a,
  {{Q [X |-> a]}} (X ::= a) {{Q}}.
Proof.
  unfold hoare_triple.
  intros Q X a st st' HE HQ.
  inversion HE. subst.
  unfold assn_sub in HQ. assumption.  Qed.

Theorem hoare_consequence_pre : forall (P P' Q : Assertion) c,
  {{P'}} c {{Q}} ->
  P ->> P' ->
  {{P}} c {{Q}}.
Proof.
  intros P P' Q c Hhoare Himp.
  intros st st' Hc HP. apply (Hhoare st st').
  assumption. apply Himp. assumption. Qed.

Theorem hoare_consequence_post : forall (P Q Q' : Assertion) c,
  {{P}} c {{Q'}} ->
  Q' ->> Q ->
  {{P}} c {{Q}}.
Proof.
  intros P Q Q' c Hhoare Himp.
  intros st st' Hc HP.
  apply Himp.
  apply (Hhoare st st').
  assumption. assumption. Qed.

Theorem hoare_skip : forall P,
     {{P}} SKIP {{P}}.
Proof.
  intros P st st' H HP. inversion H. subst.
  assumption.  Qed.

Theorem hoare_seq : forall P Q R c1 c2,
     {{Q}} c2 {{R}} ->
     {{P}} c1 {{Q}} ->
     {{P}} c1;;c2 {{R}}.
Proof.
  intros P Q R c1 c2 H1 H2 st st' H12 Pre.
  inversion H12; subst.
  apply (H1 st'0 st'); try assumption.
  apply (H2 st st'0); assumption. Qed.

Theorem hoare_if : forall P Q b c1 c2,
  {{fun st => P st /\ bassn b st}} c1 {{Q}} ->
  {{fun st => P st /\ ~(bassn b st)}} c2 {{Q}} ->
  {{P}} (IFB b THEN c1 ELSE c2 FI) {{Q}}.
Proof.
  intros P Q b c1 c2 HTrue HFalse st st' HE HP.
  inversion HE; subst.
  Case "b is true".
    apply (HTrue st st').
      assumption.
      split. assumption.
             apply bexp_eval_true. assumption.
  Case "b is false".
    apply (HFalse st st').
      assumption.
      split. assumption.
             apply bexp_eval_false. assumption. Qed.

Lemma hoare_while : forall P b c,
  {{fun st => P st /\ bassn b st}} c {{P}} ->
  {{P}} WHILE b DO c END {{fun st => P st /\ ~ (bassn b st)}}.
Proof.
  intros P b c Hhoare st st' He HP.
  (* Like we've seen before, we need to reason by induction
     on [He], because, in the "keep looping" case, its hypotheses
     talk about the whole loop instead of just [c]. *)
  remember (WHILE b DO c END) as wcom eqn:Heqwcom.
  ceval_cases (induction He) Case;
    try (inversion Heqwcom); subst; clear Heqwcom.
  Case "E_WhileEnd".
    split. assumption. apply bexp_eval_false. assumption.
  Case "E_WhileLoop".
    apply IHHe2. reflexivity.
    apply (Hhoare st st'). assumption.
      split. assumption. apply bexp_eval_true. assumption.
Qed.

Inductive dcom : Type :=
  | DCSkip :  Assertion -> dcom
  | DCSeq : dcom -> dcom -> dcom
  | DCStore : id -> aexp -> (state -> var) -> Assertion -> dcom
  | DCAsgn : id -> (state -> var) ->  Assertion -> dcom
  | DCIf : bexp ->  Assertion -> dcom ->  Assertion -> dcom
           -> Assertion-> dcom
  | DCWhile : bexp -> Assertion -> dcom -> Assertion -> dcom
  | DCPre : Assertion -> dcom -> dcom
  | DCPost : dcom -> Assertion -> dcom.

Tactic Notation "dcom_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "Skip" | Case_aux c "Seq" | Case_aux c "Store" | Case_aux c "Asgn"
  | Case_aux c "If" | Case_aux c "While"
  | Case_aux c "Pre" | Case_aux c "Post" ].

Notation "'SKIP' {{ P }}"
      := (DCSkip P)
      (at level 10) : dcom_scope.
Notation "l '::=' a {{ P }}"
      := (DCAsgn l a P)
      (at level 60, a at next level) : dcom_scope.
Notation "'WHILE' b 'DO' {{ Pbody }} d 'END' {{ Ppost }}"
      := (DCWhile b Pbody d Ppost)
      (at level 80, right associativity) : dcom_scope.
Notation "'IFB' b 'THEN' {{ P }} d 'ELSE' {{ P' }} d' 'FI' {{ Q }}"
      := (DCIf b P d P' d' Q)
      (at level 80, right associativity)  : dcom_scope.
Notation "'->>' {{ P }} d"
      := (DCPre P d)
      (at level 90, right associativity)  : dcom_scope.
Notation "{{ P }} d"
      := (DCPre P d)
      (at level 90)  : dcom_scope.
Notation "d '->>' {{ P }}"
      := (DCPost d P)
      (at level 80, right associativity)  : dcom_scope.
Notation " d ;; d' "
      := (DCSeq d d')
      (at level 80, right associativity)  : dcom_scope.

Delimit Scope dcom_scope with dcom.

Fixpoint extract (d:dcom) : com :=
  match d with
  | DCSkip _           => SKIP
  | DCSeq d1 d2        => (extract d1 ;; extract d2)
  | DCStore X idx a _  => (CStore X idx a)
  | DCAsgn X a _       => X ::= a
  | DCIf b _ d1 _ d2 _ => IFB b THEN extract d1 ELSE extract d2 FI
  | DCWhile b _ d _    => WHILE b DO extract d END
  | DCPre _ d          => extract d
  | DCPost d _         => extract d
  end.

Fixpoint post (d:dcom) : Assertion :=
  match d with
  | DCSkip P                => P
  | DCSeq d1 d2             => post d2
  | DCStore X idx v Q       => Q
  | DCAsgn X v Q            => Q
  | DCIf  _ _ d1 _ d2 Q     => Q
  | DCWhile b Pbody c Ppost => Ppost
  | DCPre _ d               => post d
  | DCPost c Q              => Q
  end.

Fixpoint pre (d:dcom) : Assertion :=
  match d with
  | DCSkip P                => fun st => True
  | DCSeq c1 c2             => pre c1
  | DCStore X idx v Q       => fun st => True
  | DCAsgn X a Q            => fun st => True
  | DCIf  _ _ t _ e _       => fun st => True
  | DCWhile b Pbody c Ppost => fun st => True
  | DCPre P c               => P
  | DCPost c Q              => pre c
  end.

Fixpoint verification_conditions (P : Assertion) (d:dcom) : Prop :=
  match d with
  | DCSkip Q          =>
      (P ->> Q)
  | DCSeq d1 d2      =>
      verification_conditions P d1
      /\ verification_conditions (post d1) d2
  | DCStore X idx v Q      =>
      (P ->> Q [X <-| idx |-> v])
  | DCAsgn X a Q      =>
      (P ->> Q [X |-> a])
  | DCIf b P1 d1 P2 d2 Q =>
      ((fun st => P st /\ bassn b st) ->> P1)
      /\ ((fun st => P st /\ ~ (bassn b st)) ->> P2)
      /\ (Q <<->> post d1) /\ (Q <<->> post d2)
      /\ verification_conditions P1 d1
      /\ verification_conditions P2 d2
  | DCWhile b Pbody d Ppost      =>
      (* post d is the loop invariant and the initial precondition *)
      (P ->> post d)
      /\ (Pbody <<->> (fun st => post d st /\ bassn b st))
      /\ (Ppost <<->> (fun st => post d st /\ ~(bassn b st)))
      /\ verification_conditions Pbody d
  | DCPre P' d         =>
      (P ->> P') /\ verification_conditions P' d
  | DCPost d Q        =>
      verification_conditions P d /\ (post d ->> Q)
  end.

Theorem verification_correct : forall d P,
  verification_conditions P d -> {{P}} (extract d) {{post d}}.
Proof.
  dcom_cases (induction d) Case; intros P H; simpl in *.
  Case "Skip".
    eapply hoare_consequence_pre.
      apply hoare_skip.
      assumption.
  Case "Seq".
    inversion H as [H1 H2]. clear H.
    eapply hoare_seq.
      apply IHd2. apply H2.
      apply IHd1. apply H1.
  Case "Store".
    eapply hoare_consequence_pre.
      apply hoare_store.

      assumption.
  Case "Asgn".
    eapply hoare_consequence_pre.
      apply hoare_asgn.
      assumption.
  Case "If".
    inversion H as [HPre1 [HPre2 [[Hd11 Hd12]
                                  [[Hd21 Hd22] [HThen HElse]]]]].
    clear H.
    apply IHd1 in HThen. clear IHd1.
    apply IHd2 in HElse. clear IHd2.
    apply hoare_if.
      eapply hoare_consequence_pre; eauto.
      eapply hoare_consequence_post; eauto.
      eapply hoare_consequence_pre; eauto.
      eapply hoare_consequence_post; eauto.
  Case "While".
    inversion H as [Hpre [[Hbody1 Hbody2] [[Hpost1 Hpost2]  Hd]]];
    subst; clear H.
    eapply hoare_consequence_pre; eauto.
    eapply hoare_consequence_post; eauto.
    apply hoare_while.
    eapply hoare_consequence_pre; eauto.
  Case "Pre".
    inversion H as [HP Hd]; clear H.
    eapply hoare_consequence_pre. apply IHd. apply Hd. assumption.
  Case "Post".
    inversion H as [Hd HQ]; clear H.
    eapply hoare_consequence_post. apply IHd. apply Hd. assumption.
Qed.

Theorem update_eq : forall n x st,
  state_get (update st x n) x = n st.
Proof.
  intros.
  unfold update. unfold state_get.
  destruct st. apply eq_id.
  Qed.
(** [] *)

Theorem update_neq : forall x2 x1 n st,
  x2 <> x1 ->
  state_get (update st x2 n) x1 = (state_get st x1).
Proof.
  intros.
  unfold update. unfold state_get.
  destruct st. apply neq_id.
  apply H.
  Qed.

Lemma ble_nat_true_iff : forall n m : nat,
  ble_nat n m = true <-> n <= m.
Proof.
  intros n m. split. apply ble_nat_true.
  generalize dependent m. induction n; intros m H. reflexivity.
    simpl. destruct m. inversion H.
    apply le_S_n in H. apply IHn. assumption.
Qed.

Lemma ble_nat_false_iff : forall n m : nat,
  ble_nat n m = false <-> ~(n <= m).
Proof.
  intros n m. split. apply ble_nat_false.
  generalize dependent m. induction n; intros m H.
    apply ex_falso_quodlibet. apply H. apply le_0_n.
    simpl. destruct m. reflexivity.
    apply IHn. intro Hc. apply H. apply le_n_S. assumption.
Qed.

Tactic Notation "verify" :=
  apply verification_correct;
  repeat split;
  simpl; unfold assert_implies;
  unfold bassn in *; unfold beval in *; unfold aeval in *;
  unfold assn_sub; intros;
  repeat rewrite update_eq;
  repeat (rewrite update_neq; [| (intro X; inversion X)]);
  simpl in *;
  repeat match goal with [H : _ /\ _ |- _] => destruct H end;
  repeat rewrite not_true_iff_false in *;
  repeat rewrite not_false_iff_true in *;
  repeat rewrite negb_true_iff in *;
  repeat rewrite negb_false_iff in *;
  repeat rewrite beq_nat_true_iff in *;
  repeat rewrite beq_nat_false_iff in *;
  repeat rewrite ble_nat_true_iff in *;
  repeat rewrite ble_nat_false_iff in *;
  try subst;
  repeat
    match goal with
      [st : state |- _] =>
        match goal with
          [H : st _ = _ |- _] => rewrite -> H in *; clear H
        | [H : _ = st _ |- _] => rewrite <- H in *; clear H
        end
    end;
  try eauto; try omega.

Definition num (n: nat): var :=
  Vnum (nat_to_jnum n 8).

Definition sum (n1 n2: var): var :=
  match n1, n2 with
  | Vnum n1', Vnum n2' => Vnum (jnum_plus n1' n2')
  | _, _ => Vnone
  end.

Definition sub (n1 n2: var): var :=
  match n1, n2 with
  | Vnum n1', Vnum n2' => Vnum (jnum_sub n1' n2')
  | _, _ => Vnone
  end.

Definition eq (n1 n2: var): var :=
  match n1, n2 with
  | Vnum n1', Vnum n2' => Vbool (jnum_eq n1' n2')
  | _, _ => Vnone
  end.

Definition neq (n1 n2: var): var :=
  match n1, n2 with
  | Vnum n1', Vnum n2' => Vbool (negb (jnum_eq n1' n2'))
  | _, _ => Vnone
  end.

Definition X : id := Id 0.
Definition Y : id := Id 1.
Definition Z : id := Id 2.

Example slow_assignment_dec (m:nat) : dcom := (
      {{ fun st => state_get st X = num m }}
    Y ::= Aeval (ANum 0)
      {{ fun st => state_get st X = num m /\ state_get st Y = num 0 }} ->>
      {{ fun st => sum (state_get st X) (state_get st Y) = num m }} ;;
    WHILE BNot (BEq (AId X) (ANum 0)) DO
        {{ fun st => sum (state_get st X) (state_get st Y) = num m /\ neq (state_get st X) (num 0) = Vbool true }} ->>
        {{ fun st => sum (sub (state_get st X) (num 1)) (sum (state_get st Y) (num 1)) = num m }}
      X ::= Aeval (AMinus (AId X) (ANum 1))
        {{ fun st => sum (state_get st X) (sum (state_get st Y) (num 1)) = num m }} ;;
      Y ::= Aeval (APlus (AId Y) (ANum 1))
        {{ fun st => sum (state_get st X) (state_get st Y) = num m }}
    END
      {{ fun st => sum (state_get st X) (state_get st Y) = num m /\ eq (state_get st X) (num 0) = Vbool true }} ->>
      {{ fun st => state_get st Y = num m }}
) % dcom.

Definition dec_correct (d:dcom) :=
  {{pre d}} (extract d) {{post d}}.

Theorem slow_assignment_dec_correct : forall m,
  dec_correct (slow_assignment_dec m).
Proof. intros m. verify.
  rewrite H. rewrite H0. simpl.


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

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

(**
** Example of a group: $\langle$#⟨#[Z],[[+]]$\rangle$#⟩#
*)

Lemma Z_is_CGroup : is_CGroup Z_as_CMonoid Zopp_is_fun.
Proof.
 red in |- *.
 simpl in |- *.
 intro x.
 split; simpl in |- *.
  apply Zplus_opp_r.
 apply Zplus_opp_l.
Qed.

Definition Z_as_CGroup := Build_CGroup Z_as_CMonoid Zopp_is_fun Z_is_CGroup.

(** The term [Z_as_CGroup] is of type [CGroup]. Hence we have proven that [Z] is a constructive group. *)

Canonical Structure Z_as_CGroup.


Require Import Coq.omega.Omega.
Require Import Examples.PreAutoSep Examples.Wrap Examples.Conditional.

Import DefineStructured.

Set Implicit Arguments.

(** Test expressions over arrays *)

Inductive exp :=
| Const (w : W)
(* Literal word value *)
| Index
(* Position in the array *)
| Value
(* Content of array cell *)
| Var (x : string)
(* Injected value of Bedrock local variable *).

Inductive condition :=
| Test (e1 : exp) (t : test) (e2 : exp)
(* Basic comparison *)
| Not (c1 : condition)
| And (c1 c2 : condition)
| Or (c1 c2 : condition)
(* Boolean operators *).

Coercion Const : W >-> exp.
Coercion Var : string >-> exp.

Notation "x = y" := (Test x IL.Eq y) : ArrayQuery_scope.
Notation "x <> y" := (Test x IL.Ne y) : ArrayQuery_scope.
Notation "x < y" := (Test x IL.Lt y) : ArrayQuery_scope.
Notation "x <= y" := (Test x IL.Le y) : ArrayQuery_scope.
Notation "x > y" := (Test y IL.Lt x) : ArrayQuery_scope.
Notation "x >= y" := (Test y IL.Le x) : ArrayQuery_scope.

Notation "!" := Not : ArrayQuery_scope.
Infix "&&" := And : ArrayQuery_scope.
Infix "||" := Or : ArrayQuery_scope.

Delimit Scope ArrayQuery_scope with ArrayQuery.

Definition eval (vs : vals) (index value : W) (e : exp) : W :=
  match e with
    | Const w => w
    | Index => index
    | Value => value
    | Var x => sel vs x
  end.

Fixpoint satisfies (vs : vals) (index value : W) (c : condition) : Prop :=
  match c with
    | Test e1 t e2 => (evalTest t) (eval vs index value e1) (eval vs index value e2) = true
    | Not c1 => ~satisfies vs index value c1
    | And c1 c2 => satisfies vs index value c1 /\ satisfies vs index value c2
    | Or c1 c2 => satisfies vs index value c1 \/ satisfies vs index value c2
  end.

Section Query.
  Hint Extern 1 (Mem _ = Mem _) =>
    eapply scratchOnlyMem; [ | eassumption ];
      simpl; intuition congruence.
  Hint Extern 1 (Mem _ = Mem _) =>
    symmetry; eapply scratchOnlyMem; [ | eassumption ];
      simpl; intuition congruence.

  Hint Resolve evalInstrs_app sepFormula_Mem.

  Hint Extern 2 (interp ?specs2 (![ _ ] (?stn2, ?st2))) =>
    match goal with
      | [ _ : interp ?specs1 (![ _ ] (?stn1, ?st1)) |- _ ] =>
        solve [ equate specs1 specs2; equate stn1 stn2; equate st1 st2; step auto_ext ]
    end.

  Variable arr : string.
  (* Name of local variable containing an array to query *)
  Variable size : string.
  (* Name of local variable containing the array length in words *)
  Variable index : string.
  (* Name of local variable that, inside the loop, is assigned the current array index *)
  Variable value : string.
  (* Name of local variable that, inside the loop, is assigned the current array cell value *)

  Variable c : condition.
  (* We will loop over only those indices satisfying this condition. *)

  Variable imports : LabelMap.t assert.
  Hypothesis H : importsGlobal imports.
  Variable modName : string.

  Variable quants : Type.
  (* Quantified variables, in scope for both precondition and postcondition *)

  Variable invPre : quants -> list W -> list W -> vals -> qspec.
  (* Precondition part of loop invariant, parameterized over part of array visited already and then whole array *)

  Variable invPost : quants -> list W -> vals -> W -> qspec.
  (* Postcondition part of loop invariant, parameterized over whole array *)

  Variables Body : cmd imports modName.
  (* Code to run on each matching array index *)

  Variable ns : list string.
  (* Local variable names *)
  Variable res : nat.
  (* Reserved stack slots *)

  Definition loopInvariant : assert :=
    st ~> Ex qs, ExX, Ex wsPre, Ex ws, Ex vs, qspecOut (invPre qs wsPre ws (sel vs)) (fun PR =>
      ![ ^[locals ("rp" :: ns) vs res st#Sp * array ws (sel vs arr) * PR] * #0 ] st
      /\ [| sel vs size = length ws /\ sel vs index = length wsPre |]
      /\ Ex wsPost, [| ws = wsPre ++ wsPost |]
      /\ (sel vs "rp", fst st) @@@ (st' ~>
        [| st'#Sp = st#Sp |]
        /\ Ex vs', qspecOut (invPost qs ws (sel vs) st'#Rv) (fun PO =>
          ![ ^[locals ("rp" :: ns) vs' res st#Sp * array ws (sel vs arr) * PO] * #1 ] st'))).

  Definition bodyPre : assert :=
    st ~> Ex qs, Ex wsPre, Ex ws, ExX, Ex vs, qspecOut (invPre qs wsPre ws (sel vs)) (fun PR =>
      ![ ^[locals ("rp" :: ns) vs res st#Sp * array ws (sel vs arr) * PR] * #0 ] st
      /\ [| sel vs size = length ws /\ sel vs index = length wsPre
        /\ satisfies vs (sel vs index) (sel vs value) c |]
      /\ Ex wsPost, [| ws = wsPre ++ sel vs value :: wsPost |]
      /\ (sel vs "rp", fst st) @@@ (st' ~>
        [| st'#Sp = st#Sp |]
        /\ Ex vs', qspecOut (invPost qs ws (sel vs) st'#Rv) (fun PO =>
          ![ ^[locals ("rp" :: ns) vs' res st#Sp * array ws (sel vs arr) * PO] * #1 ] st'))).

  Definition expBound (e : exp) : Prop :=
    match e with
      | Const _ => True
      | Index => True
      | Value => True
      | Var x => In x ns /\ x <> value /\ x <> index
    end.

  Fixpoint conditionBound (c : condition) : Prop :=
    match c with
      | Test e1 _ e2 => expBound e1 /\ expBound e2
      | Not c1 => conditionBound c1
      | And c1 c2 => conditionBound c1 /\ conditionBound c2
      | Or c1 c2 => conditionBound c1 /\ conditionBound c2
    end.

  Definition expOut (e : exp) : rvalue :=
    match e with
      | Const w => w
      | Index => variableSlot index ns
      | Value => variableSlot value ns
      | Var x => variableSlot x ns
    end.

  Fixpoint conditionOut (c : condition) : bexp :=
    match c with
      | Test e1 t e2 => Conditional.Test (expOut e1) t (expOut e2)
      | Not c1 => Conditional.Not (conditionOut c1)
      | And c1 c2 => Conditional.And (conditionOut c1) (conditionOut c2)
      | Or c1 c2 => Conditional.Or (conditionOut c1) (conditionOut c2)
    end.

  Fixpoint indexEquals (c : condition) : option string :=
    match c with
      | Test Index IL.Eq (Var s) => Some s
      | Test _ _ _ => None
      | Not _ => None
      | And c1 c2 => match indexEquals c1 with
                       | None => indexEquals c2
                       | v => v
                     end
      | Or _ _ => None
    end.

  Fixpoint indexGe (c : condition) : option string :=
    match c with
      | Test (Var s) IL.Le Index => Some s
      | Test _ _ _ => None
      | Not _ => None
      | And c1 c2 => match indexGe c1 with
                       | None => indexGe c2
                       | v => v
                     end
      | Or _ _ => None
    end.

  (* Here's the raw command, which we will later wrap with nicer VCs. *)
  Definition Query_ : cmd imports modName :=
    match indexEquals c with
      | None =>
        match indexGe c with
          | None =>
            Seq_ H
            (Straightline_ _ _ (Assign (variableSlot index ns) 0 :: nil))
            (Structured.While_ H loopInvariant (variableSlot index ns) IL.Lt (variableSlot size ns)
              (Seq_ H
                (Straightline_ _ _ (
                  Binop Rv 4 Times (variableSlot index ns)
                  :: Binop Rv (variableSlot arr ns) Plus Rv
                  :: Assign (variableSlot value ns) (LvMem (Reg Rv))
                  :: nil))
                (Seq_ H
                  (Cond_ _ H _ (conditionOut c)
                    (Seq_ H
                      (Structured.Assert_ _ _ bodyPre)
                      Body)
                    (Skip_ _ _))
                  (Straightline_ _ _ (Binop (variableSlot index ns) (variableSlot index ns) Plus 1 :: nil)))))
          | Some b =>
            Structured.If_ H (variableSlot size ns) IL.Le (variableSlot b ns)
            (Skip_ _ _)
            (Seq_ H
              (Straightline_ _ _ (Assign (variableSlot index ns) (variableSlot b ns) :: nil))
              (Structured.While_ H loopInvariant (variableSlot index ns) IL.Lt (variableSlot size ns)
                (Seq_ H
                  (Straightline_ _ _ (
                    Binop Rv 4 Times (variableSlot index ns)
                    :: Binop Rv (variableSlot arr ns) Plus Rv
                    :: Assign (variableSlot value ns) (LvMem (Reg Rv))
                    :: nil))
                  (Seq_ H
                    (Cond_ _ H _ (conditionOut c)
                      (Seq_ H
                        (Structured.Assert_ _ _ bodyPre)
                        Body)
                      (Skip_ _ _))
                    (Straightline_ _ _ (Binop (variableSlot index ns) (variableSlot index ns) Plus 1 :: nil))))))
        end
      | Some b =>
        Structured.If_ H (variableSlot b ns) IL.Lt (variableSlot size ns)
        (Seq_ H
          (Straightline_ _ _ (
            Binop Rv 4 Times (variableSlot b ns)
            :: Binop Rv (variableSlot arr ns) Plus Rv
            :: Assign (variableSlot value ns) (LvMem (Reg Rv))
            :: Assign (variableSlot index ns) (variableSlot b ns)
            :: nil))
          (Cond_ _ H _ (conditionOut c)
            (Seq_ H
              (Structured.Assert_ _ _ bodyPre)
              Body)
            (Skip_ _ _)))
        (Skip_ _ _)
    end.

  Ltac wrap := wrap0; post; wrap1.

  Hint Resolve simplify_fwd.

  Lemma subst_qspecOut_fwd : forall pc state (specs : codeSpec pc state) A v qs (k : _ -> propX _ _ (A :: nil)),
    interp specs (subst (qspecOut qs k) v)
    -> interp specs (qspecOut qs (fun x => subst (k x) v)).
    induction qs; propxFo; eauto.
  Qed.

  Lemma subst_qspecOut_bwd : forall pc state (specs : codeSpec pc state) A v qs (k : _ -> propX _ _ (A :: nil)),
    interp specs (qspecOut qs (fun x => subst (k x) v))
    -> interp specs (subst (qspecOut qs k) v).
    induction qs; propxFo; eauto.
  Qed.

  Fixpoint domain (qs : qspec) : Type :=
    match qs with
      | Programming.Body _ => unit
      | Quant _ f => sigT (fun x => domain (f x))
    end.

  Fixpoint qspecOut' (qs : qspec) : domain qs -> HProp :=
    match qs with
      | Programming.Body P => fun _ => P
      | Quant _ f => fun d => qspecOut' (f (projT1 d)) (projT2 d)
    end.

  Lemma qspecOut_fwd : forall (specs : codeSpec W (settings * state)) qs k,
    interp specs (qspecOut qs k)
    -> exists v : domain qs, interp specs (k (qspecOut' qs v)).
    induction qs; simpl; propxFo.
    exists tt; auto.
    apply H0 in H1; destruct H1.
    exists (existT _ x x0); eauto.
  Qed.

  Lemma qspecOut_bwd : forall (specs : codeSpec W (settings * state)) qs k v,
    interp specs (k (qspecOut' qs v))
    -> interp specs (qspecOut qs k).
    induction qs; simpl; propxFo; eauto.
  Qed.

  Lemma must_be_nil : forall (ind sz : W) (ws1 ws2 : list W),
    sz <= ind
    -> ind = length ws1
    -> sz = length (ws1 ++ ws2)
    -> goodSize (length (ws1 ++ ws2))
    -> ws2 = nil.
    intros; subst; rewrite app_length in *;
      match goal with
        | [ H : _ |- _ ] => eapply wle_goodSize in H; eauto
      end; destruct ws2; simpl in *; auto; omega.
  Qed.

  Hint Extern 1 (_ = _) => eapply must_be_nil; solve [ eauto ].

  Lemma length_app_nil : forall (w : W) A (ls : list A),
    w = length (ls ++ nil)
    -> w = length ls.
    intros; rewrite app_length in *; simpl in *; subst; auto.
  Qed.

  Hint Immediate length_app_nil.

  Hint Extern 1 (interp _ (_ ---> _)%PropX) => apply Imply_refl.

  Theorem double_sel : forall V x,
    sel (sel V) x = sel V x.
    reflexivity.
  Qed.

  Hint Rewrite double_sel sel_upd_eq sel_upd_ne using congruence : Locals.

  Ltac locals := intros; autorewrite with Locals; reflexivity.

  Hint Rewrite app_length natToW_plus DepList.pf_list_simpl : sepFormula.

  Lemma goodSize_middle : forall (pre : list W) mid post,
    goodSize (length (pre ++ mid :: post))
    -> goodSize (length pre).
    intros; autorewrite with sepFormula in *; simpl in *; eauto.
  Qed.

  Lemma goodSize_middleS : forall (pre : list W) mid post,
    goodSize (length (pre ++ mid :: post))
    -> goodSize (S (length pre)).
    intros; autorewrite with sepFormula in *; simpl in *; eauto.
    eapply goodSize_weaken; eauto.
  Qed.

  Hint Extern 1 (goodSize (length _)) => (eapply goodSize_middle || eapply goodSize_middleS);
    eapply containsArray_goodSize; [ eassumption | eauto ].

  Hint Rewrite sel_middle using solve [ eauto ] : sepFormula.

  Lemma condition_safe : forall specs V fr stn st,
    interp specs (![locals ("rp" :: ns) V res (Regs st Sp) * fr] (stn, st))
    -> In index ns
    -> In value ns
    -> ~In "rp" ns
    -> forall c', conditionBound c'
      -> bexpSafe (conditionOut c') stn st.
    clear_fancy; induction c'; simpl; intuition;
      match goal with
        | [ _ : evalCond (expOut ?e1) _ (expOut ?e2) _ _ = None |- _ ] =>
          destruct e1; destruct e2; (simpl in *; intuition idtac; prep_locals; evaluate auto_ext)
      end.
  Qed.

  Hint Resolve condition_safe.

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

  Lemma wneb_true : forall w1 w2,
    w1 <> w2
    -> wneb w1 w2 = true.
    unfold wneb; intros; destruct (weq w1 w2); auto.
  Qed.

  Lemma wltb_true : forall w1 w2,
    w1 < w2
    -> wltb w1 w2 = true.
    unfold wltb; intros; destruct (wlt_dec w1 w2); auto.
  Qed.

  Lemma wleb_true : forall w1 w2,
    w1 <= w2
    -> wleb w1 w2 = true.
    unfold wleb; intros; destruct (weq w1 w2); destruct (wlt_dec w1 w2); auto.
    elimtype False; apply n.
    assert (wordToNat w1 = wordToNat w2) by nomega.
    apply (f_equal (fun w => natToWord 32 w)) in H1.
    repeat rewrite natToWord_wordToNat in H1.
    assumption.
  Qed.

  Hint Resolve wneb_true wltb_true wleb_true.

  Lemma bool_one : forall b,
    b = true
    -> b = false
    -> False.
    intros; congruence.
  Qed.

  Lemma weqb_false : forall w1 w2,
    w1 <> w2
    -> weqb w1 w2 = false.
    unfold weqb; intros; generalize (weqb_true_iff w1 w2); destruct (Word.weqb w1 w2); intuition.
  Qed.

  Lemma wneb_false : forall w1 w2,
    w1 = w2
    -> wneb w1 w2 = false.
    unfold wneb; intros; destruct (weq w1 w2); intuition.
  Qed.

  Lemma wltb_false : forall w1 w2,
    w2 <= w1
    -> wltb w1 w2 = false.
    unfold wltb; intros; destruct (wlt_dec w1 w2); intuition.
  Qed.

  Lemma wleb_false : forall w1 w2,
    w2 < w1
    -> wleb w1 w2 = false.
    unfold wleb; intros; destruct (weq w1 w2); destruct (wlt_dec w1 w2); intuition; nomega.
  Qed.

  Hint Resolve weqb_false wneb_false wltb_false wleb_false.

  Lemma condition_satisfies' : forall specs V fr stn st,
    interp specs (![locals ("rp" :: ns) V res (Regs st Sp) * fr] (stn, st))
    -> In index ns
    -> In value ns
    -> ~In "rp" ns
    -> forall c', conditionBound c'
      -> (bexpTrue (conditionOut c') stn st -> satisfies V (sel V index) (sel V value) c')
      /\ (bexpFalse (conditionOut c') stn st -> ~satisfies V (sel V index) (sel V value) c').
    clear_fancy; induction c'; simpl; intuition;
      try (eapply bool_one; [ eassumption | ]);
        match goal with
          | [ _ : evalCond (expOut ?e1) ?t (expOut ?e2) _ _ = _ |- _ ] =>
            destruct e1; destruct t; destruct e2;
              (simpl in *; intuition idtac; prep_locals; evaluate auto_ext; auto)
        end.
  Qed.

  Lemma condition_satisfies : forall specs V fr stn st ind val,
    interp specs (![locals ("rp" :: ns) V res (Regs st Sp) * fr] (stn, st))
    -> In index ns
    -> In value ns
    -> ~In "rp" ns
    -> sel V index = ind
    -> sel V value = val
    -> forall c', conditionBound c'
      -> bexpTrue (conditionOut c') stn st
      -> satisfies V ind val c'.
    intros; subst; edestruct condition_satisfies'; eauto.
  Qed.

  Lemma condition_not_satisfies : forall specs V fr stn st ind val,
    interp specs (![locals ("rp" :: ns) V res (Regs st Sp) * fr] (stn, st))
    -> In index ns
    -> In value ns
    -> ~In "rp" ns
    -> sel V index = ind
    -> sel V value = val
    -> forall c', conditionBound c'
      -> bexpFalse (conditionOut c') stn st
      -> ~satisfies V ind val c'.
    intros; subst; edestruct condition_satisfies'; eauto.
  Qed.

  Fixpoint noMatches (V : vals) (ws : list W) (index : nat) : Prop :=
    match ws with
      | nil => True
      | w :: ws' => ~satisfies V index w c /\ noMatches V ws' (index + 1)
    end.

  Hint Rewrite app_nil_r : sepFormula.

  Lemma invPre_skip : (forall specs stn st V qs ws wsAll this v fr,
    ~satisfies V (length ws) this c
    -> interp specs (![qspecOut' (invPre qs ws wsAll (sel V)) v * fr] (stn, st))
    -> goodSize (S (length ws))
    -> exists v', interp specs (![qspecOut' (invPre qs (ws ++ this :: nil) wsAll (sel V)) v' * fr] (stn, st)))
  -> forall specs V fr stn st ws' qs ws wsAll v,
    interp specs (![qspecOut' (invPre qs ws wsAll V) v * fr] (stn, st))
    -> noMatches V ws' (length ws)
    -> goodSize (length (ws ++ ws'))
    -> exists v', interp specs (![qspecOut' (invPre qs (ws ++ ws') wsAll V) v' * fr] (stn, st)).
    induction ws'; simpl; intuition; autorewrite with sepFormula; eauto.

    eapply H0 in H4.
    post.
    apply IHws' in H2; [ | post; auto | auto ].
    autorewrite with sepFormula in *; eauto.
    autorewrite with sepFormula in *; auto.
    eauto.
    eapply goodSize_middleS; eauto.
  Qed.

  Hint Resolve natToW_inj.

  Lemma wleb_true_fwd : forall u v, wleb u v = true -> u <= v.
    unfold wleb; intros;
      destruct (weq u v); destruct (wlt_dec u v); subst; auto; discriminate || nomega.
  Qed.

  Ltac indexEquals :=
    repeat match goal with
             | [ _ : match ?E with None => _ | _ => _ end = _ |- _ ] => destruct E; try discriminate
             | [ _ : match ?E with Const _ => _ | _ => _ end = _ |- _ ] => destruct E; try discriminate
             | [ _ : match ?E with IL.Eq => _ | _ => _ end = _ |- _ ] => destruct E; try discriminate
             | [ H : Some _ = Some _ |- _ ] => injection H; clear H; intros; subst; simpl in *
             | [ H : weqb _ _ = true |- _ ] => apply weqb_true_iff in H
             | [ H : wleb _ _ = true |- _ ] => apply wleb_true_fwd in H
           end.

  Lemma indexEquals_correct : forall k V (len : nat) val c',
    indexEquals c' = Some k
    -> satisfies V len val c'
    -> goodSize len
    -> (forall len' val', goodSize len' -> len <> len' -> ~satisfies V len' val' c').
    induction c'; simpl; intuition; indexEquals; intuition (subst; eauto);
      match goal with
        | [ H : _ -> False |- _ ] => apply H; apply natToW_inj; auto; congruence
      end.
  Qed.

  Lemma notSatisfies_noMatches' : forall V ws index,
    (forall (index' : nat) val, goodSize index' -> satisfies V index' val c
      -> (index <= index' < index + length ws)%nat -> False)
    -> goodSize (index + length ws)
    -> noMatches V ws index.
    induction ws; simpl; intuition eauto.
    eapply IHws; intros.
    eauto.
    Require Import Coq.Arith.Arith.
    rewrite <- plus_assoc.
    auto.
  Qed.

  Lemma notSatisfies_noMatches : forall V ws index,
    (forall (index' : nat) val, goodSize index' -> (index <= index' < index + length ws)%nat
      -> ~satisfies V index' val c)
    -> goodSize (index + length ws)
    -> noMatches V ws index.
    intuition; eapply notSatisfies_noMatches'; eauto.
  Qed.

  Lemma goodSize_middle' : forall (ls1 : list W) x ls2,
    goodSize (length (ls1 ++ x :: ls2))
    -> goodSize (length (ls1 ++ x :: nil) + length ls2).
    intros; autorewrite with sepFormula in *; simpl in *; rewrite <- plus_assoc; auto.
  Qed.

  Hint Resolve goodSize_middle'.

  Hint Extern 1 (~(@eq nat _ _)) => omega.

  Lemma indexEquals_bound : forall x c',
    indexEquals c' = Some x
    -> conditionBound c'
    -> In x ns.
    induction c'; simpl; intuition; indexEquals; tauto.
  Qed.

  Lemma indexGe_bound : forall x c',
    indexGe c' = Some x
    -> conditionBound c'
    -> In x ns.
    induction c'; simpl; intuition; indexEquals; tauto.
  Qed.

  Lemma indexEquals_correct' : forall k V c',
    indexEquals c' = Some k
    -> (forall len' val', goodSize len' -> sel V k <> len' -> ~satisfies V len' val' c').
    induction c'; simpl; intuition; indexEquals; intuition (subst; eauto).
  Qed.

  Lemma indexGe_correct : forall k V c',
    indexGe c' = Some k
    -> (forall len' val', goodSize len' -> natToW len' < sel V k -> ~satisfies V len' val' c').
    induction c'; simpl; intuition; indexEquals; intuition (subst; eauto).
  Qed.

  Lemma noMatches_app : forall V ws' ws index,
    noMatches V ws index
    -> noMatches V ws' (length ws + index)
    -> noMatches V (ws ++ ws') index.
    induction ws; simpl; intuition.
    replace (S (length ws + index0)) with (length ws + (index0 + 1)) in H1 by omega.
    auto.
  Qed.

  Lemma indexEquals_index : forall x c',
    indexEquals c' = Some x
    -> conditionBound c'
    -> x <> index.
    induction c'; simpl; intuition; indexEquals; tauto.
  Qed.

  Lemma indexEquals_value : forall x c',
    indexEquals c' = Some x
    -> conditionBound c'
    -> x <> value.
    induction c'; simpl; intuition; indexEquals; tauto.
  Qed.

  Lemma indexGe_index : forall x c',
    indexGe c' = Some x
    -> conditionBound c'
    -> x <> index.
    induction c'; simpl; intuition; indexEquals; tauto.
  Qed.

  Lemma indexGe_value : forall x c',
    indexGe c' = Some x
    -> conditionBound c'
    -> x <> value.
    induction c'; simpl; intuition; indexEquals; tauto.
  Qed.

  Hint Rewrite roundTrip_0 : N.

  Lemma skipn_breakout : forall ws n,
    (n < length ws)%nat
    -> skipn n ws = Array.selN ws n :: tl (skipn n ws).
    induction ws; destruct n; simpl; intuition.
  Qed.

  Lemma satisfies_incidentals : forall ind val c',
    conditionBound c'
    -> forall V V', (forall x, x <> index -> x <> value -> sel V x = sel V' x)
      -> satisfies V ind val c'
      -> satisfies V' ind val c'.
    induction c'; simpl; intuition eauto.
    destruct e1; destruct e2; simpl in *; intuition idtac;
      repeat match goal with
               | [ H : _ |- _ ] => rewrite <- H0 by tauto
             end; tauto.
    apply H3.
    eapply H1.
    intros.
    symmetry; apply H2; auto.
    auto.
  Qed.

  Lemma not_satisfies_incidentals : forall ind val c',
    conditionBound c'
    -> forall V V', (forall x, x <> index -> x <> value -> sel V x = sel V' x)
      -> ~satisfies V ind val c'
      -> ~satisfies V' ind val c'.
    intuition.
    apply H2; eapply satisfies_incidentals; [ eauto | | eauto ].
    intros; symmetry; apply H1; auto.
  Qed.

  Lemma length_tl : forall A (ls : list A),
    length (tl ls) = length ls - 1.
    destruct ls; simpl; omega.
  Qed.

  Theorem wordToNat_natToW_goodSize : forall n,
    goodSize n
    -> wordToNat (natToW n) = n.
    intros; unfold natToW; rewrite wordToNat_natToWord_idempotent; auto.
  Qed.

  Hint Rewrite wordToNat_natToW_goodSize using solve [ eauto ] : N.

  Opaque goodSize.

  Lemma length_prefix : forall mid (ws : list W),
    (exists sz, mid < sz /\ sz = natToW (length ws))
    -> goodSize (length ws)
    -> length (firstn (wordToNat mid) ws) = wordToNat mid.
    destruct 1; intuition idtac; subst; rewrite firstn_length; rewrite min_l; intuition nomega.
  Qed.

  Hint Rewrite length_prefix using solve [ eauto ] : sepFormula.

  Lemma goodSize_middle'' : forall (ls1 ls2 : list W) x,
    goodSize (length (ls1 ++ x :: ls2))
    -> goodSize (length ls1 + 1 + length ls2).
    intros; autorewrite with sepFormula in *; simpl in *.
    rewrite <- plus_assoc; auto.
  Qed.

  Hint Resolve goodSize_middle''.

  Hint Rewrite plus_0_r length_tl CancelIL.skipn_length : sepFormula.

  Lemma roundTrip' : forall w : W,
    w = natToW (wordToNat w).
    intros; unfold natToW; rewrite natToWord_wordToNat; auto.
  Qed.

  Hint Resolve roundTrip'.

  Ltac my_nomega := repeat match goal with
                             | [ H : sel _ size = _ |- _ ] => rewrite H in *
                             | [ |- (_ <> _)%type ] =>
                               let H := fresh in intro H; rewrite H in *
                             | [ _ : goodSize ?X, H : context[wordToNat (natToW ?X)] |- _ ] =>
                               rewrite wordToNat_natToW_goodSize in H by assumption
                           end; nomega.

  Lemma goodSize_funky : forall mid sz n,
    mid < sz
    -> sz = natToW n
    -> goodSize n
    -> goodSize (wordToNat mid + 1 + (n - wordToNat mid - 1)).
    intros; subst; apply goodSize_weaken with n; eauto; my_nomega.
  Qed.

  Hint Resolve goodSize_funky.

  Lemma breakout : forall (ws : list W) mid,
    (wordToNat mid < length ws)%nat
    -> ws = firstn (wordToNat mid) ws ++ Array.sel ws mid :: tl (skipn (wordToNat mid) ws).
    intros; etransitivity; [ symmetry; apply (firstn_skipn (wordToNat mid)) | ];
      cbv beta; f_equal; apply skipn_breakout; auto.
  Qed.

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

  Ltac depropx H := apply simplify_fwd in H; simpl in H;
    repeat match goal with
             | [ H : Logic.ex ?P |- _ ] => destruct H;
               try match goal with
                     | [ H : Logic.ex P |- _ ] => clear H
                   end
             | [ H : ?P /\ ?Q |- _ ] => destruct H;
               try match goal with
                     | [ H : P /\ Q |- _ ] => clear H
                   end
           end.

  Ltac begin0 :=
    match goal with
      | [ x : (settings * state)%type |- _ ] => destruct x; unfold fst, snd in *
      | [ H : forall x y z, _, H' : interp _ _ |- _ ] =>
        specialize (H _ _ _ H')
      | [ H : interp _ _ |- _ ] =>
        (apply subst_qspecOut_fwd in H; simpl in H)
        || (apply qspecOut_fwd in H; simpl in H; autorewrite with sepFormula in H; simpl in H; destruct H)
      | [ H : interp _ (Ex x, _) |- _ ] => depropx H
      | [ H : interp _ (ExX, _) |- _ ] => depropx H
      | [ H : interp _ (_ /\ _) |- _ ] => depropx H
      | [ H : simplify _ _ _ |- _ ] =>
        (apply simplify_bwd in H || (apply simplify_bwd' in H; unfold Substs in H);
          simpl in H; autorewrite with sepFormula in H; simpl in H)
    end.

  Ltac locals_rewrite :=
    repeat match goal with
             | [ H : _ = _ |- _ ] => rewrite H
             | [ |- context[sel (upd ?V ?x ?v) ?y] ] =>
               rewrite (@sel_upd_ne V x v y) by congruence
             | [ |- context[sel (upd ?V ?x ?v) ?y] ] =>
               rewrite (@sel_upd_eq V x v y) by congruence
           end.

  Ltac finish0 :=
    try match goal with
          | [ |- ?L = firstn _ ?L ++ _ ] => symmetry; apply firstn_skipn
        end; eauto; progress (try rewrite app_nil_r in *; descend; autorewrite with sepFormula;
          repeat match goal with
                   | [ H : _ = _ |- _ ] => rewrite H
                   | [ |- specs (sel (upd _ ?x _) ?y) = Some _ ] => assert (y <> x) by congruence
                   | [ |- appcontext[invPost _ _ ?V] ] => (has_evar V; fail 2) ||
                     match goal with
                       | [ |- appcontext[invPost _ _ ?V'] ] =>
                         match V' with
                           | V => fail 1
                           | _ => match goal with
                                    | [ H : forall (_ : quants) (_ : list W) (V : vals), _ |- _ ] =>
                                      rewrite (H _ _ V V') by locals
                                  end
                         end
                     end
                 end;
          try match goal with
                | [ |- satisfies _ _ _ _ ] => eapply condition_satisfies; solve [ finish0 ]
                | [ |- interp _ (subst _ _) ] =>
                  try match goal with
                        | [ _ : context[locals _ ?X _ _] |- context[locals _ ?Y _ _] ] => equate X Y
                      end;
                  apply subst_qspecOut_bwd; eapply qspecOut_bwd; propxFo
                | _ => try match goal with
                             | [ _ : context[qspecOut' _ ?X] |- context[qspecOut' _ ?Y] ] => equate X Y
                           end; step auto_ext
        end).

  Ltac enrich := match goal with
                   | [ H : indexEquals _ = Some _, H' : conditionBound _ |- _ ] =>
                     specialize (indexEquals_bound _ H H');
                       specialize (indexEquals_index _ H H');
                         specialize (indexEquals_value _ H H');
                           intros; prep_locals
                   | [ H : indexGe _ = Some _, H' : conditionBound _ |- _ ] =>
                     specialize (indexGe_bound _ H H');
                       specialize (indexGe_index _ H H');
                         specialize (indexGe_value _ H H');
                           intros; prep_locals
                 end.

  Ltac invPre_skip :=
    edestruct invPre_skip; try match goal with
                                 | [ _ : context[qspecOut' _ ?X] |- context[qspecOut' _ ?Y] ] => equate X Y
                               end; eauto; simpl.

  Ltac notSatisfies_noMatches :=
    eapply notSatisfies_noMatches; autorewrite with sepFormula; simpl; intros; eauto 6.
  Ltac indexEquals_correct :=
    eapply indexEquals_correct; (cbv beta; eauto).
  Ltac indexEquals_correct' := eapply indexEquals_correct'; autorewrite with Locals; eauto;
    (autorewrite with Locals; my_nomega).
  Ltac indexGe_correct := eapply indexGe_correct; autorewrite with Locals; eauto;
    (autorewrite with Locals; my_nomega).

  Ltac evolve :=
    match goal with
      | [ v : domain (invPre _ ((_ ++ _ :: nil) ++ _) _ _) |- _ ] =>
        generalize dependent v; autorewrite with sepFormula; intros
      | [ v : domain (invPre _ _ (_ ++ nil) _) |- _ ] =>
        generalize dependent v; autorewrite with sepFormula in *; intros
      | [ v : domain (invPre _ _ _ _) |- _ ] =>
        generalize dependent v; simpl; autorewrite with sepFormula;
          match goal with
            | [ H : forall qs : quants, _ |- context[locals _ ?V _ _] ] =>
              rewrite (H _ _ _ _ (sel V)) by locals
          end; intros
    end.

  Ltac finish := repeat finish0.

  Ltac nonempty L := destruct L; [ elimtype False; rewrite app_nil_r in *;
    repeat match goal with
             | [ H : _ = _ |- _ ] => rewrite H in *
           end;
    match goal with
      | [ H : ?X < ?X |- _ ] => generalize H; clear; intros
    end; nomega
    | ].

  Lemma app_length_le : forall A (ls1 ls2 : list A),
    (length ls1 <= length (ls1 ++ ls2))%nat.
    intros; rewrite app_length; auto.
  Qed.

  Hint Resolve app_length_le.

  Lemma goodSize_S' : forall (ls1 ls2 : list W) ind siz,
    ind = natToW (length ls1)
    -> siz = natToW (length (ls1 ++ ls2))
    -> ind < siz
    -> goodSize (length (ls1 ++ ls2))
    -> (S (length ls1) <= length ls1 + length ls2)%nat.
    intros; subst; autorewrite with sepFormula in *; apply lt_goodSize' in H2; eauto.
  Qed.

  Hint Extern 1 (S _ <= _)%nat => eapply goodSize_S'; [ eassumption | eassumption | eassumption
    | eapply containsArray_goodSize; eauto ].

  Ltac goodSize := eapply goodSize_weaken; [
    eapply containsArray_goodSize; eauto
    | cbv beta; autorewrite with sepFormula; simpl; eauto; my_nomega ].

  Ltac begin := repeat begin0;
    try match goal with
          | [ _ : bexpFalse _ _ _, H : evalInstrs _ _ (Binop _ _ Plus _ :: nil) = Some _ |- _ ] =>
            generalize dependent H
        end;
    evaluate auto_ext; intros; subst;
      try match goal with
            | [ _ : sel _ size = natToW (length (_ ++ ?ws)) |- _ ] => assert (ws = nil) by auto; subst;
              try evolve

            | [ _ : indexEquals _ = Some _,_ : satisfies _ _ _ _ |- _ ] =>
              invPre_skip; [ match goal with
                               | [ _ : context[array (_ ++ _ :: ?wsPost) _] |- _ ] => instantiate (1 := wsPost)
                             end; notSatisfies_noMatches; indexEquals_correct
                | goodSize
                | evolve ]

            | [ _ : indexEquals _ = Some _, _ : evalCond _ _ _ _ _ = Some false |- _ ] =>
              invPre_skip; [ match goal with
                               | [ _ : context[array ?ws _] |- _ ] => instantiate (1 := ws)
                             end; notSatisfies_noMatches; indexEquals_correct'
                | goodSize
                | finish ]

            | [ _ : indexEquals _ = Some _, _ : evalCond _ _ _ _ _ = Some true, _ : bexpFalse _ _ _ |- _ ] =>
              invPre_skip; [ match goal with
                               | [ _ : ?mid < sel _ size, _ : context[array ?ws _] |- _ ] => instantiate (1 := ws);
                                 rewrite <- (firstn_skipn (wordToNat mid) ws)
                             end; apply noMatches_app; [ notSatisfies_noMatches; indexEquals_correct'
                               | rewrite skipn_breakout by my_nomega; split; autorewrite with sepFormula ]; [
                                 evolve; invPre_skip; [
                                   match goal with
                                     | [ _ : ?mid < sel _ size, _ : context[array ?ws _] |- _ ] =>
                                       instantiate (1 := firstn (wordToNat mid) ws)
                                   end; notSatisfies_noMatches; indexEquals_correct'
                                   | goodSize
                                   | match goal with
                                       | [ _ : context[locals _ ?V _ _] |- ~satisfies _ _ _ _ ] =>
                                         apply not_satisfies_incidentals with V; intros; autorewrite with Locals; auto
                                     end; eapply condition_not_satisfies; finish0; auto ]
                                 | notSatisfies_noMatches; indexEquals_correct' ]
                | goodSize
                | evolve ]

            | [ _ : indexEquals _ = Some _, _ : evalCond _ _ _ _ _ = Some true, _ : bexpTrue _ _ _ |- _ ] =>
              invPre_skip; [ match goal with
                               | [ _ : ?mid < sel _ size, _ : context[array ?ws _] |- _ ] =>
                                 instantiate (1 := firstn (wordToNat mid) ws)
                             end; notSatisfies_noMatches; indexEquals_correct'
                | goodSize
                | evolve ]

            | [ _ : indexGe _ = Some _, _ : evalCond _ _ _ _ _ = Some true |- _ ] =>
              invPre_skip; [ notSatisfies_noMatches; indexGe_correct
                | goodSize
                | match goal with
                    | [ v : domain (invPre _ (nil ++ _) _ _) |- _ ] =>
                      generalize dependent v; simpl; intros
                  end ]

            | [ _ : indexGe _ = Some _, _ : evalCond _ _ _ _ _ = Some false |- _ ] =>
              invPre_skip; [ match goal with
                               | [ _ : ?mid < sel _ size, _ : context[array ?ws _] |- _ ] =>
                                 instantiate (1 := firstn (wordToNat mid) ws)
                             end; notSatisfies_noMatches; indexGe_correct
                | goodSize
                | evolve ]

            | [ v : domain (invPre ?qs nil _ (sel ?V)), H : forall x : quants, _ |- _ ] =>
              generalize dependent v; rewrite (H qs nil _ (sel V) (sel (upd V index 0))) by locals;
                intros; do 2 eexists; exists nil

            | [ v : domain (invPre ?qs (?x ++ ?l :: nil) _ (sel ?V)), H : forall x : quants, _ |- _ ] =>
              generalize dependent v; rewrite (H qs (x ++ l :: nil) _ (sel V) (sel (upd V index (sel V index ^+ $1))))
                by locals; intros; do 2 eexists; exists (x ++ l :: nil)

            | [ _ : bexpTrue _ _ _, v : domain (invPre _ ?l _ (sel ?V)), H : forall x : quants, _,
                _ : _ = natToW (length (?wPre ++ ?wPost)) |- _ ] =>
              generalize dependent v; rewrite (H _ _ _ _ (upd V value (Array.sel (wPre ++ wPost)
                (sel V index)))) by locals; intros;
              nonempty wPost;
              match goal with
                | [ H : context[v] |- _ ] => generalize v H
              end; locals_rewrite; rewrite sel_middle by eauto; intro v'; intros; repeat eexists;
              apply simplify_fwd'; unfold Substs; apply subst_qspecOut_bwd; apply qspecOut_bwd with v'

            | [ Hf : bexpFalse (conditionOut c) _ _, _ : evalInstrs _ _ (Binop _ _ Plus _ :: nil) = Some _,
                v : domain (invPre _ ?l ?all (sel ?V)), H : forall x : quants, _,
                _ : context[Array.sel (?wPre ++ ?wPost) ?u], _ : _ = natToW (length ?L) |- _ ] =>
              let Hf' := fresh in
              match goal with
                | [ _ : context[locals _ ?V' _ _] |- _ ] =>
                  assert (Hf' : ~satisfies V' (length L) (sel V' value) c)
                    by (eapply condition_not_satisfies; finish0)
              end; clear Hf; rename Hf' into Hf;
              generalize dependent v; rewrite (H _ _ _ _ (upd V value (Array.sel (wPre ++ wPost) u))) by locals;
                intros;
                  match goal with
                    | [ H' : forall specs : codeSpec _ _, _ |- _ ] =>
                      change (forall specs stn st V qs ws wsAll this v fr,
                        ~satisfies V (Datatypes.length ws) this c
                        -> interp specs (![qspecOut' (invPre qs ws wsAll V) v * fr] (stn, st))
                        -> goodSize (S (length ws))
                        -> exists v', interp specs (![qspecOut' (invPre qs (ws ++ this :: nil) wsAll V) v' * fr] (stn, st))) in H';
                      eapply H' in Hf; [ |
                        match goal with
                          | [ |- context[qspecOut' _ ?v'] ] => equate v v'
                        end; eauto | goodSize ]
                  end; rewrite (H _ _ _ _ (upd
                    (upd V value (Array.sel (wPre ++ wPost) u)) index
                    (sel (upd V value (Array.sel (wPre ++ wPost) u)) index ^+ $1)))
                  in Hf by locals;
                  intros; do 2 eexists;
                    exists (wPre ++ Array.sel (wPre ++ wPost) u :: nil); exists all;
                      exists (upd (upd V value (Array.sel (wPre ++ wPost) u)) index
                        (sel (upd V value (Array.sel (wPre ++ wPost) u))
                          index ^+ $1));
                      nonempty wPost;
                      repeat match goal with
                               | [ H : interp _ _ |- _ ] => clear H
                             end; destruct Hf as [v']; evaluate auto_ext;
                      apply simplify_fwd'; unfold Substs; apply subst_qspecOut_bwd;
                        generalize dependent v'; locals_rewrite; intros; apply qspecOut_bwd with v'
          end.

  Ltac t := begin; finish.

  Definition Query : cmd imports modName.
    refine (Wrap _ H _ Query_
      (fun _ st => Ex qs, Ex ws, ExX, Ex V, qspecOut (invPre qs ws ws (sel V)) (fun PR =>
        ![ ^[locals ("rp" :: ns) V res st#Sp * array ws (sel V arr) * PR] * #0 ] st
        /\ [| sel V size = length ws |]
        /\ (sel V "rp", fst st) @@@ (st' ~>
          [| st'#Sp = st#Sp |]
          /\ Ex V', qspecOut (invPost qs ws (sel V) st'#Rv) (fun PO =>
            ![ ^[locals ("rp" :: ns) V' res st#Sp * array ws (sel V arr) * PO] * #1 ] st'))))%PropX
      (fun pre =>
        (* Basic hygiene requirements *)
        In arr ns
        :: In size ns
        :: In index ns
        :: In value ns
        :: (~In "rp" ns)
        :: (~(index = arr))
        :: (~(size = index))
        :: (~(value = index))
        :: (~(value = size))
        :: (~(value = arr))
        :: conditionBound c

        (* Invariants are independent of values of some variables. *)
        :: (forall qs ws all V V',
          (forall x, x <> index -> x <> value -> sel V x = sel V' x)
          -> invPre qs ws all V = invPre qs ws all V')
        :: (forall qs ws V V',
          (forall x, x <> index -> x <> value -> sel V x = sel V' x)
          -> invPost qs ws V = invPost qs ws V')

        (* Precondition implies loop invariant. *)
        :: (forall specs stn st, interp specs (pre (stn, st))
          -> interp specs (Ex qs, ExX, Ex V, Ex ws, qspecOut (invPre qs nil ws (sel V)) (fun PR =>
            ![ ^[locals ("rp" :: ns) V res (Regs st Sp) * array ws (sel V arr) * PR] * #0 ] (stn, st)
            /\ [| sel V size = length ws |]
            /\ (sel V "rp", stn) @@@ (st' ~>
              [| st'#Sp = Regs st Sp |]
              /\ Ex V', qspecOut (invPost qs ws (sel V) st'#Rv) (fun PO =>
                ![ ^[locals ("rp" :: ns) V' res (Regs st Sp) * array ws (sel V arr) * PO] * #1 ] st'))))%PropX)

        (* Loop invariant is preserved on no-op, when the current cell isn't a match. *)
        :: (forall specs stn st V qs ws all this v fr,
          ~satisfies V (length ws) this c
          -> interp specs (![qspecOut' (invPre qs ws all (sel V)) v * fr] (stn, st))
          -> goodSize (S (length ws))
          -> exists v', interp specs (![qspecOut' (invPre qs (ws ++ this :: nil) all (sel V)) v' * fr] (stn, st)))

        (* Postcondition implies loop invariant. *)
        :: (forall specs stn st, interp specs (Postcondition (Body bodyPre) (stn, st))
          -> interp specs (Ex qs, ExX, Ex wsPre, Ex ws, Ex this, Ex V,
            qspecOut (invPre qs (wsPre ++ this :: nil) ws (sel V)) (fun PR =>
              ![ ^[locals ("rp" :: ns) V res (Regs st Sp) * array ws (sel V arr) * PR] * #0 ] (stn, st)
              /\ [| sel V size = length ws /\ sel V index = length wsPre /\ satisfies V (length wsPre) this c |]
              /\ Ex wsPost, [| ws = wsPre ++ this :: wsPost |]
              /\ (sel V "rp", stn) @@@ (st' ~>
                [| st'#Sp = Regs st Sp |]
                /\ Ex V', qspecOut (invPost qs ws (sel V) st'#Rv) (fun PO =>
                  ![ ^[locals ("rp" :: ns) V' res (Regs st Sp) * array ws (sel V arr) * PO] * #1 ] st'))))%PropX)

        (* Conditions of body are satisfied. *)
        :: VerifCond (Body bodyPre))
      _ _); abstract (unfold Query_; case_eq (indexEquals c); [ | case_eq (indexGe c) ]; intros;
        wrap; try enrich; t).
  Defined.

End Query.

Definition ForArray (arr size index value : string) (c : condition) quants invPre invPost (Body : chunk) : chunk :=
  fun ns res => Structured nil (fun _ _ H => Query arr size index value c H (quants := quants) invPre invPost
    (toCmd Body _ H ns res) ns res).

Record aspec := {
  Quants : Type;
  InvPre : Quants -> list W -> list W -> vals -> qspec;
  InvPost : Quants -> list W -> vals -> W -> qspec
}.

Definition aspecBase (invPre : list W -> list W -> vals -> qspec)
  (invPost : list W -> vals -> W -> qspec) : aspec :=
  {| Quants := unit;
    InvPre := (fun _ => invPre);
    InvPost := (fun _ => invPost) |}.

Definition aspecForall A (asp : A -> aspec) : aspec :=
  {| Quants := { x : A & Quants (asp x) };
    InvPre := (fun v => InvPre (asp (projT1 v)) (projT2 v));
    InvPost := (fun v => InvPost (asp (projT1 v)) (projT2 v)) |}.

Notation "'After' ws 'Approaching' full 'PRE' [ V ] pre 'POST' [ R ] post" :=
  (aspecBase (fun ws full V => pre%qspec%Sep) (fun full V R => post%qspec%Sep))
  (at level 89) : aspec_scope.

Notation "'Al' x , asp" := (aspecForall (fun x => asp)) : aspec_scope.

Delimit Scope aspec_scope with aspec.

Notation "[ asp ] 'For' index 'Holding' value 'in' arr 'Size' size 'Where' c { Body }" :=
  (let asp' := asp%aspec in ForArray arr size index value c%ArrayQuery (InvPre asp') (InvPost asp') Body)
  (no associativity, at level 95, index at level 0, value at level 0, arr at level 0, size at level 0,
    c at level 0) : SP_scope.

Ltac for0 := try solve [ intuition (try congruence);
  repeat match goal with
           | [ H : forall x : string, _ |- _ ] => rewrite H by congruence
         end; reflexivity ].

Ltac eta_evar T k :=
  match eval cbv beta in T with
    | unit => k tt
    | @sigT ?A ?F =>
      let x' := fresh in evar (x' : A); let x := eval unfold x' in x' in clear x';
        eta_evar (F x) ltac:(fun v => k (existT F x v))
    | _ =>
      idtac "BYE";
        let x' := fresh in evar (x' : T); let x := eval unfold x' in x' in clear x';
          k x
  end.

Ltac multi_ex :=
  try match goal with
        | [ _ : sigT _ |- _ ] =>
          repeat match goal with
                   | [ x : sigT _ |- _ ] => destruct x
                 end; simpl in *
      end;
  try match goal with
        | [ |- @Logic.ex ?T _ ] =>
          match T with
            | sigT _ => eta_evar T ltac:(fun v => exists v; simpl)
          end
      end.


Require Import RRR.Lang.Lang.
Require Import RRR.Lebesgue.Lebesgue.
Require Import RRR.Rel.Relations.
Require Import Coq.omega.Omega.
Require Import Coq.Arith.Minus.
Require Import Coq.micromega.Lra.
Require Import FunctionalExtensionality.
Require ProofIrrelevance.
Require ssreflect.
Require ClassicalDescription.

Definition εNS n t K e := match ev2v n t e with
| Some (k, _, v, w) => w * μNS (n - k) (ktx_plug K v)
| None => 0
end.

Definition εNS' n t K e := match ev2v n t e with
| Some (k, _, v, w) => w * μNS n (ktx_plug K v)
| None => 0
end.

Fact εNS'_le_εNS n t K e : εNS' t n K e ≤ εNS t n K e.
Proof.
unfold εNS, εNS'.
repeat match goal with
| [ |- context[match ?x with _ => _ end] ] => destruct x
| [ |- (0 ≤ _)%ennr ] => apply ennr_le_0
| [ |- ?x * ?y ≤ ?x ] => replace x with (x * 1) at 2 by apply ennr_mul_1_r
| [ |- ?x * ?y ≤ ?x * ?z ] => apply ennr_mult_le_compat_l
end. apply μNS_antitone. omega.
Qed.

Fact εNS_le_ρTV n t K e : εNS t n K e ≤ ρTV t n e full_event.
Proof.
unfold εNS. rewrite <-ev2v_ρTV_same_weight. unfold full_event, const.
repeat match goal with
| [ |- context[match ?x with _ => _ end] ] => destruct x
| [ |- (0 ≤ _)%ennr ] => apply ennr_le_0
| [ |- ?x * ?y ≤ ?x ] => replace x with (x * 1) at 2 by apply ennr_mul_1_r
| [ |- ?x * ?y ≤ ?x * ?z ] => apply ennr_mult_le_compat_l
end. apply μNS_le_1.
Qed.

Fact εNS'_le_ρTV n t K e : εNS' t n K e ≤ ρTV t n e full_event.
Proof.
eapply ennr_le_trans. 1:{ apply εNS'_le_εNS. } apply εNS_le_ρTV.
Qed.

Definition νNS n K e := ∫ (λ t, εNS n t K e) μentropy.

Definition νNS' n K e := ∫ (λ t, εNS' n t K e) μentropy.

Fact νNS'_le_νNS n K e : νNS' n K e ≤ νNS n K e.
Proof.
intros. apply integrand_extensionality_le; intro t.
apply εNS'_le_εNS.
Qed.

Fact νNS_le_μTV n K e : νNS n K e ≤ μTV n e full_event.
Proof.
intros. apply integrand_extensionality_le; intro t.
apply εNS_le_ρTV.
Qed.

Fact νNS'_le_μTV n K e : νNS' n K e ≤ μTV n e full_event.
Proof.
intros. apply integrand_extensionality_le; intro t.
apply εNS'_le_ρTV.
Qed.

Fact μTV_minus_νNS_monotone_S n K e :
μTV n e full_event - νNS n K e ≤
μTV (S n) e full_event - νNS (S n) K e.
Proof.
  unfold μTV, νNS.
  repeat rewrite integration_linear_minus.
  3:{ intro. apply εNS_le_ρTV. }
  2:{ intro. apply εNS_le_ρTV. }
  setoid_rewrite <-ev2v_ρTV_same_weight. unfold full_event, const.
  unfold εNS.
  match goal with [ |- ?x ≤ _ ] => replace x with (
    ∫ (λ t, match ev2v n t e with
      | Some (k, _, v, w) =>
        (if ev2v (S n) t e then w else 0) *
        (1 - μNS (n - k) (ktx_plug K v))
      | None => 0
    end) μentropy +
    ∫ (λ t, match ev2v n t e with
      | Some (k, _, v, w) =>
        (if ev2v (S n) t e then 0 else w) *
        (1 - μNS (n - k) (ktx_plug K v))
      | None => 0
    end) μentropy
  ) end.
  2:{
    rewrite integration_linear_plus. integrand_extensionality t.
    repeat match goal with
    | [ |- context[match ?x with _ => _ end] ] => destruct x
    | [ |- ?x = ?x ] => ring
    | [ |- context[(0 * _)%ennr]] => rewrite ennr_mul_0_l
    | [ |- context[(0 + _)%ennr]] => rewrite ennr_add_0_l
    | [ |- context[(_ + 0)%ennr]] => rewrite ennr_add_0_r
    | [ |- context[(_ - 0)%ennr]] => rewrite ennr_minus_0
    | [ |- context[(_ * (_ - _))%ennr]] => rewrite ennr_minus_distr_r
    | [ |- context[(_ * 1)%ennr]] => rewrite ennr_mul_1_r
    | [ |- μNS _ _ ≤ 1 ] => apply μNS_le_1
    end.
  }
  match goal with [ |- _ + ?x ≤ _ ] => replace x with 0 end.
  2:{
    eapply ennr_mult_infinity_compat_0_eq.
    2:{ apply eq_sym. apply ev2v_monotone_S with (N := n) (e := e). }
    rewrite <- integration_linear_mult_l.
    apply integrand_extensionality_le. intro t.
    destruct (ev2v n t e) as [ [[[? ?] ?] ?] | ]. 2:{ apply ennr_le_0. }
    repeat match goal with
    | [ |- context[match ?x with _ => _ end] ] => destruct x
    | [ |- context[(0 * _)%ennr]] => rewrite ennr_mul_0_l
    | [ |- (0 ≤ _)%ennr ] => apply ennr_le_0
    | [ |- (_ ≤ ∞)%ennr ] => apply ennr_le_infinity
    | [ |- ?r * _ ≤ _ * ?r ] => rewrite ennr_mul_comm with (n := r)
    | [ |- _ * ?r ≤ _ * ?r ] => apply ennr_mult_le_compat_r
    end.
  }
  rewrite ennr_add_0_r.

  apply integrand_extensionality_le. intro t.
  destruct (ev2v n t e) as [[[[k0 t0] v0] w0]|] eqn:Ev2v_e_n,
      (ev2v (S n) t e) as [[[[k1 t1] v1] w1]|] eqn:Ev2v_e_Sn;
  repeat match goal with
  | [ |- context[match ?x with _ => _ end] ] => destruct x
  | [ |- (0 ≤ _)%ennr ] => apply ennr_le_0
  | [ |- context[(_ - 0)%ennr] ] => rewrite ennr_minus_0
  | [ |- context[(_ * 1)%ennr] ] => rewrite ennr_mul_1_r
  | [ |- context[(0 * _)%ennr] ] => rewrite ennr_mul_0_l
  end.
  rewrite ennr_minus_distr_r. 2:{ apply μNS_le_1. }
  rewrite <- ennr_mul_1_r with (r := w1) at 1.
  repeat rewrite ennr_mul_comm with (n := w0).
  repeat rewrite ennr_mul_comm with (n := w1).
  repeat rewrite <- ennr_minus_distr_l; try apply μNS_le_1.
  eapply ev2v_S with (n := n) in Ev2v_e_Sn as [? [? [? ?]]]; try exact
  Ev2v_e_n. subst.
  apply ennr_mult_le_compat. 2:{ assumption. }
  apply ennr_minus_le_compat_r; try apply μNS_le_1.
  rewrite <- minus_Sn_m. 2:{ eapply ev2v_index_bounded; eassumption. }
  apply μNS_antitone_S.
Qed.

Fact μTV_minus_νNS_monotone K e :
monotone (λ n, μTV n e full_event - νNS n K e).
Proof.
do 2 intro. induction 1.
+ apply ennr_le_refl.
+ eapply ennr_le_trans; [eassumption|]. apply μTV_minus_νNS_monotone_S.
Qed.

Definition vt (T : ty) : Set := option { v : val0 | wf_val ∅→ v T }.

Definition ρTVT
(T : ty) (N : nat) (t : entropy) (e : exp0) (WF_e : wf_exp ∅→ e T)
(V : Event (vt T)) : R⁺.
Proof.
destruct (ev2v N t e) as [ [[[k t'] v] w] |] eqn:Ev2v.
2:{ refine 0. }
refine (
  if V (Some (exist _ v (ev2v_preserves_type Ev2v WF_e)))
  then w else 0
).
Defined.
Arguments ρTVT : clear implicits.

Definition μTVT
(T : ty) (N : nat) (e : exp0) (WF_e : wf_exp ∅→ e T) : Meas (vt T) :=
λ V, ∫ (λ t, ρTVT T N t e WF_e V) μentropy.
Arguments μTVT : clear implicits.

Definition μTVT_sup T e (WF_e : wf_exp ∅→ e T) V :=
sup (λ n, μTVT T n e WF_e V).
Arguments μTVT_sup T : clear implicits.

Definition μentropy_to_vt
(T : ty) (N : nat) (e : exp0) (WF_e : wf_exp ∅→ e T) :
entropy → vt T.
Proof.
intro t. destruct (ev2v N t e) as [ [[[k t'] v] w] |] eqn:Ev2v.
2:{ refine None. }
refine (Some (exist _ v _)).
apply (ev2v_preserves_type Ev2v WF_e).
Defined.
Arguments μentropy_to_vt : clear implicits.

Definition vkt (T : ty) : Set := option (nat * { v : val0 | wf_val ∅→ v T }).

Definition ρTVKT
(T : ty) (N : nat) (t : entropy) (e : exp0) (WF_e : wf_exp ∅→ e T)
(V : Event (vkt T)) : R⁺.
Proof.
destruct (ev2v N t e) as [ [[[k t'] v] w] |] eqn:Ev2v.
2:{ refine 0. }
refine (
  if V (Some (k, exist _ v (ev2v_preserves_type Ev2v WF_e)))
  then w else 0
).
Defined.
Arguments ρTVKT : clear implicits.

Definition μTVKT
(T : ty) (N : nat) (e : exp0) (WF_e : wf_exp ∅→ e T) : Meas (vkt T) :=
λ V, ∫ (λ t, ρTVKT T N t e WF_e V) μentropy.
Arguments μTVKT : clear implicits.

Definition μTVKT_sup T e (WF_e : wf_exp ∅→ e T) V :=
sup (λ n, μTVKT T n e WF_e V).
Arguments μTVKT_sup T : clear implicits.

Definition μentropy_to_vkt
(T : ty) (N : nat) (e : exp0) (WF_e : wf_exp ∅→ e T) :
entropy → vkt T.
Proof.
intro t. destruct (ev2v N t e) as [ [[[k t'] v] w] |] eqn:Ev2v.
2:{ refine None. }
refine (Some (k, exist _ v _)).
apply (ev2v_preserves_type Ev2v WF_e).
Defined.
Arguments μentropy_to_vkt : clear implicits.

Section section_μTVT_is_pushforward.
Import ssreflect.
Import ProofIrrelevance.
Import ClassicalDescription. (* for convenience *)

Lemma μTVT_is_μTV
(T : ty) (N : nat) (e : exp0) (WF_e : wf_exp ∅→ e T)
(VT : Event (vt T)) :
μTVT T N e WF_e VT = μTV N e (λ v,
  match excluded_middle_informative (wf_val ∅→ v T) with
  | left WF_v => VT (Some (exist _ v WF_v))
  | right WF_v_false => false
  end
).
Proof.
unfold μTVT, μTV. integrand_extensionality t.
rewrite <-ev2v_ρTV_same_weight.
unfold ρTVT. generalize (eq_refl (ev2v N t e)).
case: {2 3}(ev2v N t e).
2:{ intro H. rewrite H. ring. }
intros [[[k t'] v] w]. intro H. rewrite H.
destruct (excluded_middle_informative _) as [WF_v|WF_v_false].
+ replace (ev2v_preserves_type H WF_e) with WF_v by apply proof_irrelevance.
  reflexivity.
+ exfalso. apply (WF_v_false (ev2v_preserves_type H WF_e)).
Qed.

Lemma μTVT_is_pushforward T N e (WF_e : wf_exp ∅→ e T) :
pushforward (score_meas (
  λ t, match ev2v N t e with
  | Some (_, _, _, w) => w
  | None => 0
  end
) μentropy) (μentropy_to_vt T N e WF_e) =
μTVT T N e WF_e.
Proof.
extensionality V. unfold pushforward, compose, μTVT.
unfold score_meas, ">>=".
integrand_extensionality t. unfold indicator, ifte, preimage.
unfold ρTVT. generalize (eq_refl (ev2v N t e)).
case: {2 3 4}(ev2v N t e). 2:{ intros. ring. }
intros [[[k t'] v] w]. intro H.
unfold μentropy_to_vt.
generalize (eq_refl (ev2v N t e)).
case: {2 3}(ev2v N t e).
2:{ intro H'. exfalso. rewrite H' in H. inversion H. }
intros [[[_k _t'] _v] _w]. intro H'.
assert (_k = k ∧ _v = v) as P.
2:{
  destruct P. subst _k _v.
  replace (ev2v_preserves_type H' WF_e) with
          (ev2v_preserves_type H WF_e)
          by apply proof_irrelevance.
  destruct (V _); ring.
}
rewrite H' in H. inversion H. subst. split; trivial.
Qed.

End section_μTVT_is_pushforward.

Section section_μTVKT_is_pushforward.
Import ssreflect.
Import ProofIrrelevance.

Lemma μTVKT_is_pushforward T N e (WF_e : wf_exp ∅→ e T) :
pushforward (score_meas (
  λ t, match ev2v N t e with
  | Some (_, _, _, w) => w
  | None => 0
  end
) μentropy) (μentropy_to_vkt T N e WF_e) =
μTVKT T N e WF_e.
Proof.
extensionality V. unfold pushforward, compose, μTVKT.
unfold score_meas, ">>=".
integrand_extensionality t. unfold indicator, ifte, preimage.
unfold ρTVKT. generalize (eq_refl (ev2v N t e)).
case: {2 3 4}(ev2v N t e). 2:{ intros. ring. }
intros [[[k t'] v] w]. intro H.
unfold μentropy_to_vkt. generalize (eq_refl (ev2v N t e)).
case: {2 3}(ev2v N t e).
2:{ intro H'. exfalso. rewrite H' in H. inversion H. }
intros [[[_k _t'] _v] _w]. intro H'.
assert (_k = k ∧ _v = v) as P.
2:{
  destruct P. subst _k _v.
  replace (ev2v_preserves_type H' WF_e) with
          (ev2v_preserves_type H WF_e)
          by apply proof_irrelevance.
  destruct (V _); ring.
}
rewrite H' in H. inversion H. subst. split; trivial.
Qed.

End section_μTVKT_is_pushforward.

Section section_μTV_minus_νNS_pushforward.
Import ProofIrrelevance.
Import ssreflect.

Fact μTV_minus_νNS'_pushforward_μTVT T n K e (WF_e : wf_exp ∅→ e T) :
μTV n e full_event - νNS' n K e =
∫ (λ v : vt T, 1 -
  match v with
  | Some (exist _ v _) => μNS n (ktx_plug K v)
  | None => 0
  end
) (μTVT T n e WF_e).
Proof.
unfold μTV, νNS', εNS'. rewrite integration_linear_minus.
1:{ intro. apply εNS'_le_ρTV. }
rewrite <-μTVT_is_pushforward. rewrite <-integration_of_pushforward.
unfold compose. rewrite integration_wrt_score_meas.
integrand_extensionality t.
unfold μentropy_to_vt.
rewrite <-ev2v_ρTV_same_weight.
generalize (eq_refl (ev2v n t e)).
case: {2 3 4 5 12}(ev2v n t e).
2:{ intro H. repeat rewrite ennr_minus_0. ring. }
intros [[[k t'] v] w]. intro H.
unfold full_event, const.
rewrite ennr_minus_distr_l. 1:{ apply μNS_le_1. }
apply f_equal2; ring.
Qed.

Fact μTV_minus_νNS_pushforward_μTVKT T n K e (WF_e : wf_exp ∅→ e T) :
μTV n e full_event - νNS n K e =
∫ (λ v : vkt T, 1 -
  match v with
  | Some (k, exist _ v _) => μNS (n - k) (ktx_plug K v)
  | None => 0
  end
) (μTVKT T n e WF_e).
Proof.
unfold μTV, νNS, εNS. rewrite integration_linear_minus.
1:{ intro. apply εNS_le_ρTV. }
rewrite <-μTVKT_is_pushforward. rewrite <-integration_of_pushforward.
unfold compose. rewrite integration_wrt_score_meas.
integrand_extensionality t.
unfold μentropy_to_vkt.
rewrite <-ev2v_ρTV_same_weight.
generalize (eq_refl (ev2v n t e)).
case: {2 3 4 5 12}(ev2v n t e).
2:{ intro H. repeat rewrite ennr_minus_0. ring. }
intros [[[k t'] v] w]. intro H.
unfold full_event, const.
rewrite ennr_minus_distr_l. 1:{ apply μNS_le_1. }
apply f_equal2; ring.
Qed.

Fact μTV_minus_νNS_pushforward_μTVT T n K e (WF_e : wf_exp ∅→ e T) :
μTV n e full_event - νNS n K e ≤
∫ (λ v : vt T, 1 -
  match v with
  | Some (exist _ v _) => μNS n (ktx_plug K v)
  | None => 0
  end
) (μTVT T n e WF_e).
Proof.
rewrite <- μTV_minus_νNS'_pushforward_μTVT.
apply ennr_minus_le_compat_r.
3:{ apply νNS'_le_νNS. }
2:{ apply νNS'_le_μTV. }
1:{ apply νNS_le_μTV. }
Qed.

Lemma μTVKT_O_val T v V WF_v :
μTVKT T O (exp_val v) (wf_exp_val WF_v) V = if V (Some (O, exist _ v WF_v)) then 1 else 0.
Proof.
destruct (V _) eqn:Hv.
+ unfold μTVKT.
  replace 1 with (μentropy full_event).
  2:{ rewrite μentropy_is_a_probability_measure ; reflexivity. }
  rewrite <- integration_of_indicator. unfold indicator, ifte.
  integrand_extensionality t. cbn.
  replace (ev2v_preserves_type _ _) with WF_v by apply proof_irrelevance.
  rewrite Hv ; cbn ; ring.
+ unfold μTVKT.
  erewrite <- integration_of_0.
  integrand_extensionality t. cbn.
  replace (ev2v_preserves_type _ _) with WF_v by apply proof_irrelevance.
  rewrite Hv ; cbn ; ring.
Qed.

Lemma μTVKT_S_val T N (v : val0) V WF_v :
μTVKT T (S N) v (wf_exp_val WF_v) V = μTVKT T N v (wf_exp_val WF_v) V.
Proof.
unfold μTVKT.
integrand_extensionality t.
unfold ρTVKT.
generalize (eq_refl (ev2v (S N) t v)).
case: {2 3}(ev2v (S N) t v).
2:{ intro H. exfalso. simpl in H. inversion H. }
generalize (eq_refl (ev2v N t v)).
case: {2 3}(ev2v N t v).
2:{ intro H. exfalso. rewrite unfold_ev2v_val in H. inversion H. }
intros [[[? ?] ?] ?] HN.
intros [[[? ?] ?] ?] HSN.
generalize (ev2v_preserves_type HN (wf_exp_val WF_v)).
generalize (ev2v_preserves_type HSN (wf_exp_val WF_v)).
intros WF_v' WF_v''.
rewrite unfold_ev2v_val in HN, HSN. inversion HN. inversion HSN. subst.
replace WF_v' with WF_v by apply proof_irrelevance.
replace WF_v'' with WF_v by apply proof_irrelevance.
reflexivity.
Qed.

Lemma μTVKT_val T N v V WF_v :
μTVKT T N (exp_val v) (wf_exp_val WF_v) V = if V (Some (O, exist _ v WF_v)) then 1 else 0.
Proof.
induction N.
+ apply μTVKT_O_val.
+ rewrite μTVKT_S_val ; apply IHN.
Qed.

Lemma ρTVKT_O_nonval T t e WF_e V :
(∀ v, e = exp_val v → False) → ρTVKT T O t e WF_e V = 0.
Proof.
intro H. unfold ρTVKT.
generalize (eq_refl (ev2v 0 t e)).
case: {2 3}(ev2v 0 t e). 2:{ reflexivity. }
intros [[[k t'] v] w] H0. exfalso.
simpl ev2v in H0. destruct (exp_val_dec e) as [[u ?]|].
2:{ inversion H0. }
inversion H0. subst. eapply H. reflexivity.
Qed.

Lemma μTVKT_O_nonval T e WF_e V :
(∀ v, e = exp_val v → False) → μTVKT T O e WF_e V = 0.
Proof.
intro H. unfold μTVKT.
erewrite <- integration_of_0.
integrand_extensionality t.
apply ρTVKT_O_nonval ; apply H.
Qed.

Lemma μTVKT_stuck_S T N e WF_e V :
stop N e →
(∀ v, e = exp_val v → False) →
0 = μTVKT T (S N) e WF_e V.
Proof.
intros Hstop e_not_val.
replace 0 with (0 * μentropy full_event) ; [ | ring ].
erewrite <- integration_of_const with (f := λ _, 0) ; [ | intro ; ring ].
integrand_extensionality t.
unfold ρTVKT.
generalize (eq_refl (ev2v (S N) t e)).
case: {2 3}(ev2v (S N) t e). 2:{ reflexivity. }
intros [[[k t'] v] w] Ev_e. exfalso.
simpl in Ev_e.
destruct (exp_val_dec e) as [ [u Hu] | ].
1:{ subst. eapply e_not_val. reflexivity. }
destruct Hstop as [Stuck_e NotExn_e].
destruct (exp_ktx_exn_dec e) as [ [K ?] | ].
1:{ subst. eapply NotExn_e. reflexivity. }
destruct (sss_det (eval N) t e) as [ [?[?[?[? ?]]]] |].
2:{ inversion Ev_e. }
specialize (Stuck_e t). eapply Stuck_e. eassumption.
Qed.

Definition S_VKT T (V : Event (vkt T)) : Event (vkt T).
Proof.
intro o. destruct o as [ [k [v Wf_v]] | ].
+ refine (V (Some (S k, exist _ v Wf_v))).
+ refine (V None).
Defined.

Lemma S_VKT_Some T (V : Event (vkt T)) k v WF_v :
V (Some (S k, exist _ v WF_v)) = S_VKT T V (Some (k, exist _ v WF_v)).
Proof.
unfold S_VKT. reflexivity.
Qed.

Lemma sss_preserves_ρTVKT T N t t' e e' WF_e w:
sss (eval N) t e t' e' w →
∀ (V V' : Event (vkt T)) WF_e',
(∀ k v WF_v, V (Some (S k, exist _ v WF_v)) = V' (Some (k, exist _ v WF_v))) →
ρTVKT T (S N) t e WF_e V = (ρTVKT T N t' e' WF_e' V') * w.
Proof.
intros Hsss V V' WF_e' HV.
apply sss_ev2v in Hsss.
unfold ρTVKT.
generalize dependent Hsss.
generalize (eq_refl (ev2v N t' e')).
case: {2 3 4}(ev2v N t' e').
2:{
  intros Ev_e'. generalize (eq_refl (ev2v (S N) t e)).
  case: {2 3 4}(ev2v (S N) t e). 2:{ intros. ring. }
  intros [[[? ?] ?] ?] ? Q. inversion Q.
}
intros [[[k t''] v] w'] Ev_e.
generalize (eq_refl (ev2v (S N) t e)).
case: {2 3 4}(ev2v (S N) t e). 2:{ intros ? Q. inversion Q. }
intros [[[_k _t''] _v] _w'] Ev_e'.
intro Q; inversion Q; clear Q; subst.
replace (ev2v_preserves_type Ev_e' WF_e) with
        (ev2v_preserves_type Ev_e WF_e') by apply proof_irrelevance.
rewrite <-HV.
destruct (V _); ring.
Qed.

Lemma sss_preserves_μTVKT T N e e' WF_e w:
(∀ t, sss (eval N) t e t e' w) →
∀ (V V' : Event (vkt T)) WF_e',
(∀ k v WF_v, V (Some (S k, exist _ v WF_v)) = V' (Some (k, exist _ v WF_v))) →
μTVKT T (S N) e WF_e V = unif_score_meas w (μTVKT T N e' WF_e') V'.
Proof.
intros Hsss V V' WF_e' HV.
unfold μTVKT.
simpl unif_score_meas.
rewrite <- integration_linear_mult_r.
integrand_extensionality t.
apply sss_preserves_ρTVKT. 2:{ apply HV. } apply Hsss.
Qed.

Lemma μTVKT_is_μTV_fullevent
(T : ty) (N : nat) (e : exp0) (WF_e : wf_exp ∅→ e T) :
μTVKT T N e WF_e full_event = μTV N e full_event.
Proof.
unfold μTVKT, μTV. integrand_extensionality t.
rewrite <-ev2v_ρTV_same_weight.
unfold ρTVKT. generalize (eq_refl (ev2v N t e)).
case: {2 3}(ev2v N t e).
2:{ intro H. rewrite H. ring. }
intros [[[k t'] v] w] H. rewrite H. simpl. ring.
Qed.

Lemma ρTVKT_monotone_in_V T (V' V : Event (vkt T)) :
(∀ v, if V' v then V v = true else True) →
∀ N t e WF_e, ρTVKT T N t e WF_e V' ≤ ρTVKT T N t e WF_e V.
Proof.
intros HV N t e WF_e. unfold ρTVKT.
generalize (eq_refl (ev2v N t e)).
case: {2 3 10}(ev2v N t e).
2:{ intros. apply ennr_le_0. }
intros [[[k t'] v] w] H.
specialize (HV (Some (k, exist _ v (ev2v_preserves_type H WF_e)))).
destruct (V' _).
+ rewrite HV. apply ennr_le_refl.
+ apply ennr_le_0.
Qed.

Lemma ρTVKT_le_full_event T N t e WF_e V :
ρTVKT T N t e WF_e V ≤ ρTVKT T N t e WF_e full_event.
Proof.
apply ρTVKT_monotone_in_V.
intro v. destruct (V v); reflexivity.
Qed.

Lemma μTVKT_le_full_event T N e WF_e V :
μTVKT T N e WF_e V ≤ μTVKT T N e WF_e full_event.
Proof.
apply integrand_extensionality_le.
intro; apply ρTVKT_le_full_event.
Qed.

Lemma μTVKT_le_μNS T N e WF_e V :
μTVKT T N e WF_e V ≤ μNS N e.
Proof.
eapply ennr_le_trans ; [ apply μTVKT_le_full_event |].
rewrite μNS_decompose. rewrite μTVKT_is_μTV_fullevent.
apply ennr_add_le_compat_1.
Qed.

Lemma ktx_sample_unif_preserves_μTVKT T N K WF_KSU :
∀ (V V' : Event (vkt T)),
(∀ k v WF_v, V (Some (S k, exist _ v WF_v)) = V' (Some (k, exist _ v WF_v))) →
∀ (WF_Kr : ∀ r, wf_exp ∅→ (ktx_plug K (val_real r)) T),
μTVKT T (S N) (ktx_plug K (exp_sample val_unif)) WF_KSU V =
∫ (λ r, μTVKT T N (ktx_plug K (val_real r)) (WF_Kr r) V' *
   match (Rinterval_dec 0 1 r) with
   | left _ => 1
   | right _ => 0
   end) lebesgue_measure.
Proof.
intros V V' HV WF_Kr.
unfold μTVKT.
rewrite <- integration_πU_lebesgue.
replace (λ t, ρTVKT T (S N) t (ktx_plug K (exp_sample val_unif)) WF_KSU V)
  with (λ t, ρTVKT T N (πR t) (ktx_plug K (val_real (πU t))) (WF_Kr (πU t)) V').
2:{
  extensionality t.
  erewrite sss_preserves_ρTVKT with (w := 1) (V' := V') (WF_e' := WF_Kr (πU t)).
  3:{ apply HV. }
  1:{ rewrite ennr_mul_1_r. reflexivity. }
  apply ktx_congruence.
  apply sss_sample_unif.
}
setoid_rewrite <- integration_πL_πR.
reflexivity.
Qed.

Lemma ρTVKT_exn T N t K WF_e V : 0 = ρTVKT T N t (ktx_plug K exp_exn) WF_e V.
Proof.
unfold ρTVKT.
generalize (eq_refl (ev2v N t (ktx_plug K exp_exn))).
case: {2 3}(ev2v N t (ktx_plug K exp_exn)).
2:{ reflexivity. }
intros [[[k t'] v] w] H.
exfalso. rewrite ev2v_ktx_exn in H. inversion H.
Qed.

Lemma μTVKT_exn T N K WF_e V : 0 = μTVKT T N (ktx_plug K exp_exn) WF_e V.
Proof.
unfold μTVKT. erewrite integration_const_entropy. 1:{ reflexivity. }
intro t. apply eq_sym. apply ρTVKT_exn.
Qed.

Section section_μTVKT_monotone_S.

Hint Constructors wf_exp wf_val : core.

Lemma μTVKT_monotone_S T : ∀ N e WF_e V,
μTVKT T N e WF_e V ≤ μTVKT T (S N) e WF_e V.
Proof.
induction N as [|N IH]; intros.
1:{
  destruct (exp_val_dec e) as [[v ?]|].
  + inversion WF_e; subst; try discriminate. inversion H0; subst.
    replace WF_e with (wf_exp_val H) by apply proof_irrelevance.
    repeat rewrite μTVKT_val. apply ennr_le_refl.
  + rewrite μTVKT_O_nonval. 1:{ assumption. } apply ennr_le_0.
}
destruct (exp_val_dec e) as [[v ?]|Notval_e].
1:{
  subst. inversion WF_e; subst.
  replace WF_e with (wf_exp_val H0) by apply proof_irrelevance.
  repeat rewrite μTVKT_val. apply ennr_le_refl.
}
destruct (exp_ktx_exn_dec e) as [[K ?]|Notexn_e].
1:{ subst. repeat rewrite <-μTVKT_exn. apply ennr_le_refl. }
destruct (sss_exp_dec N e) as [ Step_e_N | Stop_e_N ].
2:{
  rewrite <- μTVKT_stuck_S with (N := N). 1:{ apply ennr_le_0. }
  + split; assumption.
  + assumption.
}
specialize (Step_e_N entropy0) as [t' [e' [w Step_e_N]]].
apply sss_quadfurcate in Step_e_N.
destruct Step_e_N as [ [Step_e_N Hw] | [ Step_e_N | [ Step_e_N | Step_e_N ]] ].
+ eapply sss_preserves_type in WF_e as WF_e'.
  2:{ apply (Step_e_N O entropy0). }
  erewrite sss_preserves_μTVKT with (N := N) (V' := S_VKT T V) (WF_e' := WF_e').
  2:{ apply Step_e_N. } 2:{ reflexivity. }
  erewrite sss_preserves_μTVKT with (N := S N) (V' := S_VKT T V) (WF_e' := WF_e').
  2:{ apply Step_e_N. } 2:{ reflexivity. }
  cbn. apply ennr_mult_le_compat_r. apply IH.
+ destruct Step_e_N as [K [f [? [? [? [? ?]]]]]]. subst.
  assert (Step_Kf : ∀ t, sss (eval N) t (ktx_plug K (exp_sample (val_query f))) t (ktx_plug K f) (/ μNS N f)).
  1:{ intro. apply ktx_congruence. apply sss_sample_query. assumption. }
  specialize (Step_Kf entropy0) as WF_Kf.
  eapply sss_preserves_type in WF_Kf. 2:{ apply WF_e. }
  erewrite sss_preserves_μTVKT with (N := N) (V' := S_VKT T V) (WF_e' := WF_Kf).
  2:{ apply Step_Kf. } 2:{ reflexivity. }
  destruct (ennr_0_lt_dec (μNS (S N) f)) as [NS_SN|NS_SN].
  1:{
    erewrite sss_preserves_μTVKT with (N := S N) (V' := S_VKT T V) (WF_e' := WF_Kf).
    2:{ intro. apply ktx_congruence. apply sss_sample_query. assumption. }
    2:{ reflexivity. }
    unfold unif_score_meas. apply ennr_mult_le_compat.
    + apply IH.
    + apply ennr_mult_inv_le_compat. apply μNS_antitone_S.
  }
  unfold unif_score_meas.
  replace (μTVKT T N (ktx_plug K f) _ _) with 0.
  1:{ rewrite ennr_mul_0_l. apply ennr_le_0. }
  apply ennr_le_0_is_0.
  rewrite NS_SN. eapply ennr_le_trans. 1:{ apply IH. }
  eapply ennr_le_trans. 1:{ apply μTVKT_le_μNS. }
  apply μNS_ktx_plug_le.
+ destruct Step_e_N as [K [f [? [NS_N [? [? ?]]]]]]. subst.
  assert (0 = μNS (S N) f) as NS_SN.
  1:{ apply ennr_le_0_is_0. rewrite NS_N. apply μNS_antitone_S. }
  assert (Step_Kf : ∀ t, sss (eval N) t (ktx_plug K (exp_sample (val_query f))) t (ktx_plug K exp_exn) 1).
  1:{ intro. apply ktx_congruence. apply sss_sample_query_exn. assumption. }
  specialize (Step_Kf entropy0) as WF_Kdiv.
  eapply sss_preserves_type in WF_Kdiv. 2:{ apply WF_e. }
  erewrite sss_preserves_μTVKT with (N := N) (V' := S_VKT T V) (WF_e' := WF_Kdiv).
  3:{ reflexivity. } 2:{ apply Step_Kf. }
  erewrite sss_preserves_μTVKT with (N := S N) (V' := S_VKT T V) (WF_e' := WF_Kdiv).
  3:{ reflexivity. }
  2:{ intro t. apply ktx_congruence. apply sss_sample_query_exn. apply NS_SN. }
  cbn. repeat rewrite ennr_mul_1_r. apply IH.
+ destruct Step_e_N as [K [? [? [? ?]]]]. subst.
  assert (WF_Kr : ∀ r, wf_exp ∅→ (ktx_plug K (val_real r)) T).
  1:{
    clear- WF_e. generalize dependent T.
    induction K; simpl; intros; solve_pt; eauto.
  }
  erewrite ktx_sample_unif_preserves_μTVKT
    with (N := N) (V' := S_VKT T V) (WF_Kr := WF_Kr).
  2:{ reflexivity. }
  erewrite ktx_sample_unif_preserves_μTVKT
    with (N := S N) (V' := S_VKT T V) (WF_Kr := WF_Kr).
  2:{ reflexivity. }
  apply integrand_extensionality_le. intro t.
  apply ennr_mult_le_compat_r. apply IH.
Qed.

End section_μTVKT_monotone_S.

Lemma μTVKT_monotone T e A N' N WF_e :
N' <= N → μTVKT T N' e WF_e A ≤ μTVKT T N e WF_e A.
Proof.
induction 1 as [ | ? ? IH ] ; intros.
+ apply ennr_le_refl.
+ eapply ennr_le_trans; [ apply IH | ].
  apply μTVKT_monotone_S.
Qed.

Fact μTV_minus_νNS_pushforward_lim_μTVKT
T K e (WF_e : wf_exp ∅→ e T)
(HL : has_lim (λ n, μTV n e full_event - νNS n K e)) :
lim (λ n, μTV n e full_event - νNS n K e) HL =
∫ (λ v : vkt T, 1 - match v with
  | Some (_, exist _ v _) => μNS_inf (ktx_plug K v)
  | None => 0
end
) (μTVKT_sup T e WF_e).
Proof.
rewrite <-sup_is_lim' by apply μTV_minus_νNS_monotone.
specialize μTV_minus_νNS_pushforward_μTVKT with (WF_e := WF_e) as H.
setoid_rewrite H.
rewrite interchange_sup_integration_meas.
3:{
  integrand_extensionality v. destruct v as [[k [v WF_v]]|].
  2:{ apply sup_of_constant. intro; ring. }
  rewrite sup_of_constant_minus. apply f_equal2. 1:{ ring. }
  unfold μNS_inf. erewrite inf_antitone with (k := k).
  2:{ do 3 intro. apply μNS_antitone. omega. }
  apply f_equal. extensionality n.
  replace (n + k - k)%nat with n by omega. reflexivity.
}
2:{ intros. do 3 intro. apply μTVKT_monotone. omega. }
1:{
  intros [[k [v ?]]|].
  2:{ rewrite ennr_minus_0. do 3 intro. apply ennr_le_refl. }
  do 3 intro. apply ennr_minus_le_compat_r; try apply μNS_le_1.
  apply μNS_antitone. omega.
}
Qed.

Fact μTV_minus_νNS_pushforward_lim_μTVT
T K e (WF_e : wf_exp ∅→ e T)
(HL : has_lim (λ n, μTV n e full_event - νNS n K e)) :
lim (λ n, μTV n e full_event - νNS n K e) HL =
∫ (λ v : vt T, 1 - match v with
  | Some (exist _ v _) => μNS_inf (ktx_plug K v)
  | None => 0
end
) (μTVT_sup T e WF_e).
Proof.
specialize μTV_minus_νNS_pushforward_lim_μTVKT with (WF_e := WF_e) as H.
rewrite H. clear H.
apply integration_wrt_redundant_var. 1:{ ring. } 1:{ intros. ring. }
intro X. unfold μTVKT_sup, μTVT_sup. f_equal.
Qed.
End section_μTV_minus_νNS_pushforward.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e511m187_11limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition sub :
  { sub : feBW_tight -> feBW_tight -> feBW_loose
  | forall a b, phiBW_loose (sub a b) = F.sub (phiBW_tight a) (phiBW_tight b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_sub ().
  Show Ltac Profile.
Time Defined.

Print Assumptions sub.


Require Import ZArith.

From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq choice fintype.

Require Import TestingCommon.

Import LabelEqType.

Definition is_low_pointer (obs : Label) (a : Atom) : bool :=
  match a with
    | Vptr p @ l => isLow l obs
    | _ => false
  end.

Definition extract_mframe (a : Atom) : option mframe :=
  match a with
    | Vptr (Ptr fp _) @ _ => Some fp
    | _ => None
  end.

Definition elem {A : Type} (eq_dec : forall (x y : A), {x = y} + {x <> y})
           (x : A) (l : list A) : bool :=
  has (fun y => if eq_dec x y then true else false) l.

(* This unions two sets while removing duplicates *)
Fixpoint nub_by_aux (A : eqType) (l acc : list A) : list A :=
  match l with
    | [::] => acc
    | h::t =>
      if h \in acc
      then nub_by_aux A t acc
      else nub_by_aux A t (h::acc)
  end.

(* This removes duplicates from a list *)
Definition nub_by {A : eqType} (l : list A) := nub_by_aux A l [::].

Definition get_mframes_from_atoms (obs : Label) (atoms : list Atom)
  : list mframe :=
  nub_by (pmap extract_mframe (filter (is_low_pointer obs) atoms)).

Fixpoint get_root_set_stack (obs : Label)
         (acc : list mframe) (s : list StackFrame) : list mframe :=
  match s with
    | nil => acc
    | (SF pc rs _ _) :: s' =>
      let new_mframes :=
          if isLow ∂pc obs then get_mframes_from_atoms obs rs
          else [::] in
      let acc' := nub_by_aux _ new_mframes acc in
      get_root_set_stack obs acc' s'
  end.

Definition get_root_set (obs : Label) (st : SState) : list mframe :=
  let '(St _ _ s r pc) := st in
  let init_root_set :=
      if isLow ∂pc obs then get_mframes_from_atoms obs r
      else [::] in
  get_root_set_stack obs init_root_set (unStack s).

Function reachable_from_root_set (obs : Label) (st : SState)
         (visited worklist : list mframe)
  {measure (fun w => 0) worklist} (* TODO: prove termination?
     CH: Yes, but this measure is completely bogus; a good measure would be the
         length (all frames / (visited / workist)), or something like that *)
  : list mframe :=
  match worklist with
    | [::] => visited
    | h::t =>
      if h \in visited then
        reachable_from_root_set obs st visited t
      else
        match get_memframe (st_mem st) h with
          | Some (Fr l atoms) =>
            let newCands :=
                if isLow l obs then
                  get_mframes_from_atoms obs atoms
                else [::] in
            let worklist' := nub_by_aux _ newCands t in
            reachable_from_root_set obs st (h :: visited) worklist'
          | _ => reachable_from_root_set obs st (h :: visited) t
        end
  end.
Proof.
Admitted.

Definition reachable (obs : Label) (st : SState) : list mframe :=
  let root_set := get_root_set obs st in
  reachable_from_root_set obs st [::] root_set.

Definition well_formed_label (st : SState) (l : Label) : bool :=
  let observable := reachable l st in
  all (fun mf => let s := Memory.stamp mf in isLow s l) observable.

(* Given a SState and a stamp configuration, make sure everything is ok *)
(* LL: This also suggests a way of generating stamps! Namely, get
   the meet of all the labels where a frame is reachable *)
Definition well_formed (st : SState) : bool :=
  all (well_formed_label st) all_labels.

(* Computes the meet of a list of labels. Must be provided with top as the
   initial accumulator *)
Definition list_meet (acc : Label) (ls : list Label) :=
  foldl meet acc ls.


Require Import VerdiRaft.Raft.

Section CurrentTermGtZeroInterface.
  Context {orig_base_params : BaseParams}.
  Context {one_node_params : OneNodeParams orig_base_params}.
  Context {raft_params : RaftParams orig_base_params}.

  Definition current_term_gt_zero (net : network) :=
    forall h,
      type (nwState net h) <> Follower ->
      1 <= currentTerm (nwState net h).

  Class current_term_gt_zero_interface : Prop := {
    current_term_gt_zero_invariant : forall net,
      raft_intermediate_reachable net ->
      current_term_gt_zero net
  }.
End CurrentTermGtZeroInterface.