(* An oracle machine semantics for computations. *)

Set Implicit Arguments.

Require Export Comp.
Require Import Blist.
Require Import Fold.
Require Import Permutation.

Local Open Scope list_scope.
Local Open Scope comp_scope.

(* A type for keeping track of the state of the evaluation. *)
Inductive comp_state(A : Set) :=
  | cs_done : A -> Blist -> comp_state A
  | cs_eof : comp_state A
  | cs_more : Comp A -> Blist -> comp_state A.

(* a type for returning answers *)
Inductive comp_answer(A : Set) :=
  | ca_done : A -> comp_answer A
  | ca_eof : comp_answer A.

Lemma comp_answer_eq_dec : forall (A : Set),
      eq_dec A ->
      eq_dec (comp_answer A).

  intuition.
  unfold eq_dec in *.
  intuition.
  destruct a1; destruct a2.
  destruct (H a a0); subst.
  left.
  trivial.
  right.
  intuition.
  inversion H0; clear H0; subst.
  intuition.
  right; intuition; discriminate.
  right; intuition; discriminate.
  left.
  trivial.
Qed.

(* a functional form of the small-step semantics*)
Fixpoint evalDet_step(A : Set)(c : Comp A)(s : Blist) : comp_state A :=
  match c in Comp A return comp_state A with
    | Ret _ pf a => cs_done a s
    | Rnd n  =>
      match (shiftOut s n) with
        | Some (v, s') => cs_more (Ret (@Bvector_eq_dec n) v) s'
        | None => (@cs_eof (Bvector n))
      end
    | Bind A B c1 c2 =>
      match (evalDet_step c1 s) with
        | cs_eof => (@cs_eof A)
        | cs_done b s' => cs_more (c2 b) s'
        | cs_more c1' s' => cs_more (Bind c1' c2) s'
      end
    | Repeat A c P =>
      cs_more (Bind c (fun a => if (P a) then (Ret (comp_eq_dec c) a) else (Repeat c P))) s
   end.

Inductive evalDet_steps(A : Set) : comp_state A -> comp_state A -> Prop :=
  | evalDet_steps_refl : forall ans,
    evalDet_steps ans ans
  | evalDet_steps_step :
    forall c s ans ans',
      (evalDet_step c s) = ans ->
      evalDet_steps ans ans' ->
      evalDet_steps (cs_more c s) ans'.

Hint Constructors evalDet_steps : evalDet.

Inductive evalDet(A : Set)(c : Comp A)(s : Blist) : comp_answer A -> Prop :=
  | evalDet_done : forall a s',
    evalDet_steps (cs_more c s) (cs_done a s') ->
    evalDet c s (ca_done a)
  | evalDet_eof :
    evalDet_steps (cs_more c s) (@cs_eof A) ->
    evalDet c s (@ca_eof A).

Theorem evalDet_steps_trans : forall (A : Set)(x y : comp_state A),
  evalDet_steps x y ->
  forall z,
  evalDet_steps y z ->
  evalDet_steps x z.

  induction 1; intuition; subst.
  econstructor.
  trivial.
  eapply IHevalDet_steps.
  trivial.

Qed.

Theorem evalDet_steps_bind_more_h : forall(A B : Set) x y,
  evalDet_steps x y ->
  forall (c1 : Comp B)(c2 : B -> Comp A) s c1' s',
  x = (cs_more c1 s) ->
  y =  (cs_more c1' s') ->
  evalDet_steps (cs_more (Bind c1 c2) s) (cs_more (Bind c1' c2) s').

  induction 1; intuition; subst.

  Ltac evalDet_tac1 :=
    match goal with
      | [H : cs_more _ _ = cs_more _ _ |- _ ] => inversion H; clear H; subst
      | [|- evalDet_steps ?c ?c ] => econstructor
      | [H : evalDet_steps (evalDet_step ?c ?s) _ |- evalDet_steps (cs_more (Bind ?c _) ?s) _ ] => inversion H; clear H; subst
      | [H : (evalDet_step ?c ?s) = _ |- evalDet_steps (cs_more (Bind ?c _) ?s) _ ] => econstructor; simpl
      | [|- context[match ?x with | cs_done _ _ => _ | cs_eof => _ | cs_more _ _ => _ end] ] => case_eq x; intuition

    end.

  repeat evalDet_tac1.

  inversion H0; clear H0; subst.
  inversion H1; clear H1; subst.
  econstructor.
  eauto.
  simpl.
  rewrite H3.
  econstructor.

  inversion H1; clear H1; subst.
  econstructor.
  eauto.
  simpl.
  rewrite <- H.
  eapply IHevalDet_steps.
  auto.
  trivial.

Qed.

Theorem evalDet_steps_bind_more : forall(A B : Set)(c1 : Comp B)(c2 : B -> Comp A) s c1' s',
  evalDet_steps (cs_more c1 s) (cs_more c1' s') ->
  evalDet_steps (cs_more (Bind c1 c2) s) (cs_more (Bind c1' c2) s').

  intuition.
  eapply evalDet_steps_bind_more_h; eauto.
Qed.

Lemma evalDet_steps_done_inv_h : forall (A : Set)(x y : comp_state A),
  evalDet_steps x y ->
  forall (c : Comp A)(a : A) s s',
  x = (cs_more c s) ->
  y = (cs_done a s') ->
  exists c'' s'', evalDet_steps (cs_more c s) (cs_more c'' s'') /\ evalDet_step c'' s'' = (cs_done a s').

  induction 1; intuition; subst.
  discriminate.

  inversion H1; clear H1; subst.
  inversion H0; clear H0; subst.
  econstructor. econstructor.
  intuition.

  destruct (IHevalDet_steps c a s s'); eauto.
  destruct H0; intuition.
  exists x.
  exists x0.
  intuition.
  symmetry in H.
  econstructor.
  eapply H.
  trivial.
Qed.

Lemma evalDet_steps_done_inv : forall (A : Set)(c : Comp A)(a : A) s s',
  evalDet_steps (cs_more c s) (cs_done a s') ->
  exists c'' s'', evalDet_steps (cs_more c s) (cs_more c'' s'') /\ evalDet_step c'' s'' = (cs_done a s').

  intuition.
  eapply evalDet_steps_done_inv_h; eauto.
Qed.

Lemma evalDet_steps_eof_inv_h : forall (A : Set)(x y : comp_state A),
  evalDet_steps x y ->
  forall (c : Comp A) s,
  x = (cs_more c s) ->
  y = (@cs_eof A) ->
  exists c'' s'', evalDet_steps (cs_more c s) (cs_more c'' s'') /\ evalDet_step c'' s'' = (@cs_eof A).

  induction 1; intuition; subst.
  discriminate.
  inversion H1; clear H1; subst.
  inversion H0; clear H0; subst.
  econstructor. econstructor.
  intuition.

  destruct (IHevalDet_steps c s); eauto.
  destruct H0; intuition.
  exists x.
  exists x0.
  intuition.
  econstructor.
  rewrite <- H.
  eauto.
  rewrite <- H.
  trivial.
Qed.

Lemma evalDet_steps_eof_inv : forall (A : Set)(c : Comp A) s,
  evalDet_steps (cs_more c s) (@cs_eof A) ->
  exists c'' s'', evalDet_steps (cs_more c s) (cs_more c'' s'') /\ evalDet_step c'' s'' = (@cs_eof A).

  intuition.
  eapply evalDet_steps_eof_inv_h; eauto.
Qed.

Theorem evalDet_steps_bind_done : forall(A B : Set)(c1 : Comp B)(c2 : B -> Comp A) a s s',
  evalDet_steps (cs_more c1 s) (cs_done a s') ->
  evalDet_steps (cs_more (Bind c1 c2) s) (cs_more (c2 a) s').

  intuition.
  apply evalDet_steps_done_inv in H.
  destruct H.
  destruct H.
  intuition.
  eapply evalDet_steps_trans.
  eapply evalDet_steps_bind_more.
  eauto.
  econstructor.
  simpl.
  rewrite H1.
  eauto.
  econstructor.
Qed.

Theorem evalDet_bind_eof : forall(A B : Set)(c1 : Comp B)(c2 : B -> Comp A) s,
  evalDet_steps (cs_more c1 s) (@cs_eof B) ->
  evalDet_steps (cs_more (Bind c1 c2) s) (@cs_eof A).

  intuition.
  apply evalDet_steps_eof_inv in H.
  destruct H.
  destruct H.
  intuition.
  eapply evalDet_steps_trans.
  eapply evalDet_steps_bind_more.
  eauto.
  econstructor.
  simpl.
  rewrite H1.
  eauto.
  econstructor.
Qed.

Inductive comp_state_eq(A : Set) : comp_state A -> comp_state A -> Prop :=
  | cse_done :
    forall a s,
      comp_state_eq (cs_done a s) (cs_done a s)
  | cse_eof :
    comp_state_eq (@cs_eof A) (@cs_eof A)
  | cse_more :
    forall c1 c2 s,
      Comp_eq c1 c2 ->
      comp_state_eq (cs_more c1 s) (cs_more c2 s).

Theorem comp_state_eq_refl : forall (A : Set)(c : comp_state A),
  comp_state_eq c c.

  destruct c; intuition;
  econstructor.
  eapply Comp_eq_refl.
Qed.

Lemma evalDet_steps_done_func_h : forall (A : Set)(x : comp_state A) y1,
  evalDet_steps x y1 ->
  forall a a' s s',
  y1 = (cs_done a s) ->
  evalDet_steps x (cs_done a' s') ->
  (a = a' /\ s = s').

  induction 1; intros; subst.
  inversion H0; clear H0; subst.
  intuition.

  inversion H2; clear H2; subst.
  eapply IHevalDet_steps;
  trivial.
Qed.

Theorem evalDet_steps_done_func : forall (A : Set) x (a a' : A) s s',
  evalDet_steps x (cs_done a s) ->
  evalDet_steps x (cs_done a' s') ->
  (a = a' /\ s = s').

  intros.
  eapply evalDet_steps_done_func_h.
  eapply H.
  eauto.
  eauto.
Qed.

Lemma evalDet_steps_done_eof_func_h : forall (A : Set)(x : comp_state A) y1,
  evalDet_steps x y1 ->
  forall a s,
  y1 = (cs_done a s) ->
  evalDet_steps x (@cs_eof A) ->
  False.

  induction 1; intros; subst.
  inversion H0.

  inversion H2; clear H2; subst.
  eapply IHevalDet_steps;
  trivial.
Qed.

Theorem evalDet_steps_done_eof_func : forall (A : Set) x (a : A) s,
  evalDet_steps x (cs_done a s) ->
  evalDet_steps x (@cs_eof A) ->
  False.

  intros.
  eapply evalDet_steps_done_eof_func_h.
  eapply H.
  eauto.
  eauto.
Qed.

Theorem evalDet_func : forall (A : Set)(c : Comp A)(s : Blist)(y1 y2 : comp_answer A),
  evalDet c s y1 ->
  evalDet c s y2 ->
  y1 = y2.

  intuition.
  inversion H; subst; clear H.
  inversion H0; subst; clear H0.
  f_equal.
  eapply evalDet_steps_done_func; eauto.

  exfalso.
  eapply evalDet_steps_done_eof_func; eauto.

  inversion H0; clear H0; subst.
  exfalso.
  eapply evalDet_steps_done_eof_func; eauto.

  trivial.
Qed.

Definition evalDet_equiv(A : Set)(c1 c2 : Comp A) :=
  (forall s y, evalDet c1 s y <-> evalDet c2 s y).

Lemma evalDet_equiv_symm : forall (A : Set)(c1 c2 : Comp A),
  evalDet_equiv c1 c2 ->
  evalDet_equiv c2 c1.

  unfold evalDet_equiv. intuition.
  eapply H; trivial.
  eapply H; trivial.
Qed.

Theorem evalDet_steps_bind_done_inv_h : forall (A : Set)(x y : comp_state A),
  evalDet_steps x y ->
  forall (B : Set)(c1 : Comp B)(c2 : B -> Comp A) s s' a,
    x = (cs_more (Bind c1 c2) s) ->
    y = (cs_done a s') ->
  exists b s'', evalDet_steps (cs_more c1 s) (cs_done b s'') /\
    evalDet_steps (cs_more (c2 b) s'') (cs_done a s').

  induction 1; intuition; subst.
  discriminate.
  inversion H1; clear H1; subst.
  inversion H0; clear H0; subst.
  case_eq (evalDet_step c1 s0); intuition;
  rewrite H in H2; discriminate.

  case_eq (evalDet_step c1 s0); intuition;
  rewrite H0 in H.
  inversion H; clear H; subst.
  econstructor. econstructor. intuition.
  econstructor.
  eapply H0.
  econstructor.
  econstructor; eauto.

  discriminate.

  inversion H; clear H; subst.
  edestruct IHevalDet_steps.
  simpl.
  rewrite H0.
  eauto.
  eauto.
  destruct H.
  intuition.

  econstructor. econstructor. intuition.
  econstructor.
  eapply H0.
  eauto.
  trivial.
Qed.

Theorem evalDet_steps_bind_done_inv : forall (A B : Set)(c1 : Comp B)(c2 : B -> Comp A) s s' a,
  evalDet_steps (cs_more (Bind c1 c2) s) (cs_done a s') ->
  exists b s'', evalDet_steps (cs_more c1 s) (cs_done b s'') /\
    evalDet_steps (cs_more (c2 b) s'') (cs_done a s').

  intuition.
  eapply evalDet_steps_bind_done_inv_h; eauto.

Qed.

Theorem evalDet_steps_bind_eof_inv_h :
  forall (A : Set)(x y : comp_state A),
    evalDet_steps x y ->
    forall (B : Set)(c1 : Comp B)(c2 : B -> Comp A) s,
      x = (cs_more (Bind c1 c2) s) ->
      y = (@cs_eof A) ->
      evalDet_steps (cs_more c1 s) (@cs_eof B) \/
      exists b s', evalDet_steps (cs_more c1 s) (cs_done b s') /\
        evalDet_steps (cs_more (c2 b) s') (@cs_eof A).

  induction 1; intuition; subst.
  discriminate.

  inversion H1; clear H1; subst.
  inversion H0; clear H0; subst.
  case_eq (evalDet_step c1 s0); intuition;
  rewrite H in H2.
  discriminate.
  left.
  econstructor.
  rewrite H.
  eauto.
  econstructor.
  discriminate.

  case_eq (evalDet_step c1 s0); intuition;
  rewrite H0 in H.
  inversion H; clear H; subst.
  right.
  econstructor. econstructor. intuition.
  econstructor.
  eauto.
  econstructor.
  econstructor.
  eauto.
  trivial.

  discriminate.

  inversion H; clear H; subst.
  edestruct (IHevalDet_steps).
  simpl.
  rewrite H0.
  eauto.
  trivial.
  left.
  econstructor; eauto.
  destruct H. destruct H. intuition.
  right.
  econstructor. econstructor. intuition.
  econstructor; eauto.
  trivial.

Qed.

Theorem evalDet_steps_bind_eof_inv : forall (A B : Set)(c1 : Comp B)(c2 : B -> Comp A) s,
  evalDet_steps (cs_more (Bind c1 c2) s) (@cs_eof A) ->
  evalDet_steps (cs_more c1 s) (@cs_eof B) \/
  exists b s', evalDet_steps (cs_more c1 s) (cs_done b s') /\
    evalDet_steps (cs_more (c2 b) s') (@cs_eof A).

  intuition.
  eapply evalDet_steps_bind_eof_inv_h; eauto.
Qed.

Theorem evalDet_bind_assoc : forall (A : Set)(c1 : Comp A)(B C : Set)(c2 : A -> Comp B)(c3 : B -> Comp C),
  evalDet_equiv (Bind (Bind c1 c2) c3) (Bind c1 (fun a => (Bind (c2 a) c3))).

  intuition.
  unfold evalDet_equiv.
  intuition.
  inversion H; clear H; subst.

  Ltac evalDet_tac :=
    match goal with
      | [H1 : evalDet_steps ?x (cs_done ?a1 ?s1), H2 : evalDet_steps ?x (@cs_eof _) |- _ ] => exfalso; eauto using evalDet_steps_done_eof_func; intuition
      | [H : evalDet_steps (cs_more (Bind _ _) _) (cs_done _ _) |- _ ] => apply evalDet_steps_bind_done_inv in H
      | [H : evalDet_steps (cs_more (Bind _ _) _) (@cs_eof _) |- _ ] => apply evalDet_steps_bind_eof_inv in H; intuition
      | [H : exists _ : _, _ |- _ ] => destruct H; intuition
      | [H1 : evalDet_steps ?x (cs_done ?a1 ?s1), H2 : evalDet_steps ?x (cs_done ?a2 ?s2) |- _ ] => assert (a1 = a2 /\ s1 = s2); eauto using evalDet_steps_done_func; intuition; subst; clear H1; eauto
    end.
  repeat evalDet_tac.
  econstructor.
  eapply evalDet_steps_trans.
  eapply evalDet_steps_bind_done; eauto.
  eapply evalDet_steps_trans.
  eapply evalDet_steps_bind_done; eauto.
  eauto.

  repeat evalDet_tac.
  econstructor.
  eapply evalDet_bind_eof; eauto.
  econstructor.
  eapply evalDet_steps_trans.
  eapply evalDet_steps_bind_done; eauto.
  eapply evalDet_bind_eof; eauto.
  econstructor.
  eapply evalDet_steps_trans.
  eapply evalDet_steps_bind_done; eauto.
  eapply evalDet_steps_trans.
  eapply evalDet_steps_bind_done; eauto.
  eauto.

  inversion H; clear H; subst.
  repeat evalDet_tac.
  econstructor.
  eapply evalDet_steps_trans.
  eapply evalDet_steps_bind_done; eauto.
  eapply evalDet_steps_trans.
  eapply evalDet_steps_bind_done; eauto.
  eauto.
  eauto.

  repeat evalDet_tac.
  econstructor.
  eapply evalDet_steps_trans.
  eapply evalDet_bind_eof; eauto.
  eapply evalDet_bind_eof; eauto.
  econstructor.
  econstructor.
  eapply evalDet_bind_eof.
  eapply evalDet_steps_trans.
  eapply evalDet_steps_bind_done; eauto.
  eauto.
  econstructor.
  eapply evalDet_steps_trans.
  eapply evalDet_steps_bind_done; eauto.
  eapply evalDet_steps_trans.
  eapply evalDet_steps_bind_done; eauto.
  eauto.
  eauto.

Qed.

Theorem evalDet_done_eof_func:
  forall (A : Set) (c : Comp A) (a : A) (s : Blist),
    evalDet c s (ca_done a) -> evalDet c s (@ca_eof A) -> False.

  intuition.
  inversion H; clear H; subst.
  inversion H0; clear H0; subst.
  eapply evalDet_steps_done_eof_func; eauto.
Qed.

Lemma getSupport_In_evalDet_step_done : forall (A : Set)(c : Comp A) a s s',
  evalDet_step c s = cs_done a s' ->
  In a (getSupport c).

  induction c; intuition; simpl in *.

  inversion H; clear H; subst.
  intuition.

  destruct (evalDet_step c s); try discriminate.

  eapply in_getAllBvectors.

  discriminate.
Qed.

Lemma getSupport_In_evalDet_step_more : forall (A : Set)(c c' : Comp A) s s' a,
  evalDet_step c s = cs_more c' s' ->
  In a (getSupport c') ->
  In a (getSupport c).

  induction c; intuition; simpl in *.
  discriminate.

  case_eq (evalDet_step c s); intuition;
    rewrite H2 in H0.
  inversion H0; clear H0; subst.
  eapply in_getUnique.
  eapply in_flatten.
  exists (getSupport (c0 b)).
  intuition.
  eapply in_map_iff.
  exists b.
  intuition.
  eapply getSupport_In_evalDet_step_done; eauto.

  discriminate.

  inversion H0; clear H0; subst.
  simpl in *.
  apply in_getUnique_if in H1.
  apply in_flatten in H1.
  destruct H1; intuition.
  eapply in_getUnique.
  eapply in_flatten.
  exists x.
  intuition.
  apply in_map_iff in H1.
  destruct H1; intuition.
  subst.
  eapply in_map_iff.
  exists x0.
  intuition.
  eapply IHc; eauto.

  eapply in_getAllBvectors.

  inversion H; clear H; subst.
  simpl in *.
  eapply in_getUnique_if in H0.
  eapply in_flatten in H0.
  destruct H0.
  intuition.
  eapply in_map_iff in H0.
  destruct H0.
  intuition.
  subst.
  case_eq (b x0); intuition;
  rewrite H in H1; simpl in *.
  intuition; subst.
  eapply filter_In; eauto.
  trivial.

Qed.

Lemma getSupport_In_evalDet_steps_h : forall (A : Set)(x y : comp_state A),
  evalDet_steps x y ->
  forall (c : Comp A) a s s',
    x = (cs_more c s)  ->
    y = (cs_done a s') ->
    In a (getSupport c).

  induction 1; intuition; subst.
  discriminate.

  inversion H1; clear H1; subst.
  inversion H0; clear H0; subst.

  eapply getSupport_In_evalDet_step_done; eauto.

  eapply getSupport_In_evalDet_step_more.
  eauto.
  eapply IHevalDet_steps.
  eauto.
  eauto.
Qed.

Lemma getSupport_In_evalDet_steps : forall (A : Set)(c : Comp A) a s s',
  evalDet_steps (cs_more c s) (cs_done a s') ->
  In a (getSupport c).

  intuition.
  eapply getSupport_In_evalDet_steps_h; eauto.
Qed.

Theorem getSupport_In_evalDet : forall (A : Set)(c : Comp A) a s,
  evalDet c s (ca_done a) ->
  In a (getSupport c).

  intuition.
  inversion H; clear H; subst.

  eapply getSupport_In_evalDet_steps; eauto.

Qed.

(* The following predicate makes it easier for us to do induction on the number of loop iterations. *)
Inductive evalDet_repeat_steps (A : Set)(P : A -> bool) : comp_state A -> comp_state A -> Prop :=
| evalDet_repeat_steps_done :
  forall c s a s',
    evalDet_steps (cs_more c s) (cs_done a s') ->
    P a = true ->
    evalDet_repeat_steps P (cs_more c s) (cs_done a s')
| evalDet_repeat_steps_eof :
  forall c s,
    evalDet_steps (cs_more c s) (@cs_eof A) ->
    evalDet_repeat_steps P (cs_more c s) (@cs_eof A)
| evalDet_repeat_steps_step :
  forall c s a s' y,
    evalDet_steps (cs_more c s) (cs_done a s') ->
    P a = false ->
    evalDet_repeat_steps P (cs_more c s') y ->
    evalDet_repeat_steps P (cs_more c s) y.

Inductive evalDet_repeat(A : Set)(P : A -> bool)(c : Comp A)(s : Blist) : comp_answer A -> Prop :=
  | evalDet_repeat_done : forall a s',
    evalDet_repeat_steps P (cs_more c s) (cs_done a s') ->
    evalDet_repeat P c s (ca_done a)
  | evalDet_repeat_eof :
    evalDet_repeat_steps P (cs_more c s) (@cs_eof A) ->
    evalDet_repeat P c s (@ca_eof A).

Lemma list_skipn_strong_ind_h : forall (A : Type) l (P : list A -> Prop) ,
  P nil ->
  (forall x, (forall n, n > 0 -> P (skipn n x)) -> P x) ->
  (forall n, P (skipn n l)).

  induction l;
  intuition; simpl in *.

  destruct n; simpl in *; trivial.

  destruct n; simpl in *.
  eapply H0.
  intuition.
  destruct n; try omega; simpl in *.
  eapply IHl; intuition.

  eapply IHl; intuition.
Qed.

Lemma list_skipn_strong_ind : forall (A : Type) l (P : list A -> Prop) ,
  P nil ->
  (forall x, (forall n, n > 0 -> P (skipn n x)) -> P x) ->
  P l.

  intuition.
  assert (l = skipn 0 l).
  simpl.
  trivial.
  rewrite H1.
  eapply list_skipn_strong_ind_h; trivial.

Qed.

Lemma evalDet_step_nil_inv : forall (A : Set)(c : Comp A)(a1 a2 : A) s2,
  evalDet_step c nil = (cs_done a2 s2) ->
  In a1 (getSupport c) ->
  a1 = a2.

  induction c; intuition; simpl in *; intuition; subst.

  inversion H; clear H; subst.
  trivial.

  destruct (evalDet_step c nil); discriminate.

  destruct n; try discriminate.

  discriminate.

Qed.

Lemma evalDet_step_done_nil_inv : forall (A : Set)(c : Comp A) a ls,
  evalDet_step c nil = (cs_done a ls) ->
  ls = nil.

  induction c; intuition; simpl in *.
  inversion H; clear H; subst.
  trivial.

  case_eq (evalDet_step c nil); intuition;
    rewrite H1 in H0;
      discriminate.

  destruct n;
    discriminate.

  discriminate.
Qed.

Lemma evalDet_step_more_nil_inv : forall (A : Set)(c c' : Comp A) ls,
  evalDet_step c nil = (cs_more c' ls) ->
  ls = nil.

  induction c; intuition; simpl in *.
  discriminate.

  case_eq (evalDet_step c nil); intuition;
    rewrite H1 in H0.
  inversion H0; clear H0; subst.
  eapply evalDet_step_done_nil_inv; eauto.
  discriminate.
  inversion H0; clear H0; subst.
  eauto.

  destruct n.
  inversion H; clear H; subst.
  trivial.
  discriminate.

  inversion H; clear H; subst.
  trivial.

Qed.

Lemma evalDet_step_done_support_singleton : forall (A : Set)(c : Comp A) s a,
  evalDet_step c s = cs_done a s ->
  getSupport c = (a :: nil).

  induction c; intuition; simpl in *.
  inversion H; clear H; subst.
  trivial.

  destruct (evalDet_step c s); discriminate.

  destruct (shiftOut s n).
  destruct p.
  discriminate.
  discriminate.

  discriminate.
Qed.

Lemma getUnique_NoDup_eq : forall (A : Set)(eqd : eq_dec A)(ls : list A),
  NoDup ls ->
  getUnique ls eqd = ls.

  induction ls; intuition; simpl in *.
  inversion H; clear H; subst.
  destruct (in_dec eqd a (getUnique ls eqd)).
  exfalso.
  apply H2.
  eapply in_getUnique_if.
  eauto.

  f_equal.
  eauto.

Qed.

Lemma getUnique_Permutation : forall (A : Set)(eqd1 eqd2 : eq_dec A)(ls1 ls2 : list A),
  Permutation ls1 ls2 ->
  Permutation (getUnique ls1 eqd1) (getUnique ls2 eqd2).

  induction 1; intuition; simpl in *.
  destruct (in_dec eqd1 x (getUnique l eqd1)).
  destruct (in_dec eqd2 x (getUnique l' eqd2)).
  eauto.
  exfalso.
  eapply n.
  eapply Permutation_in; eauto.

  destruct (in_dec eqd2 x (getUnique l' eqd2)).
  exfalso.
  eapply n.
  eapply Permutation_in.
  eapply Permutation_sym.
  eauto.
  eauto.
  eapply perm_skip.
  trivial.

  destruct (in_dec eqd1 x (getUnique l eqd1)).
  destruct (in_dec eqd1 y (getUnique l eqd1)).
  destruct (in_dec eqd2 y (getUnique l eqd2)).
  destruct (in_dec eqd2 x (getUnique l eqd2)).

  eapply NoDup_Permutation; eauto using getUnique_NoDup; intuition;
    eauto using in_getUnique, in_getUnique_if.

  exfalso.
  eauto using in_getUnique, in_getUnique_if.
  exfalso.
  eauto using in_getUnique, in_getUnique_if.

  destruct (in_dec eqd2 y (getUnique l eqd2)).
  exfalso.
  eauto using in_getUnique, in_getUnique_if.
  destruct (in_dec eqd2 x (y :: getUnique l eqd2)).
  eapply perm_skip.
  eapply NoDup_Permutation; eauto using getUnique_NoDup; intuition;
    eauto using in_getUnique, in_getUnique_if.
  simpl in *. intuition.
  exfalso.
  eauto using in_getUnique, in_getUnique_if.

  destruct (in_dec eqd1 y (x :: getUnique l eqd1)).
  destruct (in_dec eqd2 y (getUnique l eqd2)).
  destruct (in_dec eqd2 x (getUnique l eqd2)).
  exfalso.
  eauto using in_getUnique, in_getUnique_if.
  eapply perm_skip.
  eapply NoDup_Permutation; eauto using getUnique_NoDup; intuition;
    eauto using in_getUnique, in_getUnique_if.
  destruct (in_dec eqd2 x (y :: getUnique l eqd2)).
  simpl in *; intuition.
  clear H.
  subst.
  eapply perm_skip.
  eapply NoDup_Permutation; eauto using getUnique_NoDup; intuition;
    eauto using in_getUnique, in_getUnique_if.
  subst.
  exfalso.
  eauto using in_getUnique, in_getUnique_if.
  subst.
  exfalso.
  eauto using in_getUnique, in_getUnique_if.
  exfalso.
  eauto using in_getUnique, in_getUnique_if.

  simpl in *; intuition; subst.
  intuition.
  exfalso.
  eauto using in_getUnique, in_getUnique_if.

  destruct (in_dec eqd2 y (getUnique l eqd2)).
  destruct (in_dec eqd2 x (getUnique l eqd2)).
  exfalso.
  eauto using in_getUnique, in_getUnique_if.
  simpl in n0; intuition.
  exfalso.
  eauto using in_getUnique, in_getUnique_if.
  destruct (in_dec eqd2 x (y :: getUnique l eqd2)).
  simpl in *; intuition; subst.
  intuition.
  exfalso.
  eauto using in_getUnique, in_getUnique_if.

  eapply perm_trans.
  eapply perm_swap.
  eapply perm_skip.
  eapply perm_skip.
  eapply NoDup_Permutation; eauto using getUnique_NoDup; intuition;
    eauto using in_getUnique, in_getUnique_if.

  eapply perm_trans.
  eapply IHPermutation1.
  eapply (@perm_trans _ _ (getUnique l' eqd1)).
  eapply NoDup_Permutation; eauto using getUnique_NoDup; intuition;
    eauto using in_getUnique, in_getUnique_if.
  trivial.

Qed.

Lemma flatten_Permutation : forall (A : Type)(ls1 ls2 : list (list A)),
  Permutation ls1 ls2 ->
  Permutation (flatten ls1) (flatten ls2).

  induction 1; intuition; simpl in *.

  eapply Permutation_app.
  eapply Permutation_refl.
  trivial.

  repeat rewrite app_assoc.
  eapply Permutation_app.
  eapply Permutation_app_comm.
  eapply Permutation_refl.

  eapply perm_trans.
  eapply IHPermutation1.
  trivial.

Qed.

Lemma to_list_nil_inv : forall (A : Type)(n : nat)(v : Vector.t A n),
  Vector.to_list v = nil ->
  n = O.

  intuition.
  destruct v; simpl in *.
  trivial.
  unfold Vector.to_list in *.
  discriminate.
Qed.

Lemma app_second_eq :
  forall (A : Type) (ls2 ls1 ls3 : list A),
    ls1 = ls2 ++ ls3 -> length ls1 = length ls3 -> ls1 = ls3 /\ ls2 = nil.

  induction ls2; simpl in *; intuition;

  subst;
  simpl in *;
  rewrite app_length in H0;
  omega.

Qed.

Lemma shiftOut_same_inv : forall s n v,
  shiftOut s n = Some (v, s) ->
  n = O.

  intuition.
  eapply to_list_nil_inv.
  eapply app_second_eq.
  eapply shiftOut_correct_inv.
  eauto.
  trivial.
Qed.

Lemma filter_Permutation : forall (A : Set)(ls1 ls2 : list A)(P : A -> bool),
  Permutation ls1 ls2 ->
  Permutation (filter P ls1) (filter P ls2).

  induction 1; intuition; simpl in *.
  destruct (P x).
  eapply perm_skip.
  trivial.
  trivial.

  destruct (P x).
  destruct (P y).
  eapply perm_swap.
  eapply Permutation_refl.
  destruct (P y).
  eapply Permutation_refl.
  eapply Permutation_refl.

  eapply perm_trans;
    eauto.
Qed.

Lemma evalDet_step_more_support_preserved : forall (A : Set)(c c' : Comp A) s,
  evalDet_step c s = (cs_more c' s) ->
  Permutation (getSupport c) (getSupport c').

  induction c; intuition; simpl in *; try discriminate.
  subst.
  case_eq (evalDet_step c s); intuition;
  rewrite H1 in H0.
  inversion H0; clear H0; subst.

  erewrite evalDet_step_done_support_singleton; eauto.
  simpl.
  rewrite app_nil_r.

  rewrite getUnique_NoDup_eq.
  eapply Permutation_refl.
  eapply getSupport_NoDup.
  discriminate.
  inversion H0; clear H0; subst.
  simpl.

  eapply getUnique_Permutation.

  eapply flatten_Permutation.
  eapply Permutation_map.
  eauto.

  case_eq (shiftOut s n); intuition;
  rewrite H0 in H.
  destruct p.
  inversion H; clear H; subst.

  assert (n = O).
  eapply shiftOut_same_inv; eauto.
  subst.
  simpl.
  rewrite shiftOut_0 in H0.
  inversion H0; clear H0; subst.
  eapply Permutation_refl.
  discriminate.

  inversion H; clear H; subst.
  simpl.

  eapply NoDup_Permutation.
  eapply filter_NoDup.
  eapply getSupport_NoDup.
  eapply getUnique_NoDup.
  intuition.
  eapply in_getUnique.
  eapply in_flatten.
  econstructor.
  split.
  eapply in_map_iff.
  econstructor.
  split.
  Focus 2.
  eapply filter_In; eauto.
  assert (b x = true).
  eapply filter_In; eauto.
  rewrite H0.
  eauto.
  simpl.
  intuition.

  apply in_getUnique_if in H.
  eapply in_flatten in H.
  destruct H.
  intuition.
  eapply in_map_iff in H0.
  destruct H0.
  intuition.
  subst.
  case_eq (b x1); intuition;
  rewrite H in H1.
  simpl in *.
  intuition; subst.
  eapply filter_In; eauto.
  simpl in *.
  trivial.

Qed.

Lemma evalDet_steps_nil_eq_h : forall (A : Set)(x y : comp_state A),
  evalDet_steps x y ->
  forall (c : Comp A)(a1 a2 : A) s2,
  x = (cs_more c nil) ->
  y = (cs_done a2 s2) ->
  In a1 (getSupport c) ->
  a1 = a2.

  induction 1; intuition; simpl in *; subst.
  discriminate.

  inversion H1; clear H1; subst.
  inversion H0; clear H0; subst.
  eapply evalDet_step_nil_inv; eauto.

  symmetry in H.
  specialize (evalDet_step_more_nil_inv _ H); intuition.
  subst.
  eapply IHevalDet_steps.
  eauto.
  eauto.
  eapply Permutation_in.
  eapply evalDet_step_more_support_preserved.
  eauto.
  trivial.
Qed.

Lemma evalDet_steps_nil_eq : forall (A : Set)(c : Comp A)(a1 a2 : A) s2,
  evalDet_steps (cs_more c nil) (cs_done a2 s2) ->
  In a1 (getSupport c) ->
  a1 = a2.

  intuition.
  eapply evalDet_steps_nil_eq_h; eauto.
Qed.

Lemma evalDet_step_done_val_eq : forall (A : Set)(c : Comp A)(a1 a2 : A) s1 s2,
  evalDet_step c s1 = (cs_done a2 s2) ->
  In a1 (getSupport c) ->
  a1 = a2.

  induction c; intuition; simpl in *.
  intuition; subst.
  inversion H; clear H; subst.
  trivial.

  destruct (evalDet_step c s1); discriminate.

  destruct (shiftOut s1 n); [ destruct p ; discriminate | discriminate ].

  discriminate.
Qed.

Lemma evalDet_step_done_ls_eq : forall (A : Set)(c : Comp A)(a2 : A) s1 s2,
  evalDet_step c s1 = (cs_done a2 s2) ->
  s1 = s2.

  induction c; intuition; simpl in *.
  inversion H; clear H; subst.
  trivial.

  destruct (evalDet_step c s1); discriminate.

  destruct (shiftOut s1 n); [ destruct p ; discriminate | discriminate ].

  discriminate.

Qed.

Lemma shiftOut_skipn : forall n (v : Bvector n) s s',
  shiftOut s n = Some (v, s') ->
  s' = skipn n s.

  induction n; intuition; simpl in *.
  rewrite shiftOut_0 in H.
  inversion H; clear H; subst.
  trivial.

  destruct s;
    simpl in *.
  discriminate.

  case_eq (shiftOut s n); intuition;
    rewrite H0 in H.
  destruct p.
  inversion H; clear H; subst.
  eauto.
  discriminate.
Qed.

Lemma evalDet_step_more_skipn_eq : forall (A : Set)(c c' : Comp A)(a1 : A) s1 s2,
  evalDet_step c s1 = (cs_more c' s2) ->
  In a1 (getSupport c) ->
  (s1 = s2 \/ (exists n, n > 0 /\ s2 = skipn n s1)).

  induction c; intuition; simpl in *; try discriminate.

  case_eq (evalDet_step c s1); intuition;
  rewrite H2 in H0.
  inversion H0; clear H0; subst.
  left.
  eapply evalDet_step_done_ls_eq.
  eauto.
  discriminate.
  inversion H0; clear H0; subst.

  eapply in_getUnique_if in H1.
  apply in_flatten in H1.
  destruct H1.
  intuition.
  apply in_map_iff in H1.
  destruct H1; intuition.
  eapply (IHc).
  eauto.
  eauto.

  case_eq (shiftOut s1 n); intuition;
  rewrite H1 in H.
  destruct p.
  inversion H; clear H; subst.
  destruct n.
  left.
  rewrite shiftOut_0 in H1.
  inversion H1; clear H1; subst.
  trivial.
  right.
  exists (S n).
  intuition.

  eapply shiftOut_skipn.
  eauto.

  discriminate.

  inversion H; clear H; subst.
  intuition.
Qed.

Lemma evalDet_step_done_skipn : forall (A : Set)(c : Comp A) s a s',
  evalDet_step  c s = (cs_done a s') ->
  exists n, s' = skipn n s.

  induction c; intuition; simpl in *.

  inversion H; clear H; subst.
  exists O.
  simpl.
  trivial.

  destruct (evalDet_step c s); discriminate.

  destruct (shiftOut s n).
  destruct p.
  discriminate.
  discriminate.

  discriminate.

Qed.

Lemma skipn_sum : forall (A : Type)(n2 n1 : nat)(ls : list A),
  skipn n1 (skipn n2 ls) = skipn (n2 + n1) ls.

  induction n2; intuition; simpl in *.

  destruct ls.
  destruct n1; trivial.
  trivial.
Qed.

Lemma evalDet_step_more_skipn : forall (A : Set)(c c' : Comp A) s s',
  evalDet_step  c s = (cs_more c' s') ->
  exists n, s' = skipn n s.

  induction c; intuition; simpl in *.
  discriminate.

  case_eq (evalDet_step c s); intuition;
  rewrite H1 in H0.
  inversion H0; clear H0; subst.
  eapply evalDet_step_done_skipn.
  eauto.
  discriminate.
  inversion H0; clear H0; subst.
  eauto.

  case_eq (shiftOut s n); intuition;
  rewrite H0 in H.
  destruct p.
  inversion H; clear H; subst.
  exists n.

  eauto using shiftOut_skipn.
  discriminate.

  inversion H; clear H; subst.
  exists O.
  simpl.
  trivial.

Qed.

Lemma evalDet_steps_done_skipn_h : forall (A : Set)(x y : comp_state A),
  evalDet_steps x y ->
  forall (c : Comp A) s a s',
    x = (cs_more c s) ->
    y = (cs_done a s') ->
  exists n, s' = skipn n s.

  induction 1; intuition; simpl in *; subst.
  discriminate.

  inversion H1; clear H1; subst.
  inversion H0; clear H0; subst.
  eapply evalDet_step_done_skipn; eauto.

  symmetry in H.
  specialize (evalDet_step_more_skipn _  _ H); intuition.
  destruct H0.
  subst.

  edestruct IHevalDet_steps.
  eauto.
  eauto.
  subst.
  exists (x + x0).
  apply skipn_sum.

Qed.

Lemma evalDet_steps_done_skipn : forall (A : Set)(c : Comp A) s a s',
  evalDet_steps (cs_more c s) (cs_done a s') ->
  exists n, s' = skipn n s.

  intuition.
  eapply evalDet_steps_done_skipn_h; eauto.

Qed.

Lemma evalDet_steps_skipn_h : forall (A : Set) a1 (x y : comp_state A),
  evalDet_steps x y ->
  forall (c : Comp A)(a2 : A) s1 s2,
  x = (cs_more c s1) ->
  y = (cs_done a2 s2) ->
  In a1 (getSupport c) ->
  (a1 = a2 \/ (exists n, n > 0 /\ s2 = skipn n s1)).

  induction 1; subst; intuition; subst.
  discriminate.

  inversion H; clear H; subst.

  inversion H0; clear H0; subst.
  left.
  eapply evalDet_step_done_val_eq; eauto.

  symmetry in H.
  edestruct (evalDet_step_more_skipn_eq c0).
  eauto.
  eauto.
  subst.
  edestruct (IHevalDet_steps).
  eauto.
  eauto.
  eapply Permutation_in.
  eapply evalDet_step_more_support_preserved.
  eauto.
  eauto.
  intuition.
  intuition.

  destruct H0.
  intuition.
  subst.
  right.

  case_eq (evalDet_step c (skipn x s1)); intuition;
  rewrite H0 in H3.
  edestruct (evalDet_step_done_skipn).
  eauto.
  subst.

  inversion H3; clear H3; subst.

  exists (x + x0).
  intuition.
  eapply skipn_sum.

  inversion H3.

  edestruct (evalDet_step_more_skipn).
  eauto.
  subst.
  edestruct (evalDet_steps_done_skipn).
  eauto.
  subst.
  exists (x + (x0 + x1)).
  intuition.
  rewrite skipn_sum.
  rewrite skipn_sum.
  trivial.

Qed.

Lemma evalDet_steps_skipn : forall (A : Set)(c : Comp A)(a1 a2 : A) s1 s2,
  evalDet_steps (cs_more c s1) (cs_done a2 s2) ->
  In a1 (getSupport c) ->
  (a1 = a2 \/ (exists n, n > 0 /\ s2 = skipn n s1)).

  intuition.
  eapply evalDet_steps_skipn_h; eauto.

Qed.

Lemma evalDet_repeat_steps_dec : forall (s : Blist)(A : Set)(c : Comp A)(P : A -> bool),
  (exists a, In a (getSupport c) /\ P a = true) ->
  (forall s', (exists a s'', evalDet_steps (cs_more c s') (cs_done a s'')) \/ evalDet_steps (cs_more c s') (@cs_eof A)) ->
  exists y, evalDet_repeat_steps P (cs_more c s) y.

  intro.
  eapply (list_skipn_strong_ind s); intuition.
  destruct (H0 nil).
  destruct H1.
  destruct H1.
  destruct H.
  intuition.
  exists (cs_done x x0).
  econstructor.
  trivial.

  assert (x1 = x).
  eapply evalDet_steps_nil_eq; eauto.
  subst.
  trivial.

  exists (@cs_eof A).
  econstructor.
  trivial.

  destruct (H1 x).
  destruct H2. destruct H2.
  destruct H0; intuition.

  destruct (evalDet_steps_skipn _ H2 H3); subst.
  econstructor.
  econstructor; eauto.
  destruct H0; intuition; subst.

  case_eq (P x0); intuition.
  econstructor.
  econstructor; eauto.

  edestruct H; eauto.
  econstructor.
  eapply evalDet_repeat_steps_step.
  eapply H2.
  trivial.
  eauto.

  econstructor.
  eapply evalDet_repeat_steps_eof; eauto.
Qed.

Lemma evalDet_repeat_steps_done_inv_h : forall (A : Set)(P : A -> bool) x y,
  evalDet_repeat_steps P x y ->
  forall c s,
  x = (cs_more c s) ->
  evalDet_steps (cs_more (Repeat c P) s) y.

  induction 1; intuition; subst.

  inversion H1; clear H1; subst.
  econstructor.
  eauto.
  simpl.
  eapply evalDet_steps_trans.
  eapply evalDet_steps_bind_done.
  eauto.
  rewrite H0.
  econstructor.
  eauto.
  simpl.
  econstructor.

  inversion H0; clear H0; subst.
  econstructor.
  eauto.
  simpl.
  eapply evalDet_bind_eof.
  trivial.

  inversion H2; clear H2; subst.
  econstructor.
  eauto.
  simpl.
  eapply evalDet_steps_trans.
  eapply evalDet_steps_bind_done.
  eauto.
  rewrite H0.
  eauto.

Qed.

Lemma evalDet_repeat_steps_done_inv : forall (A : Set)(c : Comp A)(P : A -> bool) s y,
  evalDet_repeat_steps P (cs_more c s) y ->
  evalDet_steps (cs_more (Repeat c P) s) y.

  intuition.
  eapply evalDet_repeat_steps_done_inv_h; eauto.
Qed.

Lemma evalDet_repeat_steps_more_inv_h : forall (A : Set)(x y : comp_state A) P,
  evalDet_repeat_steps P x y ->
  forall (c: Comp A)(P : A -> bool) s,
  y = (cs_more c s) ->
  False.

  induction 1; intuition; subst; try discriminate.
Qed.

Lemma evalDet_repeat_steps_more_inv : forall (A : Set) x (c : Comp A)(P : A -> bool) s,
  evalDet_repeat_steps P x (cs_more c s) ->
  False.

  intuition.
  eapply evalDet_repeat_steps_more_inv_h; eauto.
Qed.

(* The result of evaluation is decidable. *)
Lemma evalDet_steps_dec : forall (A : Set)(c : Comp A),
  well_formed_comp c ->
  forall s,
  (exists a s', evalDet_steps (cs_more c s) (cs_done a s')) \/
  (evalDet_steps (cs_more c s) (@cs_eof A)).

  induction 1; intros.

  left.
  exists a. exists s.
  econstructor.
  simpl.
  eauto.
  econstructor.

  destruct (IHwell_formed_comp s).
  destruct H2. destruct H2.
  edestruct (H1 x).
  eapply getSupport_In_evalDet_steps.
  eauto.

  destruct H3. destruct H3.
  left.
  exists x1.
  exists x2.
  eapply evalDet_steps_trans.
  eapply evalDet_steps_bind_done; eauto.
  eauto.

  right.
  eapply evalDet_steps_trans.
  eapply evalDet_steps_bind_done; eauto.
  trivial.

  right.
  eapply evalDet_bind_eof; eauto.

  case_eq (shiftOut s n); intuition.
  left.
  destruct p.
  exists b.
  exists b0.
  econstructor.
  simpl.
  rewrite H.
  eauto.
  econstructor.
  simpl.
  eauto.
  econstructor.

  right.
  econstructor.
  simpl.
  rewrite H.
  eauto.
  econstructor.

  edestruct (evalDet_repeat_steps_dec).
  exists b.
  eapply filter_In; eauto.
  eauto.
  destruct x.
  left.
  econstructor.
  econstructor.
  eapply evalDet_repeat_steps_done_inv.
  eauto.

  right.
  eapply evalDet_repeat_steps_done_inv.
  eauto.

  exfalso.
  eauto using evalDet_repeat_steps_more_inv.

Qed.

Lemma evalDet_dec : forall (A : Set)(c : Comp A)(s : Blist),
  well_formed_comp c ->
  (exists a, evalDet c s (ca_done a)) \/ (evalDet c s (@ca_eof A)).

  intuition.
  edestruct (@evalDet_steps_dec _ c).
  trivial.
  destruct H0.
  destruct H0.
  left.
  econstructor.
  econstructor.
  eauto.

  right.
  econstructor.
  eauto.

Qed.

Lemma evalDet_step_app_done_eq : forall (A : Set)(c : Comp A) s s' s'' a,
  evalDet_step c s = (cs_done a s'') ->
  evalDet_step c (s ++ s') = (cs_done a (s'' ++ s')).

  induction c; intuition; simpl in *.
  inversion H; clear H; subst.
  trivial.

  case_eq (evalDet_step c s); intuition;
    rewrite H1 in H0; try discriminate.

  case_eq (shiftOut s n); intuition;
    rewrite H0 in H.
  destruct p.
  inversion H; clear H; subst.
  discriminate.

  discriminate.

Qed.

Lemma evalDet_step_app_more_eq : forall (A : Set)(c c': Comp A) s s' s'',
  evalDet_step c s = (cs_more c' s'') ->
  evalDet_step c (s ++ s') = (cs_more c' (s'' ++ s')).

  induction c; intuition; simpl in *.
  discriminate.

  case_eq (evalDet_step c s); intuition;
    rewrite H1 in H0; try discriminate.
  inversion H0; clear H0; subst.
  erewrite evalDet_step_app_done_eq;
  eauto.
  inversion H0; clear H0; subst.
  erewrite IHc.
  eauto.
  trivial.

  case_eq (shiftOut s n); intuition;
    rewrite H0 in H.
  destruct p.
  inversion H; clear H; subst.
  erewrite shiftOut_app; eauto.
  discriminate.

  inversion H; clear H; subst.
  trivial.
Qed.

Lemma evalDet_steps_app_eq_h : forall (A : Set)(x y : comp_state A),
  evalDet_steps x y ->
  forall (c : Comp A) s s' s'' a,
    x = (cs_more c s) ->
    y = (cs_done a s'') ->
    evalDet_steps (cs_more c (s ++ s')) (cs_done a (s'' ++ s')).

  induction 1; intuition; subst.
  discriminate.

  inversion H1; clear H1; subst.
  inversion H0; clear H0; subst.

  econstructor.
  eapply evalDet_step_app_done_eq.
  eauto.
  econstructor.

  econstructor.

  eauto.
  erewrite evalDet_step_app_more_eq.
  eapply IHevalDet_steps.
  eauto.
  trivial.
  auto.
Qed.

Lemma evalDet_steps_app_eq : forall (A : Set)(c : Comp A) s s' s'' a,
  evalDet_steps (cs_more c s) (cs_done a s'') ->
  evalDet_steps (cs_more c (s ++ s')) (cs_done a (s'' ++ s')).

  intuition.
  eapply evalDet_steps_app_eq_h; eauto.

Qed.

Lemma evalDet_app_eq : forall (A : Set)(c : Comp A) s s' a,
  evalDet c s (ca_done a) ->
  evalDet c (s ++ s') (ca_done a).

  intuition.
  inversion H; clear H; subst.
  econstructor.
  eapply evalDet_steps_app_eq.
  eauto.
Qed.

Lemma evalDet_steps_done_nil_inv_h : forall (A : Set)(x y : comp_state A),
  evalDet_steps x y ->
  forall (c : Comp A) a ls,
    x = (cs_more c nil) ->
    y = (cs_done a ls) ->
    ls = nil.

  induction 1; intuition; subst.
  discriminate.

  inversion H1; clear H1; subst.
  inversion H0; clear H0; subst.
  eapply evalDet_step_done_nil_inv; eauto.
  assert (s = nil).
  eapply evalDet_step_more_nil_inv; eauto. subst.
  eauto.

Qed.

Lemma evalDet_steps_done_nil_inv : forall (A : Set)(c : Comp A) a ls,
  evalDet_steps (cs_more c nil) (cs_done a ls) ->
  ls = nil.

  intuition.
  eapply evalDet_steps_done_nil_inv_h; eauto.
Qed.

Lemma app_eq_nil_inv : forall (A : Set)(ls2 ls1 ls3 : list A),
  ls1 = ls2 ++ ls3 ->
  length ls1 = length ls2 ->
  ls3 = nil.

  induction ls2; intuition; simpl in *; subst.
  destruct ls3; simpl in *; trivial. omega.

  simpl in *.
  eapply IHls2.
  eauto.
  omega.
Qed.

Lemma evalDet_steps_repeat_done_inv_h : forall (A : Set)(x y : comp_state A),
  evalDet_steps x y ->
  forall (P : A -> bool)(c : Comp A) s a s',
  evalDet_steps x (cs_more (Repeat c P) s) ->
  y = (cs_done a s') ->
  evalDet_repeat_steps P (cs_more c s) (cs_done a s').

  induction 1; intuition; subst.
  inversion H.

  inversion H1; clear H1; subst.
  simpl in *.
  eapply evalDet_steps_bind_done_inv in H0.
  destruct H0. destruct H.
  intuition.
  case_eq (P x); intuition;
  rewrite H in H1.
  inversion H1; clear H1; subst.
  simpl in *.
  inversion H6; clear H6; subst.
  econstructor;
  eauto.
  eapply evalDet_repeat_steps_step.
  eauto.
  trivial.
  eapply IHevalDet_steps.
  eapply evalDet_steps_trans.
  eapply evalDet_steps_bind_done.
  eauto.
  rewrite H.
  econstructor.
  trivial.

  case_eq (P a); intuition.

Qed.

Lemma evalDet_steps_repeat_done_inv : forall (A : Set)(P : A -> bool)(c : Comp A) s a s',
  evalDet_steps (cs_more (Repeat c P) s) (cs_done a s') ->
  evalDet_repeat_steps P (cs_more c s) (cs_done a s').

  intuition.
  eapply evalDet_steps_repeat_done_inv_h.
  eapply H.
  econstructor.
  trivial.

Qed.

Lemma evalDet_steps_repeat_eof_inv_h : forall (A : Set)(x y : comp_state A),
  evalDet_steps x y ->
  forall (P : A -> bool)(c : Comp A) s,
    evalDet_steps x (cs_more (Repeat c P) s) ->
    y = (cs_eof A) ->
  evalDet_repeat_steps P (cs_more c s) (cs_eof A).

  induction 1; intuition; subst.
  inversion H.

  inversion H1; clear H1; subst.
  simpl in *.
  eapply evalDet_steps_bind_eof_inv in H0.
  intuition.
  econstructor.
  trivial.
  destruct H. destruct H.
  intuition.
  case_eq (P x); intuition;
  rewrite H in H1.
  inversion H1; clear H1; subst.
  simpl in *.
  inversion H6.
  eapply evalDet_repeat_steps_step.
  eauto.
  trivial.
  eapply IHevalDet_steps.
  eapply evalDet_steps_trans.
  eapply evalDet_steps_bind_done.
  eauto.
  rewrite H.
  econstructor.
  trivial.

  eauto.

Qed.

Lemma evalDet_steps_repeat_eof_inv : forall (A : Set)(P : A -> bool)(c : Comp A) s,
  evalDet_steps (cs_more (Repeat c P) s) (cs_eof A)->
  evalDet_repeat_steps P (cs_more c s) (cs_eof A).

  intuition.
  eapply evalDet_steps_repeat_eof_inv_h.
  eauto.
  econstructor.
  trivial.
Qed.

Lemma evalDet_repeat_steps_nil_inv_h : forall (A : Set) P (x y : comp_state A),
  evalDet_repeat_steps P x y ->
  forall (P : A -> bool) c a ls',
  x = (cs_more c nil) ->
  y = (cs_done a ls') ->
  ls' = nil.

  induction 1; intuition; subst.

  inversion H2; clear H2; subst.
  inversion H3; clear H3; subst.
  eapply evalDet_steps_done_nil_inv.
  eauto.

  discriminate.

  inversion H4; clear H4; subst.
  assert (s' = nil).
  eapply evalDet_steps_done_nil_inv.
  eauto.
  subst.
  eauto.

Qed.

Lemma evalDet_repeat_steps_nil_inv : forall (A : Set)(P : A -> bool) c a ls',
  evalDet_repeat_steps P (cs_more c nil) (cs_done a ls') ->
  ls' = nil.

  intuition.
  eapply evalDet_repeat_steps_nil_inv_h; eauto.

Qed.

Lemma evalDet_repeat_steps_app_nil_h : forall (A : Set) P (x y : comp_state A),
  evalDet_repeat_steps P x y ->
  forall c ls1 ls2 b a,
    x = (cs_more c ls1) ->
    y = (cs_eof A) ->
    evalDet_repeat_steps P (cs_more c (ls1 ++ b :: nil)) (cs_done a ls2)->
    (forall s s' b a,
      evalDet_steps (cs_more c s) (cs_eof A) ->
      evalDet_steps (cs_more c (s ++ b :: nil)) (cs_done a s') ->
      s' = nil) ->
    ls2 = nil.

  induction 1; intuition; subst.

  discriminate.

  inversion H0; clear H0; subst.
  inversion H2; clear H2; subst.
  eapply H3; eauto.

  assert (s' = nil).
  eapply H3; eauto.
  subst.

  eapply evalDet_repeat_steps_nil_inv.
  eauto.

  inversion H2; clear H2; subst.
  inversion H4; clear H4; subst.
  assert (evalDet_steps (cs_more c0 (ls1 ++ b :: nil)) (cs_done a (s' ++ b :: nil))).
  eapply evalDet_steps_app_eq.
  trivial.
  specialize (evalDet_steps_done_func H7 H2); intuition; subst.
  congruence.

  assert (evalDet_steps (cs_more c0 (ls1 ++ b :: nil)) (cs_done a (s' ++ b :: nil))).
  eapply evalDet_steps_app_eq.
  trivial.
  specialize (evalDet_steps_done_func H6 H2); intuition; subst.
  clear H6.
  eapply IHevalDet_repeat_steps.
  eauto.
  eauto.
  eauto.
  trivial.

Qed.

Lemma evalDet_repeat_steps_app_nil : forall (A : Set)(c : Comp A) P ls1 ls2 b a,
  evalDet_repeat_steps P (cs_more c ls1) (cs_eof A) ->
  evalDet_repeat_steps P (cs_more c (ls1 ++ b :: nil)) (cs_done a ls2) ->
  (forall s s' b a,
    evalDet_steps (cs_more c s) (cs_eof A) ->
    evalDet_steps (cs_more c (s ++ b :: nil)) (cs_done a s') ->
    s' = nil) ->
  ls2 = nil.

  intuition.
  eapply evalDet_repeat_steps_app_nil_h.
  eapply H.
  eauto.
  trivial.
  eauto.
  trivial.

Qed.

Lemma evalDet_app_nil : forall (A : Set)(c : Comp A),
  well_formed_comp c ->
  forall ls1 ls2 b a,
  evalDet c ls1 (ca_eof A) ->
  evalDet_steps (cs_more c (ls1 ++ b :: nil)) (cs_done a ls2) ->
  ls2 = nil.

  induction 1; intuition; simpl in *.

  exfalso.
  eapply evalDet_done_eof_func; eauto.
  econstructor.
  econstructor.
  eauto.
  simpl.
  econstructor.

  apply evalDet_steps_bind_done_inv in H3.
  destruct H3. destruct H3. intuition.

  edestruct (@evalDet_dec _ c1 ls1).
  trivial.
  destruct H3.
  inversion H3; clear H3; subst.
  assert (evalDet_steps (cs_more c1 (ls1 ++ b :: nil)) (cs_done x1 (s' ++ b :: nil))).
  eapply evalDet_steps_app_eq.
  eauto.
  specialize (evalDet_steps_done_func H4 H3); intuition. subst.
  clear H3.

  edestruct (@evalDet_dec _ (c2 x1) s').
  eapply H0.
  eapply getSupport_In_evalDet_steps.
  eauto.
  destruct H3;
  inversion H3; clear H3; subst.
  exfalso.
  eapply evalDet_done_eof_func; [idtac | eapply H2].
  econstructor.
  eapply evalDet_steps_trans.
  eapply evalDet_steps_bind_done; eauto.
  eauto.

  eapply H1; eauto.
  eapply getSupport_In_evalDet_steps.
  eauto.

  assert (x0 = nil).
  eapply IHwell_formed_comp.
  eauto.
  eauto.
  subst.

  eapply evalDet_steps_done_nil_inv; eauto.

  case_eq (shiftOut ls1 n); intuition.
  destruct p.
  exfalso.
  eapply evalDet_done_eof_func; [idtac | eapply H].
  econstructor.
  econstructor.
  eauto.
  simpl.
  rewrite H1.
  econstructor.
  eauto.
  simpl.
  econstructor.

  inversion H0; clear H0; subst.
  simpl in *.
  apply shiftOut_None_inv in H1.
  case_eq (shiftOut (ls1 ++ b :: nil) n); intuition.
  destruct p.
  rewrite H0 in H6.
  inversion H6; clear H6; subst.
  simpl in *.
  inversion H7; clear H7; subst.
  specialize (shiftOut_Some_inv _ H0); intuition.
  apply shiftOut_correct_inv in H0.

  eapply app_eq_nil_inv.
  eapply H0.
  rewrite to_list_length.
  rewrite app_length in *; simpl in *.
  omega.

  rewrite H0 in H6.
  inversion H6.

  inversion H1; clear H1; subst.
  eapply evalDet_repeat_steps_app_nil.
  eapply evalDet_steps_repeat_eof_inv.
  eauto.
  eapply evalDet_steps_repeat_done_inv; eauto.
  intuition.
  eapply IHwell_formed_comp.
  econstructor.
  eauto.
  eauto.

Qed.

Lemma evalDet_step_done_inv : forall (A : Set)(c : Comp A) a ls ls',
  evalDet_step c ls = cs_done a ls' ->
  exists eqd,
    c = Ret eqd a.

  intuition.
  destruct c; simpl in *.
  inversion H; clear H; subst.
  econstructor; eauto.

  case_eq (evalDet_step c ls); intuition; rewrite H0 in H; discriminate.

  destruct (shiftOut ls n). destruct p. discriminate.
  discriminate.

  discriminate.

Qed.

Lemma evalDet_step_more_sublist : forall (A : Set)(c : Comp A) c' ls ls',
  evalDet_step c ls = (cs_more c' ls') ->
  exists ls'', ls = ls'' ++ ls'.

  induction c; intuition; simpl in *; try discriminate.

  case_eq (evalDet_step c ls); intuition; rewrite H1 in H0.
  inversion H0; clear H0; subst.
  destruct (evalDet_step_done_inv _ _ H1); subst; simpl in *.
  inversion H1; clear H1; subst.
  exists nil. trivial.

  discriminate.

  inversion H0; clear H0; subst.
  eapply IHc.
  eauto.

  case_eq (shiftOut ls n); intuition; rewrite H0 in H.
  destruct p.
  inversion H; clear H; subst.
  exists (Vector.to_list b).
  eapply shiftOut_correct_inv.
  trivial.
  discriminate.

  inversion H; clear H; subst.
  exists nil.
  simpl.
  trivial.

Qed.

Lemma evalDet_sublist_h : forall (A : Set)(x y : comp_state A),
  evalDet_steps x y ->
  forall (c : Comp A) a ls ls' ,
    x = (cs_more c ls) ->
    y = (cs_done a ls') ->
    exists ls'', ls = ls'' ++ ls'.

  induction 1; intuition; subst; try discriminate.

  inversion H1; clear H1; subst.
  inversion H0; clear H0; subst.

  destruct (evalDet_step_done_inv _ _ H2). subst.
  simpl in *.
  inversion H2; clear H2; subst.
  exists nil. trivial.

  edestruct (IHevalDet_steps).
  symmetry. eauto.
  eauto.
  subst.

  symmetry in H.
  apply evalDet_step_more_sublist in H.
  destruct H.
  subst.
  exists (x0 ++ x).
  apply app_assoc.

Qed.

Lemma evalDet_sublist : forall (A : Set)(c : Comp A) a ls ls',
  evalDet_steps (cs_more c ls) (cs_done a ls') ->
  exists ls'', ls = ls'' ++ ls'.

  intuition.
  eapply evalDet_sublist_h; eauto.

Qed.

Lemma evalDet_nil : forall (A : Set)(c : Comp A) a ls,
  evalDet_steps (cs_more c nil) (cs_done a ls) ->
  ls = nil.

  intuition.
  apply evalDet_sublist in H.
  destruct H.
  symmetry in H.
  apply app_eq_nil in H.
  intuition.
Qed.

Lemma evalDet_left_total : forall (A : Set)(c : Comp A) s,
  well_formed_comp c ->
  exists ans, evalDet c s ans.

  intuition.
  edestruct (evalDet_dec).
  eauto.
  destruct H0.
  econstructor.
  eauto.
  econstructor.
  eauto.
Qed.

Lemma evalDet_steps_done_support_singleton_h : forall (A : Set)(x1 x2 : comp_state A),
  evalDet_steps x1 x2 ->
  forall (c : Comp A) a s,
    x1 = (cs_more c nil) ->
    x2 = (cs_done a s) ->
    getSupport c = a :: nil.

  induction 1; intuition; subst.
  discriminate.
  inversion H1; clear H1; subst.

  inversion H0; clear H0; subst.
  assert (s0 = nil).
  eapply evalDet_step_done_nil_inv.
  eauto.
  subst.
  eapply evalDet_step_done_support_singleton.
  eauto.
  assert (s = nil).
  eapply evalDet_step_more_nil_inv.
  eauto.
  subst.

  assert (Permutation (getSupport c0) (getSupport c)).
  eapply evalDet_step_more_support_preserved.
  symmetry.
  eauto.
  assert (getSupport c = a :: nil).
  eapply IHevalDet_steps.
  eauto.
  eauto.
  rewrite H1 in H0.
  apply Permutation_sym in H0.
  apply Permutation_length_1_inv in H0.
  trivial.

Qed.

Lemma evalDet_steps_done_support_singleton : forall (A : Set)(c : Comp A) a s,
  evalDet_steps (cs_more c nil) (cs_done a s) ->
  getSupport c = a :: nil.

  intuition.
  eapply evalDet_steps_done_support_singleton_h; eauto.

Qed.

Lemma evalDet_step_well_formed_comp_preserved : forall (A : Set)(c : Comp A),
  well_formed_comp c ->
  forall c' s s',
    evalDet_step c s = (cs_more c' s') ->
    well_formed_comp c'.

  induction 1; intuition; simpl in *.

  discriminate.

  case_eq (evalDet_step c1 s); intuition;
    rewrite H3 in H2; try discriminate.
  inversion H2; clear H2; subst.
  eapply H0.
  eapply getSupport_In_evalDet_step_done; eauto.
  inversion H2; clear H2; subst.
  eapply well_formed_Bind.
  eapply IHwell_formed_comp.
  eauto.
  intuition.
  eapply H0.
  eapply getSupport_In_evalDet_step_more; eauto.

  case_eq (shiftOut s n); intuition;
      rewrite H0 in H; try discriminate.
  destruct p.
  inversion H; clear H; subst.
  econstructor.

  inversion H1; clear H1; subst.
  econstructor.
  trivial.
  intuition.
  case_eq (P b0); intuition.
  econstructor.
  econstructor.
  trivial.
  trivial.
  eauto.

Qed.

(*
Print OracleComp.

Definition OracleStep (A B S : Set) :=
  (S -> A -> Blist -> comp_state (B * S) -> Prop).

Inductive oracle_comp_state(A B C S : Set) :=
| ocs_oracle_running :
  OracleComp A B C ->
  OracleStep A B S ->
  comp_state (B * S) ->
  oracle_comp_state A B C S
| ocs_oracle_done :
  OracleComp A B C ->
  OracleStep A B S ->
  B * S ->
  Blist ->
  oracle_comp_state A B C S
| ocs_more :
  OracleComp A B C ->
  OracleStep A B S ->
  S ->
  Blist ->
  oracle_comp_state A B C S
| ocs_done :
  C * S ->
  Blist ->
  oracle_comp_state A B C S
| ocs_eof :
  oracle_comp_state A B C S.

Print OracleComp.

Inductive oc_det_step : forall (A B C S : Set), oracle_comp_state A B C S -> oracle_comp_state A B C S -> Prop :=
| oc_det_oracle_step :
  forall (A B C S : Set)(c : OracleComp A B C)(o : OracleStep A B S)(c_o : Comp (B * S))(x : Blist) cs',
    evalDet_step c_o x = cs' ->
    oc_det_step (ocs_oracle_running c o (cs_more c_o x)) (ocs_oracle_running c o cs')
| oc_det_oracle_eof :
  forall (A B C S : Set)(c : OracleComp A B C)(o : OracleStep A B S)(c_o : Comp (B * S))(x : Blist),
    oc_det_step (ocs_oracle_running c o (cs_eof _)) (ocs_eof A B C S)
| oc_det_query_start :
  forall (A B S: Set)(a : A)(o : OracleStep A B S) (s : S) (r : Blist) cs_o,
    o s a r cs_o ->
    oc_det_step (ocs_more (@OC_Query A B a) o s r) (ocs_oracle_running (@OC_Query A B a) o cs_o)
| oc_det_query_finish :
  forall (A B S: Set)(a : A)(o : OracleStep A B S) (r : Blist) z,
    oc_det_step (ocs_oracle_running (@OC_Query A B a) o (cs_done z r)) (ocs_done _ _ z r)
| oc_det_run_start :
  forall (A A' B B' C S S' : Set)
    (eqds : EqDec S)(eqdb : EqDec B)(eqda : EqDec A)(c : OracleComp A B C)(o : S -> A -> OracleComp A' B' (B * S))(s : S)(o' : OracleStep A' B' S')(s' : S')(r : Blist),
    oc_det_step
    (ocs_more (OC_Run c _ _ _ o s) o' s' r)
    (ocs_more c (fun x y z => oc_det_step (ocs_more (o (fst x) y) o' (snd x) z)) (s, s') r).

*)


(* -------------------------------------------------------------------- *)
(* ------- *) Require Import Setoid Morphisms.
From mathcomp Require Import all_ssreflect all_algebra.
From mathcomp.analysis Require Import boolp reals realseq realsum distr.
(* ------- *) Require Import notations inhabited pwhile psemantic passn.

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

Import GRing.Theory Num.Theory.

Local Open Scope ring_scope.
Local Open Scope syn_scope.
Local Open Scope sem_scope.
Local Open Scope mem_scope.

(* -------------------------------------------------------------------- *)
Definition range {A : choiceType} (P : pred A) (mu : Distr A) :=
  forall m, m \in dinsupp mu -> P m.

Section Range.
Context {A B : choiceType}.

Lemma range_dnull (P : pred A) : range P dnull.
Proof. by move=> x /dinsuppP; rewrite dnullE. Qed.

Lemma range_dunit (P: pred A) m : P m -> range P (dunit m).
Proof. by move=> Pm m' /in_dunit ->. Qed.

Lemma range_dlet (PA : pred A) (PB : pred B) mu f :
    range PA mu -> (forall m, PA m -> range PB (f m))
  -> range PB (\dlet_(m <- mu) f m).
Proof. by move=> hA hB y /dinsupp_dlet[x] /hA /hB /(_ y). Qed.

Lemma dinsupp_dlim (mu : nat -> Distr A) x:
  x \in dinsupp (\dlim_(n) mu n) ->
    exists k, x \in dinsupp (mu k).
Proof.
move/dinsuppP; rewrite dlimE; apply: contra_notP.
move/asboolPn/forallp_asboolPn => eq; rewrite (@eq_nlim _ (fun _ => 0)).
  by move=> n; apply/dinsuppPn/negP/eq.
  by rewrite nlimC.
Qed.

Lemma range_dlim P (mu : nat -> Distr A):
  (forall n, range P (mu n)) -> range P (dlim mu).
Proof. by move=> h m /dinsupp_dlim[k] /h. Qed.

Lemma range_weaken (P1 P2 : pred A) mu:
  (forall x, P1 x -> P2 x) ->
  range P1 mu -> range P2 mu.
Proof. by move=> imp_P h m /h /imp_P. Qed.

Lemma range_pswap (P : pred (A * B)) (mu : Distr (A * B)) :
  range P mu -> range (pswap P) (dswap mu).
Proof.
move=> h [m1 m2] m_in_mu; have := h (m2, m1); apply.
by apply/dinsuppP; rewrite -dswapK; apply/dinsuppP/dinsupp_swap.
Qed.

Lemma pr_range (mu : Distr A) (E : pred A) :
  \P_[mu] (~ E)%A = 0 <-> range E mu.
Proof.
  split.
  + by move=> /pr_eq0 h x; apply/contraLR => /h /dinsuppPn.
  rewrite /range -(pr_pred0 mu)=> Hin;apply eq_in_pr=> x /Hin.
  by rewrite /mem /= /in_mem /= => ->.   (* TODO: simplify this *)
Qed.
End Range.

(* -------------------------------------------------------------------- *)
Section Phl.
Context {X : eqType} {mem : memType X}.

Notation assn := (pred mem).
Notation cmd  := (@cmd_ X mem).

Definition phl (P : assn) (c : cmd) (Q : assn) :=
  forall m, P m -> range Q (ssem_ c m).

Arguments phl P%A c%S Q%A.

Definition forall_in {T : ihbType} (mu : mem -> Distr T) (P : T -> assn) : assn :=
  `[< fun m => forall t,  t \in dinsupp (mu m) -> P t m >]%A.

Notation "`[ 'forall' x 'in' mu => Q ]" :=
  (@forall_in _ mu%A (fun x => Q)): assn.

Notation "`[ 'forall' x 'in' mu | m => Q ]" :=
  (@forall_in _ mu%A (fun x m => Q)): assn.

(* -------------------------------------------------------------------- *)
(* Core rules                                                           *)
(* -------------------------------------------------------------------- *)
Lemma phl_eq (P Q : assn) (c c' : cmd):
     (forall m, P m -> ssem_ c m = ssem_ c' m)
  -> phl P c Q
  -> phl P c' Q.
Proof. by move=> Hc Hw m Pm;rewrite -Hc //;apply Hw. Qed.

Instance phl_m : Proper (eq ==> @eqcmd _ mem ==> eq ==> iff) phl.
Proof. by move=> ??-> ??? ??->;split;apply phl_eq. Qed.

Lemma phl_conseq (P2 Q2 P1 Q1 : assn) (c : cmd):
 (forall m, P1 m -> P2 m) ->
 (forall m, Q2 m -> Q1 m) ->
 phl P2 c Q2 -> phl P1 c Q1.
Proof. by move=> HP HQ H2 m /HP /H2 Hr m' /Hr /HQ. Qed.

Lemma phl_F (c : cmd) P: phl pred0 c P.
Proof. by []. Qed.

Lemma phl_T (c : cmd) P: phl P c predT.
Proof. by []. Qed.

Lemma phl_skip (P : assn) : phl P skip P.
Proof. by move=> ??;rewrite ssemE;apply range_dunit. Qed.

Lemma phl_abort (P Q : assn) : phl P abort Q.
Proof. by move=> ??;rewrite ssemE;apply range_dnull. Qed.

Lemma phl_assign {T : ihbType} x (e:expr_ X mem T) (Q : assn):
   phl [pred m | Q m.[x <- `[{e}]%A m]] (x <<- e) Q.
Proof. by move=> m /=;rewrite !semE;apply range_dunit. Qed.

Lemma phl_random {T : ihbType} x (d:expr_ X mem (Distr T)) (Q : assn):
   phl `[forall v in `[{d}] | m => Q m.[x <- v]] (x <$- d) Q.
Proof.
move=> m /asboolP /= h; rewrite !semE.
apply (@range_dlet _ _ [pred v | Q m.[x<- v]]) => v /=.
  by apply h. by apply range_dunit.
Qed.

Lemma phl_seq (R Pr Po : assn) (c1 c2:cmd):
  phl Pr c1 R -> phl R c2 Po -> phl Pr (c1;;c2) Po.
Proof.
by move=> H1 H2 m /H1 Hm; rewrite ssemE; apply/(range_dlet Hm H2).
Qed.

Lemma phl_if (Pr Po : assn) (e:expr_ X mem bool) (c1 c2:cmd):
  phl (Pr /\ `[{e}])   c1 Po ->
  phl (Pr /\ `[{~~e}]) c2 Po ->
  phl Pr (If e then c1 else c2)%S Po.
Proof.
by move=> H1 H2 m Hm; rewrite ssemE; case: ifPn => He;
  [apply H1 | apply H2] => /=; rewrite Hm.
Qed.

Lemma phl_while (I : assn) (e:expr_ X mem bool) (c:cmd):
  phl (I /\ `[{e}]) c I ->
  phl I (While e Do c) (I /\ `[{~~e}]).
Proof.
move=> Hc m Hm; rewrite ssemE; apply/range_dlim=> n.
elim: n m Hm => [|n Hn] m Hm /=.
+ by rewrite ssemE; apply range_dnull.
apply (@phl_if I)=> //; last by apply phl_skip.
by apply (phl_seq Hc)=> ??; apply Hn.
Qed.

(* -------------------------------------------------------------------- *)
Lemma phl_ll (P Q : assn) (c:cmd) m:
  phl P c Q -> P m -> \P_[ssem_ c m] predT = 1 -> \P_[ssem_ c m] Q = 1.
Proof.
 by move=> Hphl /Hphl HP <-; rewrite !pr_exp;apply/eq_exp => x /HP ->.
Qed.
End Phl.

(* -------------------------------------------------------------------- *)
Definition eqon (X : pred { t : ihbType & vars t } ) (m : cmem) :=
  nosimpl (fun m' : cmem => forall x, x \in X -> m.[tagged x] = m'.[tagged x]).

Definition separated X (P : pred dmem) :=
  forall (mu1 mu2 : dmem),
      (forall m : cmem, \P_[mu1] [pred m' | `[<eqon (predC X) m m'>] ] =
                        \P_[mu2] [pred m' | `[<eqon (predC X) m m'>] ])
    -> mu1 \in P -> mu2 \in P.

(* -------------------------------------------------------------------- *)
Fixpoint mod (c : cmd) : pred { t : ihbType & vars t } :=
  match c with
  | abort    => pred0
  | skip     => pred0
  | x <<- _  => [pred y | `[<y = Tagged _ x>]]
  | x <$- _  => [pred y | `[<y = Tagged _ x>]]
  | c1 ;; c2 => [predU mod c1 & mod c2]

  | If _ then c1 else c2 => [predU mod c1 & mod c2]
  | While _ Do c         => mod c
  end.

(* -------------------------------------------------------------------- *)
Definition eaccess {t} (e : expr t) : pred { t : ihbType & vars t } :=
  match e with
  | var_ _ x => [pred y | `[<y = Tagged _ x>]]
  | _ => pred0
  end.

(* -------------------------------------------------------------------- *)
Global Instance eqon_R X : Equivalence (eqon X).
Proof.
constructor=> //; first by move=> c1 c2 eq x /eq ->.
by move=> c1 c2 c3 eq1 eq2 x xX; rewrite eq1 ?eq2.
Qed.

(* -------------------------------------------------------------------- *)
Lemma mod_spec c m:
   phl [pred m' | m == m'] c
       [pred m' | `[<eqon (predC (mod c)) m m'>] ].
Proof. elim: c m.
+ by move=> m; apply phl_abort.
+ move=> m; pose P := [pred m' | m == m'].
  apply (phl_conseq (P2 := P) (Q2 := P))=> //; last exact/phl_skip.
  by move=> m' /eqP ->; apply/asboolT.
+ move=> t x e m; set Q := (Q in phl _ _ Q).
  pose R := [pred m' | Q m'.[x <- `[{e}] m']].
  apply (phl_conseq (P2 := R) (Q2 := Q))=> //; last exact/phl_assign.
  move=> m' /eqP <-; apply/asboolP=> -[u y] /asboolP /=.
  move/eq_vars=> neq; rewrite mget_neq //.
  by case: eqP neq; intuition.
+ move=> t x d m; set Q := (Q in phl _ _ Q).
  pose R := forall_in `[{d}] (fun v m => Q m.[x <- v]).
  apply (phl_conseq (P2 := R) (Q2 := Q)) => //; last exact/phl_random.
  move=> m' /= /eqP <-; apply/asboolP => z.
  move=> zQ; apply/asboolP => -[u y] /asboolP /eq_vars /= neq.
  by rewrite mget_neq //; case: eqP neq; intuition.
+ move=> e c1 ih1 c2 ih2 m; apply phl_if.
  * pose P := [pred m' | m == m'].
    pose Q := [pred m' | `[<eqon (predC (mod c1)) m m'>]].
    apply (phl_conseq (P2 := P) (Q2 := Q)); last exact/ih1.
    - by move=> m' /= /andP [/eqP <-].
    move=> m' /asboolP eq_m_m'; apply/asboolP=> z.
    by case/norP => [cz1 cz2]; rewrite eq_m_m'.
  * pose P := [pred m' | m == m'].
    pose Q := [pred m' | `[<eqon (predC (mod c2)) m m'>]].
    apply (phl_conseq (P2 := P) (Q2 := Q)); last exact/ih2.
    - by move=> m' /= /andP [/eqP <-].
    move=> m' /asboolP eq_m_m'; apply/asboolP=> z.
    by case/norP => [cz1 cz2]; rewrite eq_m_m'.
+ move=> e c ihc m.
  pose P := ([pred m' | `[< eqon (~ mod c)%A m m' >]])%A.
  pose Q := ([pred m' | `[< eqon (~ mod c)%A m m' >]] /\ `[{~~ e}])%A.
  apply (phl_conseq (P2 := P) (Q2 := Q)).
  + by move=> m' /eqP <-; apply /asboolP.
  + by move=> m' /andP [].
  apply/phl_while=> m1 /andP[] /asboolP Hm1 _.
  apply: (@range_weaken _ [pred m' | `[< eqon (~ mod c)%A m1 m' >]]).
  + move=> x /asboolP eq_m1_x; apply/asboolP=> z Hz.
    by rewrite Hm1 // eq_m1_x.
  by apply (ihc m1)=> //=.
+ move=> c1 ih1 c2 ih2 m; eapply phl_seq; first by apply (ih1 m).
  move=> m1 /asboolP Hm1.
  apply: (@range_weaken _ [pred m' | `[< eqon (~ mod c2)%A m1 m' >]]).
  + move=> x /asboolP Hx; apply/asboolP=> z /=.
    by case/norP => [/= zc1 zc2]; rewrite Hm1 // Hx.
  by apply (ih2 m1) => /=.
Qed.

(* -------------------------------------------------------------------- *)
Lemma modll c mu m : lossless predT c ->
  \P_[mu]         [pred m' | `[<eqon (predC (mod c)) m m'>] ] =
  \P_[dssem c mu] [pred m' | `[<eqon (predC (mod c)) m m'>] ].
Proof.
move=> ll; rewrite pr_dlet pr_exp; apply/eq_exp => m' _.
apply/esym; rewrite !inE; case/boolP: (X in (_ X)%:R) => /= /asboolP h.
+ pose P := [pred m' | `[< eqon (~ mod c)%A m m' >]]; suff: phl P c P.
  - by move=> Hr; rewrite (phl_ll Hr) ?ll //; apply/asboolP.
  move=> m''; rewrite !inE => /asboolP eqm''.
  apply: (range_weaken (P1 := [pred m' | `[< eqon (~ mod c)%A m'' m' >]])).
  + by move=> m3 /asboolP eqm3; apply/asboolP; rewrite eqm''.
  by apply/mod_spec; rewrite inE.
+ rewrite (eq_in_pr (B := pred0)) ?pr_pred0 // => m''.
  move/mod_spec=> /(_ _ (eqxx _)) => /asboolP eq_m'_m''.
  by apply/asboolPn => eq_m_m''; apply/h; rewrite eq_m'_m''.
Qed.


Load LFindLoad.
Load LFindLoad.
From adtind Require Import goal10.

From lfind Require Import LFind.
Lemma lfind_state  (n:natural) (l1:lst) (n0:natural) (l2:lst) (IHl2:@eq lst (rev (append (Cons n l1) l2)) (append (rev l2) (rev (Cons n l1)))):@eq lst (append (rev (append l1 (Cons n0 l2))) (Cons n Nil))
  (append (append (rev l2) (Cons n0 Nil)) (append (rev l1) (Cons n Nil))).
Admitted.
From QuickChick Require Import QuickChick.
QCInclude "/home/yousef/lemmafinder/benchmark/_lfind_clam_lf_goal10_rev_append_54_append_rev_Cons/".
QCInclude ".".
Extract Constant defNumTests => "50".
Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.
Derive Show for lst.

              Derive Arbitrary for lst.

              Instance Dec_Eq_lst : Dec_Eq lst.

              Proof. dec_eq. Qed.

Open Scope string_scope.

Parameter print : natural -> string -> natural.
Extract Constant print => "Extract.print".
Definition collect_data  (n:natural) (l1:lst) (n0:natural) (l2:lst) :=
 let lfind_var := "n:" ++ "(" ++ show n ++ ")"++ "|" ++"l1:" ++ "(" ++ show l1 ++ ")"++ "|" ++"n0:" ++ "(" ++ show n0 ++ ")"++ "|" ++"l2:" ++ "(" ++ show l2 ++ ")"
 in let lfind_v := print n lfind_var
 in lfind_state lfind_v  l1 n0 l2.
QuickChick collect_data.
Success.


Require Import bedrock2.NotationsCustomEntry.

Import Syntax BinInt String List.ListNotations.
Local Open Scope string_scope. Local Open Scope Z_scope. Local Open Scope list_scope.

Definition uint128_add := func! (s, a, b) ~> c {
    a0 = load4(a); a = a+$4;
    b0 = load4(b); b = b+$4;
    s0 = a0 + b0;
        a1 = load4(a); a = a+$4;
        b1 = load4(b); b = b+$4;
        c1 = s0 < a0;
        s1 = a1 + b1;
            a2 = load4(a);
            c2 = s1 < a1;
        s1 = c1 + s1;
                           a = a+$4;
            c2p = s1 < c1;
            b2 = load4(b); b = b+$4;
            c2 = c2 + c2p;
            s2 = a2 + b2;
                a3 = load4(a);
                b3 = load4(b);
                c3 = s2 < a2;
            s2 = c2 + s2;
    store4(s, s0); s = s+$4;
                c3p = s2 < c2;
                c3 = c3 + c3p;
                s3 = a3 + b3;
        store4(s, s1); s = s+$4;
                    c = s3 < a3;
                s3 = c3 + s3;
            store4(s, s2); s = s+$4;
                    c4p = s3 < c3;
                store4(s, s3);
                    c = c + c4p
}.

Require Import bedrock2.FE310CSemantics bedrock2.Semantics .
Require Import bedrock2.WeakestPrecondition bedrock2.ProgramLogic.
Require Import coqutil.Word.Interface coqutil.Word.Bitwidth.
Require Import coqutil.Map.Interface bedrock2.Map.SeparationLogic.
Require Import bedrock2.Array bedrock2.Scalars.
Require Import bedrock2.ZnWords.
Require Import coqutil.Tactics.Tactics.
Local Ltac invert H := inversion H; clear H.

Section WithParameters.
  Context {word: word.word 32} {mem: map.map word Byte.byte}.
  Context {word_ok: word.ok word} {mem_ok: map.ok mem}.
  Local Notation "m =* P" := ((P%sep) m) (at level 70, only parsing) (* experiment*).
  Local Notation "m =*> P" := (exists R, (sep P R) m) (at level 70, only parsing) (* experiment*).
  Import ProgramLogic.Coercions.
  Local Number Notation nat Nat.of_num_uint Nat.to_num_hex_uint (abstract after 5001) : core_scope.
  Local Number Notation nat Nat.of_num_uint Nat.to_num_uint (abstract after 5001) : core_scope.
  Local Open Scope core_scope.
  Local Notation array32 := (array scalar32 (word.of_Z 4)).

  Definition eval : list word -> Z :=
    List.fold_right (fun a s => word.unsigned a + 2^32*s) 0.

  Instance spec_of_uint128_add : spec_of "uint128_add" :=
    fnspec! "uint128_add" ps pa pb / a b s R ~> c,
    { requires t m :=
        m =*> array32 pa a     /\ length a = 4 /\
        m =*> array32 pb b     /\ length b = 4 /\
        m =*  array32 ps s * R /\ length s = 4;
      ensures T M := exists s,
        M =*  array32 ps s * R /\ length s = 4 /\
        T = t /\ 2^128*c + eval s = eval a + eval b }.

  Lemma ltu_as_carry (a b : word)
    (s : word := word.add a b)
    (c : word := if word.ltu s a then word.of_Z 1 else word.of_Z 0)
    : word.unsigned c = (a + b) /  2 ^ 32.
  Proof.
    subst s c. rewrite word.unsigned_ltu. destr (word.add a b <? a); ZnWords.
  Qed.

  Lemma uint128_add_ok : program_logic_goal_for_function! uint128_add.
  Proof.
    straightline; repeat straightline_cleanup.

    repeat match goal with
    | H : length ?l = _ |- _ =>
        let x := fresh l "_0" in destruct l as [(*nil*)|x l]; invert H
    end; unfold array in *.

    repeat straightline.
    (* exfalso; clear dependent mem. *)
    clear dependent pa; clear dependent pb. clear -H5 mem_ok word_ok.

    exists [s0; s1; s2; s3]; ssplit; try ecancel_assumption; trivial.

    (* repeat match goal with x := _ |- _ => subst x end. *)

    repeat match goal with
    | c := if word.ltu _ _ then _ else _ |- _ =>
        let H := fresh "H" c in
        pose proof (ltu_as_carry _ _ : word.unsigned c = _) as H;
        move H before c; clearbody c; move c before word_ok
    end.
    clear dependent ps; clear dependent mem.

    unfold eval, List.fold_right; ZnWords.
  Qed.
End WithParameters.


Require Import isla.isla.
Require Import isla.aarch64.aarch64.
Require Export isla.examples.pkvm_handler.a7400.

Lemma a7400_spec `{!islaG Σ} `{!threadG} pc:
  instr pc (Some a7400) -∗
  instr_body pc (stp_uninit_spec pc "R0" "R1" "SP_EL2" (-16) true).
Proof.
  iStartProof.
  repeat liAStep; liShow.
  Unshelve. all: prepare_sidecond.
  all: bv_solve.
Qed.

Definition a7400_spec_inst `{!islaG Σ} `{!threadG} pc :=
  entails_to_simplify_hyp 0 (a7400_spec pc).
Global Existing Instance a7400_spec_inst.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal33.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj23synthconj4 : forall  (lv0 : natural) (lv1 : natural) (lv2 : natural), (@eq natural (Succ (plus (plus (mult lv0 (plus Zero lv1)) lv1) lv0)) (plus lv2 (Succ lv1))).
Admitted.
QuickChick conj23synthconj4.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall A B C Q X : Universe, ((wd_ X C /\ (wd_ A X /\ (wd_ B Q /\ (wd_ Q C /\ (wd_ A B /\ (wd_ B C /\ (wd_ A C /\ (wd_ Q A /\ (col_ Q X A /\ (col_ B Q C /\ (col_ A X C /\ col_ X X B))))))))))) -> col_ A B C)).
Proof.
  time tac.
Qed.

End FOFProblem.


(* *********************************************************************)
(*                                                                     *)
(*            The CertiKOS Certified Kit Operating System              *)
(*                                                                     *)
(*                   The FLINT Group, Yale University                  *)
(*                                                                     *)
(*  Copyright The FLINT Group, Yale University.  All rights reserved.  *)
(*  This file is distributed under the terms of the Yale University    *)
(*  Non-Commercial License Agreement.                                  *)
(*                                                                     *)
(* *********************************************************************)
(* *********************************************************************)
(*                                                                     *)
(*    Definitions used in verification of proc module initialization   *)
(*                                                                     *)
(*                       Xiongnan (Newman) Wu                          *)
(*                                                                     *)
(*                         Yale University                             *)
(*                                                                     *)
(* *********************************************************************)
Require Import Coqlib.
Require Import ZArith.Zwf.
Require Import DataType.
Require Import ProcDataType.
Require Import VirtDataType.
Require Import MemoryExtra.
Require Import Maps.
Require Import Integers.
Require Import CDataTypes.
Require Import LayerDefinition.
Require Import CInitSpecsMPTOp.
Require Import CInitSpecsMPTCommon.
Require Import CInitSpecsMPTBit.
Require Import PThreadIntro.
Require Import PQueueIntro.
Require Import PIPCIntro.
Require Import RealParams.

(** Perhaps this is useful elsewhere? *)
Section INITZMAP.
  (* Initialize elements [0..n) of a ZMap to a constant value *)
  Fixpoint init_zmap_nat {A} (n: nat) (x: A) (f: ZMap.t A): ZMap.t A :=
    match n with
      | O => f
      | S i => ZMap.set (Z.of_nat i) x (init_zmap_nat i x f)
    end.

  Lemma init_zmap_nat_inside {A} (n: nat) (x: A) (f: ZMap.t A) (i: Z):
    0 <= i < (Z.of_nat n) ->
    ZMap.get i (init_zmap_nat n x f) = x.
  Proof.
    induction n; intros.
    * rewrite Nat2Z.inj_0 in H.
      omega.
    * simpl.
      destruct (Z.eq_dec i (Z.of_nat n)) as [Hi | Hi].
      + rewrite <- Hi.
        rewrite ZMap.gss.
        reflexivity.
      + rewrite ZMap.gso.
        - apply IHn.
          rewrite Nat2Z.inj_succ in H.
          omega.
        - assumption.
  Qed.

  (* This version has (n: Z) instead of (n: nat) *)
  Definition init_zmap {A} (n: Z): A -> ZMap.t A -> ZMap.t A :=
    init_zmap_nat (Z.to_nat n).

  Lemma init_zmap_inside {A} (n: Z) (x: A) (f: ZMap.t A) (i: Z):
    0 <= i < n ->
    ZMap.get i (init_zmap n x f) = x.
  Proof.
    intros H.
    unfold init_zmap.
    apply init_zmap_nat_inside.
    rewrite Z2Nat.id; omega.
  Qed.

  Lemma init_zmap_eq {A} (i: Z) (x: A) (f: ZMap.t A):
    0 <= i ->
    init_zmap (i+1) x f = ZMap.set i x (init_zmap i x f).
  Proof.
    intro Hi.
    unfold init_zmap.
    change (i + 1) with (Z.succ i).
    rewrite Z2Nat.inj_succ by assumption.
    simpl.
    rewrite Z2Nat.id by assumption.
    reflexivity.
  Qed.
End INITZMAP.

(* Initialize a TCB pool *)
Section CInitSpecsAbPThreadIntro.
  Definition real_abtcb :=
    init_zmap num_proc (AbTCBValid DEAD (-1)).

  (* FIXME: inconsistent naming *)
  Lemma real_abtcb_init abtcb:
    AbTCBInit (real_abtcb abtcb) 0 num_proc.
  Proof.
    intros i.
    apply init_zmap_inside.
  Qed.
End CInitSpecsAbPThreadIntro.

(* Initialize a pool of thread queues *)
Section CInitSpecsAbPQueueIntro.
  Definition real_abq :=
    init_zmap (num_chan + 1) (AbQValid nil).

  (* FIXME: inconsistent naming *)
  Lemma real_abq_init abq:
    AbQInit (real_abq abq) 0 num_chan.
  Proof.
    intros i Hi.
    apply init_zmap_inside.
    omega.
  Qed.
End CInitSpecsAbPQueueIntro.

Section CInitSpecsPThreadIntro.

  Context `{real_params_ops : RealParamsOps}.

  Notation DATA := (PTHREADINTRO.AbData (PgSize:= PgSize) (num_proc:= num_proc) (kern_high:= kern_high) (kern_low := kern_low) (maxpage:= maxpage)).

  Context {PTHREADINTRO_mem}
              `{Hlmmh: !LayerMemoryModel DATA PTHREADINTRO_mem}.

  Instance pthread_intro_layer: LayerDefinition DATA PTHREADINTRO.primOp PTHREADINTRO_mem :=
        PTHREADINTRO.layer_def (maxpage := maxpage) (real_nps:= real_nps) (real_AT:= real_AT) (HPS4:= HPS4) (Hlow:= Hlow) (Hhigh:= Hhigh) (real_ptp:= real_ptp) (real_pt:= real_pt) (real_ptb:= real_ptb) (Hnpc:= Hnpc) (real_free_pt:= real_free_pt) (STACK_LOC:= STACK_LOC).

  (** thread_init *)

  Definition real_tcb: TCBPool -> TCBPool :=
    init_zmap num_proc (TCBValid DEAD num_proc num_proc).

  Lemma real_TCB_valid: forall tcb, TCBCorrect_range (real_tcb tcb) 0 num_proc.
  Proof.
    unfold TCBCorrect_range.
    unfold TCBCorrect.
    intros.
    unfold real_tcb.
    rewrite init_zmap_inside by assumption.
    exists DEAD.
    exists 64.
    exists 64.
    split.
    tauto.
    omega.
  Qed.

  (* FIXME: inconsistent naming *)
  Lemma real_TCB_init: forall tcb, TCBInit (real_tcb tcb) 0 num_proc.
  Proof.
    unfold TCBInit.
    intros.
    unfold real_tcb.
    rewrite init_zmap_inside by assumption.
    reflexivity.
  Qed.

  Definition thread_init_madt (m: PTHREADINTRO_mem) := PTHREADINTRO.ADT (Mem.get_abstract_data m).

  Definition thread_init_mk_rdata (m: PTHREADINTRO_mem) (index: Z) :=
    let adt := (thread_init_madt m) in
      PTHREADINTRO.mkRData
        (PTHREADINTRO.HP adt)
        (PTHREADINTRO.AT adt)
        (PTHREADINTRO.nps adt)
        (PTHREADINTRO.ti adt)
        (PTHREADINTRO.PT adt)
        (PTHREADINTRO.ptpool adt)
        (PTHREADINTRO.pb adt)
        (PTHREADINTRO.kctxt adt)
        (init_zmap (index + 1) (TCBValid DEAD num_proc num_proc) (PTHREADINTRO.tcb adt))
        (PTHREADINTRO.pe adt)
        (PTHREADINTRO.ikern adt)
        (PTHREADINTRO.ipt adt)
        true.

  Lemma thread_init_mk_rinv  (m: PTHREADINTRO_mem) (index: Z):
    PTHREADINTRO.RInv  (kern_low:= kern_low) (kern_high:= kern_high) (maxpage:= maxpage) (num_proc:= num_proc) (PgSize:= PgSize) (thread_init_mk_rdata m index).
  Proof.
    unfold thread_init_mk_rdata.
    generalize (PTHREADINTRO.INV (Mem.get_abstract_data m)).
    intro HRINV.
    inv HRINV.
    unfold thread_init_madt.
    constructor; simpl; auto.
    intro contra; discriminate contra.
  Qed.

  Lemma thread_init_ABD_EX (m: PTHREADINTRO_mem) (index: Z):
    {abd | (PTHREADINTRO.ADT (kern_low:= kern_low) (kern_high:= kern_high) (maxpage:= maxpage) (num_proc:= num_proc) (PgSize:= PgSize)abd) = (thread_init_mk_rdata m index)}.
  Proof.
    unfold thread_init_mk_rdata.
    exists (PTHREADINTRO.mkAbData (thread_init_mk_rdata m index) (thread_init_mk_rinv m index)).
    simpl.
    trivial.
  Qed.

  Definition thread_init_mk_abdata (m: PTHREADINTRO_mem) (index: Z) := match (thread_init_ABD_EX m index) with
    | exist a _ => a
  end.

End CInitSpecsPThreadIntro.

Section CInitSpecsPQueueIntro.

  Context `{real_params_ops : RealParamsOps}.

  Notation DATA := (PQUEUEINTRO.AbData (PgSize:= PgSize) (num_proc:= num_proc) (kern_high:= kern_high) (kern_low := kern_low) (maxpage:= maxpage)).

  Context {PQUEUEINTRO_mem}
              `{Hlmmh: !LayerMemoryModel DATA PQUEUEINTRO_mem}.

  Instance pqueue_intro_layer: LayerDefinition DATA PQUEUEINTRO.primOp PQUEUEINTRO_mem :=
        PQUEUEINTRO.layer_def (maxpage := maxpage) (real_nps:= real_nps) (real_AT:= real_AT) (HPS4:= HPS4) (Hlow:= Hlow) (Hhigh:= Hhigh) (real_ptp:= real_ptp) (real_pt:= real_pt) (real_ptb:= real_ptb) (Hnpc:= Hnpc) (real_free_pt:= real_free_pt) (STACK_LOC:= STACK_LOC) (num_chan:= num_chan) (real_tcb:= real_tcb).

  (** tdqueue_init *)

  Fixpoint Calculate_tdq (i: nat) (tdq: TDQueuePool) : TDQueuePool :=
    match i with
      | O => ZMap.set 0 (TDQValid num_proc num_proc) tdq
      | S k => ZMap.set (Z.of_nat (S k)) (TDQValid num_proc num_proc) (Calculate_tdq k tdq)
    end.

  Definition real_tdq: TDQueuePool -> TDQueuePool :=
    init_zmap (num_chan + 1) (TDQValid num_proc num_proc).

  (* FIXME: inconsistent naming *)
  Lemma real_tdq_valid: forall tdq, TDQInit (real_tdq tdq) 0 num_chan num_proc.
  Proof.
    unfold TDQInit.
    intros.
    unfold real_tdq.
    rewrite init_zmap_inside by omega.
    reflexivity.
  Qed.

  Definition tdqueue_init_madt (m: PQUEUEINTRO_mem) := PQUEUEINTRO.ADT (Mem.get_abstract_data m).

  Definition tdqueue_init_mk_rdata (m: PQUEUEINTRO_mem) (index: Z) := let adt := (tdqueue_init_madt m) in (PQUEUEINTRO.mkRData (PQUEUEINTRO.HP adt) (PQUEUEINTRO.AT adt) (PQUEUEINTRO.nps adt) (PQUEUEINTRO.ti adt) (PQUEUEINTRO.PT adt) (PQUEUEINTRO.ptpool adt) (PQUEUEINTRO.pb adt) (PQUEUEINTRO.kctxt adt) (PQUEUEINTRO.tcb adt) (Calculate_tdq (Z.to_nat index) (PQUEUEINTRO.tdq adt)) (PQUEUEINTRO.pe adt) (PQUEUEINTRO.ikern adt) (PQUEUEINTRO.ipt adt) true).

  Lemma tdqueue_init_mk_rinv  (m: PQUEUEINTRO_mem) (index: Z):
    PQUEUEINTRO.RInv  (kern_low:= kern_low) (kern_high:= kern_high) (maxpage:= maxpage) (num_proc:= num_proc) (PgSize:= PgSize) (tdqueue_init_mk_rdata m index).
  Proof.
    unfold tdqueue_init_mk_rdata.
    generalize (PQUEUEINTRO.INV (Mem.get_abstract_data m)).
    intro HRINV.
    inv HRINV.
    unfold tdqueue_init_madt.
    constructor; simpl; auto.
    intro contra; discriminate contra.
  Qed.

  Lemma tdqueue_init_ABD_EX (m: PQUEUEINTRO_mem) (index: Z):
    {abd | (PQUEUEINTRO.ADT (kern_low:= kern_low) (kern_high:= kern_high) (maxpage:= maxpage) (num_proc:= num_proc) (PgSize:= PgSize)abd) = (tdqueue_init_mk_rdata m index)}.
  Proof.
    unfold tdqueue_init_mk_rdata.
    exists (PQUEUEINTRO.mkAbData (tdqueue_init_mk_rdata m index) (tdqueue_init_mk_rinv m index)).
    simpl.
    trivial.
  Qed.

  Definition tdqueue_init_mk_abdata (m: PQUEUEINTRO_mem) (index: Z) := match (tdqueue_init_ABD_EX m index) with
    | exist a _ => a
  end.

End CInitSpecsPQueueIntro.

Section CInitSpecsPIPCIntro.

  Context `{real_params_ops : RealParamsOps}.

  Notation DATA := (PIPCINTRO.AbData (PgSize:= PgSize) (num_proc:= num_proc) (kern_high:= kern_high) (kern_low := kern_low) (maxpage:= maxpage) (num_chan:= num_chan)).

  Local Instance LdataOp:AbstractDataOps DATA:= (PIPCINTRO.abstract_data (Hnpc:= Hnpc)).

  Context {PIPCINTRO_mem}
              `{Hlmmh: !LayerMemoryModel DATA PIPCINTRO_mem}.

  Instance pipc_intro_layer: LayerDefinition DATA PIPCINTRO.primOp PIPCINTRO_mem :=
        PIPCINTRO.layer_def (maxpage := maxpage) (real_nps:= real_nps) (real_AT:= real_AT) (HPS4:= HPS4) (Hlow:= Hlow) (Hhigh:= Hhigh) (real_ptp:= real_ptp) (real_pt:= real_pt) (real_ptb:= real_ptb) (Hnpc:= Hnpc) (real_free_pt:= real_free_pt) (STACK_LOC:= STACK_LOC) (num_chan:= num_chan) (real_abtcb:= real_abtcb) (real_abq:= real_abq) (Hnchan:= Hnchan).

  (** proc_init *)

  Definition real_chpool: ChanPool -> ChanPool :=
    init_zmap num_chan (ChanValid Int.zero Int.zero).

  Lemma real_chpool_valid: forall chpool, ChanPool_Init (real_chpool chpool) 0 num_chan.
  Proof.
    generalize max_unsigned_val; intro muval.
    unfold ChanPool_Init.
    unfold Channel_Init.
    intros.
    unfold real_chpool.
    rewrite init_zmap_inside by omega.
    reflexivity.
  Qed.

  Definition proc_init_madt (m: PIPCINTRO_mem) := PIPCINTRO.ADT (Mem.get_abstract_data m).

  Definition proc_init_mk_rdata (m: PIPCINTRO_mem) (index: Z) :=
    let adt := (proc_init_madt m) in
      PIPCINTRO.mkRData
        (PIPCINTRO.HP adt)
        (PIPCINTRO.AT adt)
        (PIPCINTRO.nps adt)
        (PIPCINTRO.ti adt)
        (PIPCINTRO.PT adt)
        (PIPCINTRO.ptpool adt)
        (PIPCINTRO.pb adt)
        (PIPCINTRO.kctxt adt)
        (PIPCINTRO.abtcb adt)
        (PIPCINTRO.abq adt)
        (PIPCINTRO.cid adt)
        (init_zmap (index + 1) (ChanValid Int.zero Int.zero) (PIPCINTRO.chpool adt))
        (PIPCINTRO.pe adt)
        (PIPCINTRO.ikern adt)
        (PIPCINTRO.ipt adt)
        true.

  Lemma proc_init_mk_rinv  (m: PIPCINTRO_mem) (index: Z):
    PIPCINTRO.RInv  (kern_low:= kern_low) (kern_high:= kern_high) (maxpage:= maxpage) (num_proc:= num_proc) (PgSize:= PgSize) (num_chan:= num_chan) (proc_init_mk_rdata m index).
  Proof.
    unfold proc_init_mk_rdata.
    generalize (PIPCINTRO.INV (Mem.get_abstract_data m)).
    intro HRINV.
    inv HRINV.
    unfold proc_init_madt.
    constructor; simpl; auto.
    intro contra; discriminate contra.
  Qed.

  Lemma proc_init_ABD_EX (m: PIPCINTRO_mem) (index: Z):
    {abd | (PIPCINTRO.ADT (kern_low:= kern_low) (kern_high:= kern_high) (maxpage:= maxpage) (num_proc:= num_proc) (PgSize:= PgSize) (num_chan:= num_chan) abd) = (proc_init_mk_rdata m index)}.
  Proof.
    unfold proc_init_mk_rdata.
    exists (PIPCINTRO.mkAbData (proc_init_mk_rdata m index) (proc_init_mk_rinv m index)).
    simpl.
    trivial.
  Qed.

  Definition proc_init_mk_abdata (m: PIPCINTRO_mem) (index: Z) := match (proc_init_ABD_EX m index) with
    | exist a _ => a
  end.

End CInitSpecsPIPCIntro.


Require Import Crypto.Specific.Framework.RawCurveParameters.
Require Import Crypto.Util.LetIn.

(***
Modulus : 2^369 - 25
Base: 52 + 5/7
***)

Definition curve : CurveParameters :=
  {|
    sz := 7%nat;
    base := 52 + 5/7;
    bitwidth := 64;
    s := 2^369;
    c := [(1, 25)];
    carry_chains := Some [seq 0 (pred 7); [0; 1]]%nat;

    a24 := None;
    coef_div_modulus := Some 2%nat;

    goldilocks := None;
    karatsuba := None;
    montgomery := false;
    freeze := Some true;
    ladderstep := false;

    mul_code := None;

    square_code := None;

    upper_bound_of_exponent_loose := None;
    upper_bound_of_exponent_tight := None;
    allowable_bit_widths := None;
    freeze_extra_allowable_bit_widths := None;
    modinv_fuel := None
  |}.

Ltac extra_prove_mul_eq _ := idtac.
Ltac extra_prove_square_eq _ := idtac.


Require Import Coq.ZArith.ZArith.
Require Import Coq.micromega.Lia.
Require Import Coq.Strings.String.
Require Import Coq.Lists.List.
Require Import bedrock2.Array.
Require Import bedrock2.ProgramLogic.
Require Import bedrock2.Syntax.
Require Import bedrock2.Map.Separation.
Require Import bedrock2.Map.SeparationLogic.
Require Import coqutil.Word.Interface.
Require Import Crypto.Arithmetic.Core.
Require Import Crypto.Arithmetic.Partition.
Require Import Crypto.Bedrock.Field.Translation.Parameters.Defaults64.
Require Import Crypto.Bedrock.Field.Common.Tactics.
Require Import Crypto.Bedrock.Field.Common.Types.
Require Import Crypto.Bedrock.Field.Synthesis.Generic.Bignum.
Require Import Crypto.Bedrock.Field.Synthesis.Generic.Operation.
Require Import Crypto.Bedrock.Field.Synthesis.Generic.UnsaturatedSolinas.
Require Import Crypto.Bedrock.Field.Synthesis.Specialized.Tactics.
Require Import Crypto.Bedrock.Field.Synthesis.Specialized.UnsaturatedSolinas.
Require Import Crypto.Bedrock.Field.Synthesis.Examples.X25519_64.
Require Import Crypto.COperationSpecifications.
Require Import Crypto.UnsaturatedSolinasHeuristics.
Require Import bedrock2.Semantics.
Import ListNotations.
Import Syntax.Coercions.
Local Open Scope Z_scope.

Existing Instances
         default_parameters default_parameters_ok names
         curve25519_bedrock2_funcs curve25519_bedrock2_specs
         curve25519_bedrock2_correctness.
Local Open Scope string_scope.

(* Notations to make spec more readable *)
Local Notation n := X25519_64.n.
Local Notation s := X25519_64.s.
Local Notation c := X25519_64.c.
Local Notation M := (UnsaturatedSolinas.m s c).
Local Notation weight :=
  (ModOps.weight (QArith_base.Qnum
                    (UnsaturatedSolinasHeuristics.limbwidth n s c))
                 (Z.pos (QArith_base.Qden
                           (UnsaturatedSolinasHeuristics.limbwidth n s c)))).
Local Notation eval := (Positional.eval weight n).
Local Notation n_bytes := (UnsaturatedSolinas.n_bytes s).
Local Notation loose_bounds := (UnsaturatedSolinasHeuristics.loose_bounds n s c).
Local Notation tight_bounds := (UnsaturatedSolinasHeuristics.tight_bounds n s c).
Local Notation prime_bytes_bounds :=
  (map (fun v : Z => Some {| ZRange.lower := 0; ZRange.upper := v |})
       (UnsaturatedSolinas.prime_bytes_upperbound_list s)).
Local Infix "*" := sep : sep_scope.
Delimit Scope sep_scope with sep.

Definition encode_decode : func :=
  let x := "x" in
  let tmp := "tmp" in
  ("encode_decode",
   ([x; tmp], [],
    (cmd.seq
       (cmd.call [] "curve25519_to_bytes" [expr.var tmp; expr.var x])
       (cmd.call [] "curve25519_from_bytes" [expr.var x; expr.var tmp])))).

Instance spec_of_encode_decode : spec_of encode_decode :=
  fun functions =>
    forall x old_tmp px ptmp t m R,
      let xz := map word.unsigned x in
      list_Z_bounded_by tight_bounds xz ->
      (Bignum n px x * EncodedBignum n_bytes ptmp old_tmp * R)%sep m ->
      WeakestPrecondition.call
        functions encode_decode t m
        (px :: ptmp :: nil)
        (fun t' m' rets =>
           t = t' /\
           rets = []%list /\
           exists out tmp',
             let outz := map word.unsigned out in
             eval outz mod M = eval xz mod M
             /\ list_Z_bounded_by tight_bounds outz
             /\ (Bignum n px out
                 * EncodedBignum n_bytes ptmp tmp' * R)%sep m').

(* TODO: currently this extra step is required so the literal string isn't
  hidden *)
Instance spec_of_curve25519_to_bytes :
  spec_of "curve25519_to_bytes" := spec_of_to_bytes.
Instance spec_of_curve25519_from_bytes :
  spec_of "curve25519_from_bytes" := spec_of_from_bytes.

Ltac prove_bounds :=
  match goal with
  | H : list_Z_bounded_by tight_bounds ?x
    |- list_Z_bounded_by loose_bounds ?x =>
    apply UnsaturatedSolinas.relax_correct; apply H
  | H : list_Z_bounded_by ?b ?x |- list_Z_bounded_by ?b ?x =>
    apply H
  end.
Ltac prove_length :=
  match goal with
  | |- length _ = _ => rewrite ?map_length; solve [eauto]
  | |- length _ = X25519_64.n =>
    apply bounded_by_loose_bounds_length
      with (s:=X25519_64.s) (c:=X25519_64.c); prove_bounds
  | H : map Byte.byte.unsigned ?x = Partition.partition _ _ _
    |- length ?x = n_bytes =>
    erewrite <-map_length; erewrite H;
    rewrite length_partition; reflexivity
  end.
Ltac prove_preconditions :=
  lazymatch goal with
  | |- length _ = _ => prove_length
  | |- list_Z_bounded_by _ _ => prove_bounds
  end.

(* TODO: postcondition of to_bytes should include the bounds so that this proof
is not needed *)
Lemma bounded_by_prime_bytes_bounds x :
  0 <= x < M ->
  list_Z_bounded_by
    prime_bytes_bounds
    (Partition.partition (ModOps.weight 8 1) n_bytes x).
Proof.
  let weight := constr:(ModOps.weight 8 1) in
  change (prime_bytes_bounds) with
      ((ByteBounds.byte_bounds (n_bytes-1)%nat)
         ++ [Some {| ZRange.lower:=0;
                     ZRange.upper:=
                       ((s - 1) mod (weight n_bytes) / weight (n_bytes-1)%nat);
                  |}])%list.
  change n_bytes with (S (n_bytes-1)).
  rewrite partition_step, Util.list_Z_bounded_by_snoc.
  change (S (n_bytes-1)) with n_bytes.
  split; [ | solve [apply ByteBounds.partition_bounded_by] ].
  pose proof (@weight_positive (ModOps.weight 8 1)
                               ltac:(apply ModOps.wprops; lia))
    as weight_pos.
  pose proof (weight_pos n_bytes).
  pose proof (weight_pos (n_bytes-1)%nat).
  pose proof (Z.mod_pos_bound x (ModOps.weight 8 1 n_bytes)).
  pose proof (Z.mod_le x (ModOps.weight 8 1 n_bytes) ltac:(lia) ltac:(lia)).
  cbv [ZRange.is_bounded_by_bool]. cbn [ZRange.upper ZRange.lower].
  apply Bool.andb_true_iff; split; LtbToLt.Z.ltb_to_lt;
    [ apply Div.Z.div_nonneg; lia | ].
  apply Z.div_le_mono; [ lia | ].
  transitivity (M - 1); [ lia | ].
  vm_compute. congruence.
Qed.

Lemma encode_decode_correct :
  program_logic_goal_for_function! encode_decode.
Proof.
  straightline_init_with_change.

  repeat straightline.
  handle_call; [ prove_preconditions .. | ].
  repeat match goal with
           H : context [Freeze.bytes_n ?a ?b ?c] |- _ =>
           change (Freeze.bytes_n a b c) with n_bytes in H
         end.

  (* to_bytes doesn't explicitly mention bounds in the postcondition, so we need
     to extract them *)
  lazymatch goal with
    H : ?out = Partition.partition _ _ _ |- _ =>
    assert (list_Z_bounded_by prime_bytes_bounds out)
      by (rewrite H; apply bounded_by_prime_bytes_bounds;
          apply Z.mod_pos_bound; reflexivity)
  end.

  repeat straightline.
  handle_call; [ prove_preconditions .. | ].
  repeat match goal with
           H : context [Freeze.bytes_n ?a ?b ?c] |- _ =>
           change (Freeze.bytes_n a b c) with n_bytes in H
         end.

  repeat split; try reflexivity.
  sepsimpl_hyps.
  do 2 eexists; sepsimpl;
    lazymatch goal with
    | |- sep _ _ _ => ecancel_assumption
    | _ => idtac
    end.
  all: try prove_bounds.
  all: try prove_length.

  repeat match goal with
         | H : eval _ mod M = _ |- _ => rewrite H
         | H : map Byte.byte.unsigned _ = _ |- _ => rewrite H
         end.
  rewrite eval_partition
    by (apply UniformWeight.uwprops; lia).
  match goal with
    |- context [(((eval ?a) mod ?m1) mod ?m2) mod ?m1] =>
    let x1 := (eval vm_compute in m1) in
    let x2 := (eval vm_compute in m2) in
    change m2 with x2; change m1 with x1;
      pose proof (Z.mod_pos_bound (eval a) x1 ltac:(lia));
      rewrite (Z.mod_small _ x2) by lia
  end.
  rewrite Z.mod_mod by lia. reflexivity.
Qed.