Require Import Coq.omega.Omega.
Require Import Coq.Strings.Ascii Coq.Bool.Bool Coq.Strings.String Coq.Lists.List.
Require Import Bedrock.Word Bedrock.Memory Bedrock.Expr Bedrock.SepExpr Bedrock.SymEval Bedrock.SepIL Bedrock.Env Bedrock.Prover Bedrock.SymEval Bedrock.IL Bedrock.SymIL.
Require Import Bedrock.sep.Array.
Require Import Bedrock.Allocated.
Require Import Bedrock.ListFacts.

Set Implicit Arguments.

Definition vals := string -> W.

Definition toArray (ns : list string) (vs : vals) : list W := map vs ns.

Definition locals (ns : list string) (vs : vals) (avail : nat) (p : W) : HProp :=
  ([| NoDup ns |] * array (toArray ns vs) p * ((p ^+ $ (length ns * 4)) =?> avail))%Sep.

Definition ascii_eq (a1 a2 : ascii) : bool :=
  let (b1, c1, d1, e1, f1, g1, h1, i1) := a1 in
  let (b2, c2, d2, e2, f2, g2, h2, i2) := a2 in
    eqb b1 b2 && eqb c1 c2 && eqb d1 d2 && eqb e1 e2
    && eqb f1 f2 && eqb g1 g2 && eqb h1 h2 && eqb i1 i2.

Lemma ascii_eq_true : forall a,
  ascii_eq a a = true.
Proof.
  destruct a; simpl; intuition.
  repeat rewrite eqb_reflx; reflexivity.
Qed.

Lemma ascii_eq_false : forall a b,
  a <> b -> ascii_eq a b = false.
  destruct b, a; simpl; intuition.
  match goal with
    | [ |- ?E = _ ] => case_eq E
  end; intuition.
    repeat match goal with
             | [ H : _ |- _ ] => apply andb_prop in H; destruct H
             | [ H : _ |- _ ] => apply eqb_prop in H
           end; congruence.
Qed.

Fixpoint string_eq (s1 s2 : string) : bool :=
  match s1, s2 with
    | EmptyString, EmptyString => true
    | String a1 s1', String a2 s2' => ascii_eq a1 a2 && string_eq s1' s2'
    | _, _ => false
  end.

Theorem string_eq_true : forall s,  string_eq s s = true.
Proof.
  induction s; simpl; intuition; rewrite ascii_eq_true; assumption.
Qed.

Theorem string_eq_false : forall s1 s2,
  s1 <> s2 -> string_eq s1 s2 = false.
  induction s1; destruct s2; simpl; intuition.
  match goal with
    | [ |- ?E = _ ] => case_eq E
  end; intuition.
  repeat match goal with
           | [ H : _ |- _ ] => apply andb_prop in H; destruct H
           | [ H : _ |- _ ] => apply eqb_prop in H
         end.
  destruct (ascii_dec a a0); subst.
  destruct (string_dec s1 s2); subst.
  tauto.
  apply IHs1 in n; congruence.
  apply ascii_eq_false in n; congruence.
Qed.

Theorem string_eq_correct : forall s1 s2,
  string_eq s1 s2 = true -> s1 = s2.
Proof.
  intros; destruct (string_dec s1 s2); subst; auto.
  apply string_eq_false in n; congruence.
Qed.

Definition sel (vs : vals) (nm : string) : W := vs nm.
Definition upd (vs : vals) (nm : string) (v : W) : vals := fun nm' =>
  if string_eq nm' nm then v else vs nm'.

Definition bedrock_type_string : type :=
  {| Impl := string
   ; Eqb := string_eq
   ; Eqb_correct := string_eq_correct |}.

Definition bedrock_type_listString : type :=
  {| Impl := list string
   ; Eqb := (fun _ _ => false)
   ; Eqb_correct := @ILEnv.all_false_compare _ |}.

Definition bedrock_type_vals : type :=
  {| Impl := vals
   ; Eqb := (fun _ _ => false)
   ; Eqb_correct := @ILEnv.all_false_compare _ |}.

Definition types_r : Env.Repr type :=
  Eval cbv beta iota zeta delta [ Env.listOptToRepr ] in
    let lst :=
      (@Some type ILEnv.bedrock_type_W) ::
      (@Some type ILEnv.bedrock_type_setting_X_state) ::
      None ::
      None ::
      (@Some type ILEnv.bedrock_type_nat) ::
      None ::
      (@Some type bedrock_type_string) ::
      (@Some type bedrock_type_listString) ::
      (@Some type bedrock_type_vals) ::
      nil
    in Env.listOptToRepr lst EmptySet_type.

Local Notation "'pcT'" := (tvType 0).
Local Notation "'stT'" := (tvType 1).
Local Notation "'wordT'" := (tvType 0).
Local Notation "'natT'" := (tvType 4).
Local Notation "'stringT'" := (tvType 6).
Local Notation "'listStringT'" := (tvType 7).
Local Notation "'valsT'" := (tvType 8).

Definition badLocalVariable := O.
Global Opaque badLocalVariable.

Fixpoint variablePosition (ns : list string) (nm : string) : nat :=
  match ns with
    | nil => badLocalVariable
    | nm' :: ns' => if string_dec nm' nm then O
      else 4 + variablePosition ns' nm
  end.

Local Notation "'wplusF'" := 0.
Local Notation "'wmultF'" := 2.
Local Notation "'natToWF'" := 5.
Local Notation "'nilF'" := 9.
Local Notation "'consF'" := 10.
Local Notation "'selF'" := 11.
Local Notation "'updF'" := 12.
Local Notation "'InF'" := 13.
Local Notation "'variablePositionF'" := 14.

Section parametric.
  Variable types' : list type.
  Definition types := repr types_r types'.
  Variable Prover : ProverT types.

  Definition nil_r : signature types.
    refine {| Domain := nil; Range := listStringT |}.
    exact (@nil _).
  Defined.

  Definition cons_r : signature types.
    refine {| Domain := stringT :: listStringT :: nil; Range := listStringT |}.
    exact (@cons _).
  Defined.

  Definition sel_r : signature types.
    refine {| Domain := valsT :: stringT :: nil; Range := wordT |}.
    exact sel.
  Defined.

  Definition upd_r : signature types.
    refine {| Domain := valsT :: stringT :: wordT :: nil; Range := valsT |}.
    exact upd.
  Defined.

  Definition In_r : signature types.
    refine {| Domain := stringT :: listStringT :: nil; Range := tvProp |}.
    exact (@In _).
  Defined.

  Definition variablePosition_r : signature types.
    refine {| Domain := listStringT :: stringT :: nil; Range := natT |}.
    exact variablePosition.
  Defined.

  Definition funcs_r : Env.Repr (signature types) :=
    Eval cbv beta iota zeta delta [ Env.listOptToRepr ] in
      let lst :=
        Some (ILEnv.wplus_r types) ::
        None ::
        Some (ILEnv.wmult_r types) ::
        None ::
        None ::
        Some (ILEnv.natToW_r types) ::
        None ::
        None ::
        None ::
        Some nil_r ::
        Some cons_r ::
        Some sel_r ::
        Some upd_r ::
        Some In_r ::
        Some variablePosition_r ::
        nil
      in Env.listOptToRepr lst (Default_signature _).

  Inductive deref_res :=
  | Nothing : deref_res
  | Constant : expr types -> nat -> deref_res
  | Symbolic : expr types -> expr types -> expr types -> deref_res.
  (* Last one's args: base, variable list, and specific variable name *)

  Definition deref (e : expr types) : deref_res :=
    match e with
      | Func wplusF (base :: offset :: nil) =>
        match offset with
          | Func natToWF (Const t k :: nil) =>
            match t return tvarD types t -> _ with
              | natT => fun k => match div4 k with
                                   | None => Nothing
                                   | Some k' => Constant base k'
                                 end
              | _ => fun _ => Nothing
            end k

          | Func natToWF (Func variablePositionF (xs :: x :: nil) :: nil) => Symbolic base xs x

          | _ => Nothing
        end

      | _ => Nothing
    end.

  Fixpoint listIn (e : expr types) : option (list string) :=
    match e with
      | Func nilF nil => Some nil
      | Func consF (Const tp s :: t :: nil) =>
        match tp return tvarD types tp -> option (list string) with
          | stringT => fun s => match listIn t with
                                  | None => None
                                  | Some t => Some (s :: t)
                                end
          | _ => fun _ => None
        end s
      | _ => None
    end.

  Fixpoint sym_sel (vs : expr types) (nm : string) : expr types :=
    match vs with
      | Func updF (vs' :: Const tp nm' :: v :: nil) =>
        match tp return tvarD types tp -> expr types with
          | stringT => fun nm' =>
            if string_eq nm' nm
              then v
              else sym_sel vs' nm
          | _ => fun _ => Func selF (vs :: Const (types := types) (t := stringT) nm :: nil)
        end nm'
      | _ => Func selF (vs :: Const (types := types) (t := stringT) nm :: nil)
    end.

  Definition sym_read (summ : Prover.(Facts)) (args : list (expr types)) (p : expr types)
    : option (expr types) :=
    match args with
      | ns :: vs :: _ :: p' :: nil =>
        match deref p with
          | Nothing => None
          | Constant base offset =>
            match listIn ns with
              | None => None
              | Some ns' =>
                if Prover.(Prove) summ (Equal wordT p' base)
                  then match nth_error ns' offset with
                         | None => None
                         | Some nm => Some (sym_sel vs nm)
                       end
                  else None
            end
          | Symbolic base nms nm =>
            if Prover.(Prove) summ (Equal wordT p' base)
              && Prover.(Prove) summ (Equal listStringT nms ns)
              && Prover.(Prove) summ (Func InF (nm :: nms :: nil))
              then Some (match nm with
                           | Const tp nm' =>
                             match tp return tvarD types tp -> expr types with
                               | stringT => fun nm' => sym_sel vs nm'
                               | _ => fun _ => Func selF (vs :: nm :: nil)
                             end nm'
                           | _ => Func selF (vs :: nm :: nil)
                         end)
              else None
        end
      | _ => None
    end.

  Definition sym_read_easier (summ : Prover.(Facts)) (args : list (expr types)) (p : expr types)
    : option (expr types) :=
    match args with
      | ns :: vs :: _ :: p' :: nil =>
        match deref p with
          | Nothing => None
          | Constant base offset =>
            match listIn ns with
              | None => None
              | Some ns' =>
                if Prover.(Prove) summ (Equal wordT p' base)
                  then match nth_error ns' offset with
                         | None => None
                         | Some nm => Some (sym_sel vs nm)
                       end
                  else None
            end
          | Symbolic base nms nm =>
            if Prover.(Prove) summ (Equal wordT p' base)
              && Prover.(Prove) summ (Equal listStringT nms ns)
              && Prover.(Prove) summ (Func InF (nm :: nms :: nil))
              then Some (Func selF (vs :: nm :: nil))
              else None
        end
      | _ => None
    end.

  Definition sym_write (summ : Prover.(Facts)) (args : list (expr types)) (p v : expr types)
    : option (list (expr types)) :=
    match args with
      | ns :: vs :: avail :: p' :: nil =>
        match deref p with
          | Nothing => None
          | Constant base offset =>
            match listIn ns with
              | None => None
              | Some ns' =>
                if Prover.(Prove) summ (Equal wordT p' base)
                  then match nth_error ns' offset with
                         | None => None
                         | Some nm => Some (ns
                           :: Func updF (vs :: Const (types := types) (t := stringT) nm :: v :: nil)
                           :: avail :: p' :: nil)
                       end
                  else None
            end
          | Symbolic base nms nm =>
            if Prover.(Prove) summ (Equal wordT p' base)
              && Prover.(Prove) summ (Equal listStringT nms ns)
              && Prover.(Prove) summ (Func InF (nm :: nms :: nil))
              then Some (ns
                :: Func updF (vs :: nm :: v :: nil)
                :: avail :: p' :: nil)
              else None
        end
      | _ => None
    end.
End parametric.

Definition MemEval types' : @MEVAL.PredEval.MemEvalPred (types types') :=
  MEVAL.PredEval.Build_MemEvalPred (@sym_read _) (@sym_write _) (fun _ _ _ _ => None) (fun _ _ _ _ _ => None).

Section correctness.
  Variable types' : list type.
  Definition types0 := types types'.

  Definition ssig : SEP.predicate types0 pcT stT.
    refine (SEP.PSig _ _ _ (listStringT :: valsT :: natT :: wordT :: nil) _).
    exact locals.
  Defined.

  Definition ssig_r : Env.Repr (SEP.predicate types0 pcT stT) :=
    Eval cbv beta iota zeta delta [ Env.listOptToRepr ] in
      let lst :=
        None :: None :: Some ssig :: nil
      in Env.listOptToRepr lst (SEP.Default_predicate _ _ _).

  Variable funcs' : functions types0.
  Definition funcs := Env.repr (funcs_r _) funcs'.

  Variable Prover : ProverT types0.
  Variable Prover_correct : ProverT_correct Prover funcs.

  Ltac doMatch P :=
    match P with
      | match ?E with 0 => _ | _ => _ end => destr2 idtac E
      | match ?E with nil => _ | _ => _ end => destr idtac E
      | match ?E with Const _ _ => _ | _ => _ end => destr2 idtac E
      | match ?E with tvProp => _ | _ => _ end => destr idtac E
      | match ?E with None => _ | _ => _ end => destr idtac E
      | match ?E with left _ => _ | _ => _ end => destr2 idtac E
      | match ?E with Nothing => _ | _ => _ end => destr2 idtac E
    end.

  Ltac deconstruct' :=
    match goal with
      | [ H : Some _ = Some _ |- _ ] => injection H; clear H; intros; subst
      | [ H : ?P |- _ ] =>
        let P := stripSuffix P in doMatch P
      | [ H : match ?P with None => _ | _ => _ end |- _ ] =>
        let P := stripSuffix P in doMatch P
      | [ |- match ?P with Nothing => _ | _ => _ end ] =>
        let P := stripSuffix P in doMatch P
    end.

  Ltac deconstruct := repeat deconstruct'.

  Lemma deref_correct : forall uvars vars e w,
    exprD funcs uvars vars e wordT = Some w
    -> match deref e with
         | Nothing => True
         | Constant base offset =>
           exists wb,
             exprD funcs uvars vars base wordT = Some wb
             /\ w = wb ^+ $ (offset * 4)
         | Symbolic base nms nm =>
           exists wb nmsV nmV,
             exprD funcs uvars vars base wordT = Some wb
             /\ exprD funcs uvars vars nms listStringT = Some nmsV
             /\ exprD funcs uvars vars nm stringT = Some nmV
             /\ w = wb ^+ $ (variablePosition nmsV nmV)
       end.
  Proof.
    destruct e; simpl deref; intuition; try discriminate.
    deconstruct.

    match goal with
      | [ |- context[div4 ?N] ] => specialize (div4_correct N);
        destruct (div4 N)
    end; intuition.
    specialize (H0 _ (refl_equal _)); subst.
    simpl in H.
    deconstruct.
    repeat (esplit || eassumption).
    repeat f_equal.
    unfold natToW.
    f_equal.
    omega.

    simpl in H.
    deconstruct.
    destruct (exprD funcs uvars vars e0 listStringT); try discriminate.
    destruct (exprD funcs uvars vars e1 stringT); try discriminate.
    deconstruct; eauto 10.
  Qed.

  Lemma listIn_correct : forall uvars vars e ns, listIn e = Some ns
    -> exprD funcs uvars vars e listStringT = Some ns.
  Proof.
    induction e; simpl; intuition; try discriminate.
    repeat match type of H with
             | Forall _ (_ :: _ :: nil) => inversion H; clear H; subst
             | _ => deconstruct'
           end.
    inversion H4; clear H4; subst.
    clear H5.
    deconstruct.
    simpl in *.
    erewrite H2; reflexivity.
  Qed.

  Lemma sym_sel_correct : forall uvars vars nm (vs : expr types0) vsv,
    exprD funcs uvars vars vs valsT = Some vsv
    -> exprD funcs uvars vars (sym_sel vs nm) wordT = Some (sel vsv nm).
  Proof.
    induction vs; simpl; intros; try discriminate.

    destruct (equiv_dec t valsT); congruence.

    rewrite H; reflexivity.

    rewrite H; reflexivity.

    Ltac t := simpl in *; try discriminate; try (deconstruct;
      match goal with
        | [ _ : Range (match ?E with nil => _ | _ => _ end) === _ |- _ ] =>
          destruct E; simpl in *; try discriminate;
            match goal with
              | [ H : Range ?X === _ |- _ ] => destruct X; simpl in *; hnf in H; subst
            end;
            match goal with
              | [ H : _ = _ |- _ ] => rewrite H; reflexivity
            end
      end).
    simpl in *.

    do 13 (destruct f; t).

    Focus 2.
    deconstruct.
    hnf in e; subst.
    rewrite H0; reflexivity.

    destruct l; simpl in *; try discriminate.
    destruct l; simpl in *; try discriminate.
    rewrite H0; reflexivity.
    destruct e0; simpl in *; try (rewrite H0; reflexivity).
    do 2 (destruct l; simpl in *; try (rewrite H0; reflexivity)).
    destruct t; simpl in *; try (rewrite H0; reflexivity).
    do 7 (destruct n; simpl in *; try (rewrite H0; reflexivity)).
    inversion H; clear H; subst.
    inversion H4; clear H4; subst.
    inversion H5; clear H5; subst.
    clear H6.
    destruct (string_dec t0 nm); subst.
    rewrite string_eq_true.
    deconstruct.
    unfold sel, upd.
    rewrite string_eq_true; reflexivity.

    rewrite string_eq_false by assumption.
    deconstruct.
    erewrite H3 by reflexivity.
    f_equal; unfold sel, upd.
    rewrite string_eq_false; auto.
  Qed.

  Theorem sym_read_easier_correct : forall args uvars vars cs summ pe p ve m stn,
    sym_read_easier Prover summ args pe = Some ve ->
    Valid Prover_correct uvars vars summ ->
    exprD funcs uvars vars pe wordT = Some p ->
    match
      applyD (exprD funcs uvars vars) (SEP.SDomain ssig) args _ (SEP.SDenotation ssig)
      with
      | None => False
      | Some p => ST.satisfies cs p stn m
    end ->
    match exprD funcs uvars vars ve wordT with
      | Some v =>
        ST.HT.smem_get_word (IL.implode stn) p m = Some v
      | _ => False
    end.
  Proof.
    simpl; intuition.
    do 5 (destruct args; simpl in *; intuition; try discriminate).
    generalize (deref_correct uvars vars pe); destruct (deref pe); intro Hderef; try discriminate.

    generalize (listIn_correct uvars vars e); destr idtac (listIn e); intro HlistIn.
    specialize (HlistIn _ (refl_equal _)).
    rewrite HlistIn in *.
    repeat match goal with
             | [ H : Valid _ _ _ _, _ : context[Prove Prover ?summ ?goal] |- _ ] =>
               match goal with
                 | [ _ : context[ValidProp _ _ _ goal] |- _ ] => fail 1
                 | _ => specialize (Prove_correct Prover_correct summ H (goal := goal)); intro
               end
           end; unfold ValidProp in *.
    unfold types0 in *.
    match type of H with
      | (if ?E then _ else _) = _ => destruct E
    end; intuition; try discriminate.
    simpl in H4.
    case_eq (nth_error l n); [ intros ? Heq | intro Heq ]; rewrite Heq in *; try discriminate.
    injection H; clear H; intros; subst.
    generalize (sym_sel_correct uvars vars s e0); intro Hsym_sel.
    destruct (exprD funcs uvars vars e0 valsT); try tauto.
    specialize (Hsym_sel _ (refl_equal _)).
    rewrite Hsym_sel.
    specialize (Hderef _ H1).
    destruct Hderef as [ ? [ ] ].
    subst.
    unfold types0 in H2.
    unfold types0 in H1.
    case_eq (exprD funcs uvars vars e1 natT); [ intros ? Heq' | intro Heq' ]; rewrite Heq' in *; try tauto.
    case_eq (exprD funcs uvars vars e2 wordT); [ intros ? Heq'' | intro Heq'' ]; rewrite Heq'' in *; try tauto.
    rewrite H in H4.
    specialize (H4 (ex_intro _ _ (refl_equal _))).
    hnf in H4; simpl in H4.
    rewrite Heq'' in H4.
    rewrite H in H4.
    subst.
    Require Import Bedrock.PropXTac.
    apply simplify_fwd in H2.
    destruct H2 as [ ? [ ? [ ? [ ] ] ] ].
    destruct H3 as [ ? [ ? [ ? [ ] ] ] ].
    simpl simplify in H2, H3, H5.
    destruct H5.
    apply simplify_bwd in H6.
    generalize (split_semp _ _ _ H3 H7); intro; subst.
    specialize (smem_read_correct' _ _ _ _ (i := natToW n) H6); intro Hsmem.
    rewrite natToW_times4.
    rewrite wmult_comm.
    unfold natToW in *.
    erewrite split_smem_get_word; eauto.
    left.
    rewrite Hsmem.
    f_equal.

    Lemma array_selN : forall nm vs ns n,
      nth_error ns n = Some nm
      -> Array.selN (toArray ns vs) n = sel vs nm.
    Proof.
      induction ns; destruct n; simpl; intuition; try discriminate.
      injection H; clear H; intros; subst; reflexivity.
    Qed.

    Require Import Coq.NArith.NArith Bedrock.Nomega.

    unfold Array.sel.
    apply array_selN.
    apply array_bound in H6.
    rewrite wordToNat_natToWord_idempotent; auto.

    apply nth_error_Some_length in Heq.

    Lemma length_toArray : forall ns vs,
      length (toArray ns vs) = length ns.
    Proof.
      induction ns; simpl; intuition.
    Qed.

    rewrite length_toArray in *.
    apply Nlt_in.
    rewrite Nat2N.id.
    rewrite Npow2_nat.
    omega.

    rewrite length_toArray.
    apply Nlt_in.
    repeat rewrite wordToN_nat.
    repeat rewrite Nat2N.id.
    apply array_bound in H6.
    rewrite length_toArray in *.
    repeat rewrite wordToNat_natToWord_idempotent.
    eapply nth_error_Some_length; eauto.
    apply Nlt_in.
    rewrite Nat2N.id.
    rewrite Npow2_nat.
    omega.
    apply Nlt_in.
    rewrite Nat2N.id.
    rewrite Npow2_nat.
    apply nth_error_Some_length in Heq.
    omega.

    (* Now the [Symbolic] case... *)
    repeat match goal with
             | [ H : Valid _ _ _ _, _ : context[Prove Prover ?summ ?goal] |- _ ] =>
               match goal with
                 | [ _ : context[ValidProp _ _ _ goal] |- _ ] => fail 1
                 | _ => specialize (Prove_correct Prover_correct summ H (goal := goal)); intro
               end
           end; unfold ValidProp in *.
    unfold types0 in *.
    match type of H with
      | (if ?E then _ else _) = _ => case_eq E
    end; intuition; match goal with
                      | [ H : _ = _ |- _ ] => rewrite H in *
                    end; try discriminate.
    simpl in H3, H4, H5.
    apply andb_prop in H6; destruct H6.
    apply andb_prop in H6; destruct H6.
    intuition.
    destruct (Hderef _ H1) as [ ? [ ? [ ] ] ]; clear Hderef; intuition; subst.
    rewrite H10 in *.
    rewrite H5 in *.
    rewrite H11 in *.
    specialize (H4 (ex_intro _ _ (refl_equal _))).
    unfold Provable in H4.
    injection H; clear H; intros; subst.
    simpl exprD in *.
    unfold types0 in *.
    unfold Provable in *.
    simpl exprD in *.
    deconstruct.
    rewrite H10 in *.
    specialize (H3 (ex_intro _ _ (refl_equal _))).
    specialize (H9 (ex_intro _ _ (refl_equal _))).
    subst.
    apply simplify_fwd in H2.
    destruct H2.
    destruct H.
    destruct H.
    destruct H2.
    destruct H2.
    destruct H2.
    destruct H2.
    destruct H5.
    simpl in H.
    simpl in H2.
    simpl in H5.
    destruct H5.
    generalize (split_semp _ _ _ H2 H11); intro; subst.
    apply simplify_bwd in H9.

    Fixpoint variablePosition' (ns : list string) (nm : string) : nat :=
      match ns with
        | nil => O
        | nm' :: ns' => if string_dec nm' nm then O
          else S (variablePosition' ns' nm)
      end.

    specialize (smem_read_correct' _ _ _ _ (i := natToW (variablePosition' t x1)) H9); intro Hsmem.
    rewrite wmult_comm in Hsmem.
    rewrite <- natToW_times4 in Hsmem.

    Lemma variablePosition'_4 : forall nm ns,
      variablePosition' ns nm * 4 = variablePosition ns nm.
      induction ns; simpl; intuition.
      destruct (string_dec a nm); intuition.
    Qed.

    rewrite variablePosition'_4 in Hsmem.
    erewrite split_smem_get_word; eauto.
    left.
    unfold natToW in *.
    rewrite Hsmem.
    f_equal.
    unfold Array.sel.
    apply array_selN.
    apply array_bound in H9.
    rewrite wordToNat_natToWord_idempotent; auto.

    Lemma nth_error_variablePosition' : forall nm ns,
      In nm ns
      -> nth_error ns (variablePosition' ns nm) = Some nm.
      induction ns; simpl; intuition; subst.
      destruct (string_dec nm nm); tauto.
      destruct (string_dec a nm); intuition; subst; auto.
    Qed.

    apply nth_error_variablePosition'; auto.
    rewrite length_toArray in *.
    apply Nlt_in.
    rewrite Nat2N.id.
    rewrite Npow2_nat.

    Lemma variablePosition'_length : forall nm ns,
      In nm ns
      -> (variablePosition' ns nm < length ns)%nat.
      induction ns; simpl; intuition; subst.
      destruct (string_dec nm nm); intuition.
      destruct (string_dec a nm); omega.
    Qed.

    specialize (variablePosition'_length _ _ H4).
    omega.

    red.
    apply array_bound in H9.
    repeat rewrite wordToN_nat.
    rewrite wordToNat_natToWord_idempotent.
    rewrite wordToNat_natToWord_idempotent.
    apply Nlt_in.
    repeat rewrite Nat2N.id.
    rewrite length_toArray.
    apply variablePosition'_length; auto.
    apply Nlt_in.
    rewrite Npow2_nat.
    repeat rewrite Nat2N.id.
    assumption.
    apply Nlt_in.
    rewrite Npow2_nat.
    repeat rewrite Nat2N.id.
    specialize (variablePosition'_length _ _ H4).
    rewrite length_toArray in H9.
    omega.
  Qed.

  Theorem easy_bridge : forall args uvars vars summ pe ve P,
    sym_read Prover summ args pe = Some ve
    -> match
         applyD (exprD funcs uvars vars) (SEP.SDomain ssig) args _ (SEP.SDenotation ssig)
         with
         | None => False
         | Some p => P p
       end
    -> exists ve', sym_read_easier Prover summ args pe = Some ve'
      /\ exprD funcs uvars vars ve wordT = exprD funcs uvars vars ve' wordT.
    intros.
    simpl in H0.
    repeat (destruct args; simpl in *; try discriminate).
    case_eq (exprD funcs uvars vars e0 valsT); [ intros ? Heq | intro Heq ]; rewrite Heq in *.
    Focus 2.
    deconstruct.
    deconstruct.
    match goal with
      | [ |- context[if ?E then _ else _] ] => destruct E
    end; try discriminate.
    deconstruct; eauto.
    match goal with
      | [ |- context[if ?E then _ else _] ] => destruct E
    end; try discriminate.
    deconstruct.
    do 2 esplit; [ reflexivity | ].
    simpl exprD.
    destruct e5; try reflexivity.
    destruct t3; try reflexivity.
    do 7 (destruct n; try reflexivity).
    rewrite Heq.
    erewrite sym_sel_correct by eassumption; reflexivity.
  Qed.

  Theorem sym_read_correct : forall args uvars vars cs summ pe p ve m stn,
    sym_read Prover summ args pe = Some ve ->
    Valid Prover_correct uvars vars summ ->
    exprD funcs uvars vars pe wordT = Some p ->
    match
      applyD (exprD funcs uvars vars) (SEP.SDomain ssig) args _ (SEP.SDenotation ssig)
      with
      | None => False
      | Some p => ST.satisfies cs p stn m
    end ->
    match exprD funcs uvars vars ve wordT with
      | Some v =>
        ST.HT.smem_get_word (IL.implode stn) p m = Some v
      | _ => False
    end.
  Proof.
    intros.
    eapply easy_bridge in H; eauto.
    2: instantiate (1 := fun p => ST.satisfies cs p stn m); eauto.
    destruct H as [ ? [ ] ].
    rewrite H3.
    eapply sym_read_easier_correct; eauto.
  Qed.

  Theorem sym_write_correct : forall args uvars vars cs summ pe p ve v m stn args',
    sym_write Prover summ args pe ve = Some args' ->
    Valid Prover_correct uvars vars summ ->
    exprD funcs uvars vars pe wordT = Some p ->
    exprD funcs uvars vars ve wordT = Some v ->
    match
      applyD (@exprD _ funcs uvars vars) (SEP.SDomain ssig) args _ (SEP.SDenotation ssig)
      with
      | None => False
      | Some p => ST.satisfies cs p stn m
    end ->
    match
      applyD (@exprD _ funcs uvars vars) (SEP.SDomain ssig) args' _ (SEP.SDenotation ssig)
      with
      | None => False
      | Some pr =>
        match ST.HT.smem_set_word (IL.explode stn) p v m with
          | None => False
          | Some sm' => ST.satisfies cs pr stn sm'
        end
    end.
  Proof.
    simpl; intuition.
    do 5 (destruct args; simpl in *; intuition; try discriminate).
    generalize (deref_correct uvars vars pe); destruct (deref pe); intro Hderef; try discriminate.

    generalize (listIn_correct uvars vars e); destr idtac (listIn e); intro HlistIn;
      specialize (HlistIn _ (refl_equal _)); rewrite HlistIn in *.
    destruct (Hderef _ H1); clear Hderef; intuition; subst.
    repeat match goal with
             | [ H : Valid _ _ _ _, _ : context[Prove Prover ?summ ?goal] |- _ ] =>
               match goal with
                 | [ _ : context[ValidProp _ _ _ goal] |- _ ] => fail 1
                 | _ => specialize (Prove_correct Prover_correct summ H (goal := goal)); intro
               end
           end; unfold ValidProp in *.
    unfold types0 in *.
    match type of H with
      | (if ?E then _ else _) = _ => destruct E
    end; intuition; try discriminate.
    simpl in H5.
    case_eq (nth_error l n); [ intros ? Heq | intro Heq ]; rewrite Heq in *; try discriminate.
    injection H; clear H; intros; subst.
    unfold applyD.
    rewrite HlistIn.
    simpl exprD.
    destruct (exprD funcs uvars vars e0 valsT); try tauto.
    unfold Provable in H6.
    simpl in H6.
    rewrite H5 in H6.
    destruct (exprD funcs uvars vars e1 natT); try tauto.
    destruct (exprD funcs uvars vars e2 wordT); try tauto.
    rewrite H2.
    specialize (H6 (ex_intro _ _ (refl_equal _))); subst.
    apply simplify_fwd in H3.
    destruct H3 as [ ? [ ? [ ? [ ] ] ] ].
    destruct H3 as [ ? [ ? [ ? [ ] ] ] ].
    simpl in H, H3, H6, H7.
    destruct H6.
    apply simplify_bwd in H7.
    eapply smem_write_correct' in H7.
    destruct H7 as [ ? [ ] ].
    rewrite natToW_times4.
    rewrite wmult_comm.
    generalize (split_semp _ _ _ H3 H8); intro; subst.
    eapply split_set_word in H7.
    destruct H7.
    destruct H; subst.
    rewrite H10.
    unfold locals.
    apply simplify_bwd.
    exists x4; exists x1.
    repeat split; auto.
    exists smem_emp.
    exists x4.
    simpl; intuition.
    apply split_a_semp_a.
    reflexivity.
    apply simplify_fwd.

    Lemma toArray_irrel : forall vs v nm ns,
      ~In nm ns
      -> toArray ns (upd vs nm v) = toArray ns vs.
      induction ns; simpl; intuition.
      f_equal; auto.
      unfold upd.
      rewrite string_eq_false; auto.
    Qed.

    Lemma nth_error_In : forall A (x : A) ls n,
      nth_error ls n = Some x
      -> In x ls.
      induction ls; destruct n; simpl; intuition; try discriminate; eauto.
      injection H; intros; subst; auto.
    Qed.

    Lemma array_updN : forall vs nm v ns,
      NoDup ns
      -> forall n, nth_error ns n = Some nm
        -> Array.updN (toArray ns vs) n v
        = toArray ns (upd vs nm v).
      induction 1; destruct n; simpl; intuition.
      injection H1; clear H1; intros; subst.
      rewrite toArray_irrel by assumption.
      unfold upd; rewrite string_eq_true; reflexivity.
      rewrite IHNoDup; f_equal; auto.
      unfold upd; rewrite string_eq_false; auto.
      intro; subst.
      apply H.
      eapply nth_error_In; eauto.
    Qed.

    unfold Array.upd in H9.
    rewrite wordToNat_natToWord_idempotent in H9.
    erewrite array_updN in H9; eauto.
    apply nth_error_Some_length in Heq.
    apply array_bound in H9.
    Require Import Bedrock.Arrays.
    rewrite updN_length in H9.
    rewrite length_toArray in H9.
    apply Nlt_in.
    rewrite Nat2N.id.
    rewrite Npow2_nat.
    omega.

    destruct H; auto.

    rewrite length_toArray.
    apply Nlt_in.
    repeat rewrite wordToN_nat.
    repeat rewrite Nat2N.id.
    apply array_bound in H7.
    rewrite length_toArray in *.
    repeat rewrite wordToNat_natToWord_idempotent.
    eapply nth_error_Some_length; eauto.
    apply Nlt_in.
    rewrite Nat2N.id.
    rewrite Npow2_nat.
    omega.
    apply Nlt_in.
    rewrite Nat2N.id.
    rewrite Npow2_nat.
    apply nth_error_Some_length in Heq.
    omega.

    (* Now the [Symbolic] case... *)

    destruct (Hderef _ H1) as [ ? [ ? [ ? [ ] ] ] ]; clear Hderef; intuition; subst.
    repeat match goal with
             | [ H : Valid _ _ _ _, _ : context[Prove Prover ?summ ?goal] |- _ ] =>
               match goal with
                 | [ _ : context[ValidProp _ _ _ goal] |- _ ] => fail 1
                 | _ => specialize (Prove_correct Prover_correct summ H (goal := goal)); intro
               end
           end; unfold ValidProp in *.
    unfold types0 in *.
    match type of H with
      | (if ?E then _ else _) = _ => case_eq E
    end; intuition; match goal with
                      | [ H : _ = _ |- _ ] => rewrite H in *
                    end; try discriminate.
    simpl in H7, H8, H9.
    apply andb_prop in H10; destruct H10.
    apply andb_prop in H10; destruct H10.
    intuition.
    injection H; clear H; intros; subst.
    simpl applyD.
    unfold Provable in *.
    simpl exprD in *.
    deconstruct.
    repeat match goal with
             | [ H : _ = _ |- _ ] => rewrite H in *
             | [ H : _ |- _ ] => specialize (H (ex_intro _ _ (refl_equal _))); subst
           end.
    apply simplify_fwd in H3.
    destruct H3.
    destruct H.
    destruct H.
    simpl in H.
    destruct H3.
    destruct H3.
    destruct H3.
    destruct H3.
    simpl in H3.
    destruct H9.
    simpl in H9.
    destruct H9.
    apply simplify_bwd in H13.
    generalize (split_semp _ _ _ H3 H14); intro; subst.
    eapply smem_write_correct' in H13.
    destruct H13 as [ ? [ ] ].
    rewrite <- variablePosition'_4.
    rewrite natToW_times4.
    rewrite wmult_comm.
    eapply split_set_word in H13.
    destruct H13.
    generalize (proj2 H); intro; subst.
    rewrite H16.
    apply simplify_bwd.
    esplit.
    esplit.
    esplit.
    simpl.
    apply disjoint_split_join; auto.
    esplit.
    esplit.
    esplit.
    esplit.
    simpl.
    apply split_a_semp_a.
    esplit.
    simpl; intuition.
    apply semp_smem_emp.
    apply simplify_fwd.
    unfold Array.upd in H15.
    rewrite wordToNat_natToWord_idempotent in H15.

    Lemma array_updN_variablePosition' : forall vs nm v ns,
      NoDup ns
      -> In nm ns
      -> toArray ns (upd vs nm v) = updN (toArray ns vs) (variablePosition' ns nm) v.
      induction 1; simpl; intuition; subst.
      destruct (string_dec nm nm); try tauto.
      rewrite toArray_irrel; auto.
      unfold upd.
      rewrite string_eq_true.
      auto.

      destruct (string_dec x nm); subst.
      rewrite toArray_irrel; auto.
      unfold upd.
      rewrite string_eq_true.
      auto.

      unfold upd at 1.
      rewrite string_eq_false by auto.
      rewrite H1; auto.
    Qed.

    rewrite array_updN_variablePosition'; auto.

    apply array_bound in H15.
    rewrite updN_length in H15.
    apply Nlt_in.
    rewrite Npow2_nat.
    repeat rewrite Nat2N.id.
    apply variablePosition'_length in H8.
    rewrite length_toArray in H15.
    omega.

    assumption.
    apply H.
    rewrite length_toArray.
    apply Nlt_in.
    repeat rewrite wordToN_nat.
    repeat rewrite Nat2N.id.
    rewrite wordToNat_natToWord_idempotent.
    rewrite wordToNat_natToWord_idempotent.
    apply variablePosition'_length; auto.
    apply array_bound in H13.
    apply Nlt_in.
    rewrite Npow2_nat.
    repeat rewrite Nat2N.id.
    rewrite length_toArray in H13.
    assumption.

    apply Nlt_in.
    rewrite Npow2_nat.
    repeat rewrite wordToN_nat.
    repeat rewrite Nat2N.id.
    apply array_bound in H13.
    generalize (variablePosition'_length _ _ H8).
    rewrite length_toArray in H13.
    omega.
  Qed.

End correctness.

Definition MemEvaluator types' : MEVAL.MemEvaluator (types types') (tvType 0) (tvType 1) :=
  Eval cbv beta iota zeta delta [ MEVAL.PredEval.MemEvalPred_to_MemEvaluator ] in
    @MEVAL.PredEval.MemEvalPred_to_MemEvaluator _ (tvType 0) (tvType 1) (MemEval types') 2.

Theorem MemEvaluator_correct types' funcs' preds'
  : @MEVAL.MemEvaluator_correct (Env.repr types_r types') (tvType 0) (tvType 1)
  (MemEvaluator (Env.repr types_r types')) (funcs funcs') (Env.repr (ssig_r _) preds')
  (IL.settings * IL.state) (tvType 0) (tvType 0)
  (@IL_mem_satisfies (types types')) (@IL_ReadWord (types types')) (@IL_WriteWord (types types'))
  (@IL_ReadByte (types types')) (@IL_WriteByte (types types')).
Proof.
  intros. eapply (@MemPredEval_To_MemEvaluator_correct (types types')); simpl; intros; try discriminate.
  eapply (@sym_read_correct (types types')); eauto.
  eapply (@sym_write_correct (types types')); eauto.
  reflexivity.
Qed.

Definition pack : MEVAL.MemEvaluatorPackage types_r (tvType 0) (tvType 1) (tvType 0) (tvType 0)
  IL_mem_satisfies IL_ReadWord IL_WriteWord IL_ReadByte IL_WriteByte :=

  @MEVAL.Build_MemEvaluatorPackage types_r (tvType 0) (tvType 1) (tvType 0) (tvType 0)
  IL_mem_satisfies IL_ReadWord IL_WriteWord IL_ReadByte IL_WriteByte
  types_r
  funcs_r
  (fun ts => Env.listOptToRepr (None :: None :: Some (ssig ts) :: nil)
    (SEP.Default_predicate (Env.repr types_r ts)
      (tvType 0) (tvType 1)))
  (fun ts => MemEvaluator (types ts))
  (fun ts fs ps => @MemEvaluator_correct (types ts) _ _).

(** * Some additional helpful theorems *)

Theorem sel_upd_eq : forall vs nm v nm',
  nm = nm'
  -> sel (upd vs nm v) nm' = v.
Proof.
  unfold sel, upd; intros; subst; rewrite string_eq_true; reflexivity.
Qed.

Theorem sel_upd_ne : forall vs nm v nm',
  nm <> nm'
  -> sel (upd vs nm v) nm' = sel vs nm'.
Proof.
  unfold sel, upd; intros; subst; rewrite string_eq_false; auto.
Qed.

(*
Require Import PropX.
*)

Ltac simp := cbv beta; unfold In.

(** ** Point-of-view switch at function call sites *)

Lemma behold_the_array' : forall p ns,
  NoDup ns
  -> forall offset, allocated p offset (length ns)
    ===> Ex vs, ptsto32m' nil p offset (toArray ns vs).
  induction 1; simpl length; unfold allocated; fold allocated; intros.

  simpl.
  apply Himp_ex_c.
  exists (fun _ => wzero _).
  apply Himp_refl.

  eapply Himp_trans; [ apply Himp_ex_star | ].
  apply Himp'_ex; intro.
  eapply Himp_trans; [ eapply Himp_star_frame | ]; [ apply Himp_refl | apply IHNoDup | ].
  eapply Himp_trans; [ apply Himp_star_comm | ].
  eapply Himp_trans; [ apply Himp_ex_star | ].
  eapply Himp'_ex; intro.
  simpl toArray.
  unfold ptsto32m'; fold ptsto32m'.

  replace (match offset with
             | 0 => p
             | S _ => p ^+ $ (offset)
           end) with (p ^+ $ (offset)) by (destruct offset; W_eq).

  apply Himp_ex_c; exists (upd x1 x x0).
  eapply Himp_trans; [ apply Himp_star_comm | ].
  apply Himp_star_frame.
  change (upd x1 x x0 x) with (sel (upd x1 x x0) x).
  rewrite sel_upd_eq by reflexivity.
  apply Himp_refl.

  rewrite toArray_irrel by assumption.
  apply Himp_refl.
Qed.

Theorem Himp_star_Emp : forall P,
  Emp * P ===> P.
  intros; intro cs.
  destruct (heq_star_emp_l cs P); auto.
Qed.

Theorem ptsto32m'_out : forall a vs offset,
  ptsto32m' _ a offset vs ===> ptsto32m _ a offset vs.
  induction vs; intros.

  apply Himp_refl.

  unfold ptsto32m', ptsto32m; fold ptsto32m; fold ptsto32m'.
  replace (match offset with
             | 0 => a
             | S _ => a ^+ $ (offset)
           end) with (a ^+ $ (offset)) by (destruct offset; W_eq).
  destruct vs.
  simpl ptsto32m'.
  eapply Himp_trans; [ apply Himp_star_comm | ].
  apply Himp_star_Emp.
  apply Himp_star_frame.
  apply Himp_refl.
  auto.
Qed.

Theorem Himp_ex : forall T (P Q : T -> _),
  (forall v, P v ===> Q v) ->
  ex P ===> ex Q.
  intros; intro cs; apply himp_ex; firstorder.
Qed.

Lemma behold_the_array : forall p ns,
  NoDup ns
  -> forall offset, allocated p offset (length ns)
    ===> Ex vs, ptsto32m nil p offset (toArray ns vs).
  intros.
  eapply Himp_trans; [ apply behold_the_array' | ]; auto.
  apply Himp_ex; intro.
  apply ptsto32m'_out.
Qed.

Lemma do_call' : forall ns ns' vs avail avail' p p',
  (length ns' <= avail)%nat
  -> avail' = avail - length ns'
  -> p' = p ^+ natToW (4 * length ns)
  -> NoDup ns'
  -> locals ns vs avail p ===> locals ns vs 0 p * Ex vs', locals ns' vs' avail' p'.
Proof.
  intros.
  unfold locals.
  eapply Himp_trans; [ | apply Himp_star_assoc' ].
  apply Himp_star_frame.
  apply Himp_refl.

  subst.
  eapply Himp_trans; [ | apply Himp_star_Emp' ].
  eapply Himp_trans; [ apply allocated_split | ]; eauto.
  replace (0 + 4 * length ns') with (length ns' * 4) by omega.
  replace (4 * length ns) with (length ns * 4) by omega.
  eapply Himp_trans.
  eapply Himp_star_frame.
  apply behold_the_array; auto.
  apply Himp_refl.
  eapply Himp_trans; [ apply Himp_ex_star | ].
  apply Himp'_ex; intro vs'.
  apply Himp_ex_c; exists vs'.
  unfold array.
  eapply Himp_trans; [ | apply Himp_star_assoc' ].
  apply Himp_star_pure_cc; auto.
  apply Himp_star_frame.
  apply Himp_refl.
  apply allocated_shift_base; auto.
  unfold natToW; W_eq.
Qed.

Definition reserved (p : W) (len : nat) := (p =?> len)%Sep.

Ltac words' := repeat (rewrite (Mult.mult_comm 4)
  || rewrite natToW_times4 || rewrite natToW_plus); unfold natToW.
Ltac words := words'; W_eq.

Lemma expose_avail : forall ns vs avail p expose avail',
  (expose <= avail)%nat
  -> avail' = avail - expose
  -> locals ns vs avail p ===> locals ns vs avail' p
  * reserved (p ^+ natToW (4 * (length ns + avail'))) expose.
Proof.
  unfold locals; intros.
  eapply Himp_trans; [ | apply Himp_star_assoc' ].
  apply Himp_star_frame.
  apply Himp_refl.
  subst.
  eapply Himp_trans; [ apply allocated_split | ].
  instantiate (1 := avail - expose); omega.
  apply Himp_star_frame.
  apply Himp_refl.
  apply allocated_shift_base; try omega.
  words.
Qed.

Theorem Himp_refl' : forall P Q,
  P = Q
  -> P ===> Q.
  intros; subst; apply Himp_refl.
Qed.

Theorem do_call : forall ns ns' vs avail avail' p p',
  (length ns' <= avail)%nat
  -> (avail' <= avail - length ns')%nat
  -> p' = p ^+ natToW (4 * length ns)
  -> NoDup ns'
  -> locals ns vs avail p ===>
  locals ns vs 0 p
  * Ex vs', locals ns' vs' avail' p'
  * reserved (p ^+ natToW (4 * (length ns + length ns' + avail')))
  (avail - length ns' - avail').
Proof.
  intros; subst.
  eapply Himp_trans; [ apply do_call' | ]; eauto.
  apply Himp_star_frame; [ apply Himp_refl | ].
  apply Himp_ex; intro.
  eapply Himp_trans; [ apply expose_avail | ].
  instantiate (1 := avail - length ns' - avail'); omega.
  eauto.
  apply Himp_star_frame.
  apply Himp_refl'.
  f_equal; omega.
  apply Himp_refl'.
  f_equal.
  words'.
  replace (avail - Datatypes.length ns' -
    (avail - Datatypes.length ns' - avail'))
    with avail' by omega.
  W_eq.
Qed.

Lemma ptsto32m'_allocated : forall (p : W) (ls : list W) (offset : nat),
  ptsto32m' nil p offset ls ===> allocated p offset (length ls).
  induction ls.

  intros; apply Himp_refl.

  simpl length.
  unfold ptsto32m', allocated; fold ptsto32m'; fold allocated.
  intros.
  replace (match offset with
             | 0 => p
             | S _ => p ^+ $ (offset)
           end) with (p ^+ $ (offset)) by (destruct offset; W_eq).
  apply Himp_star_frame.
  apply Himp_ex_c; eexists; apply Himp_refl.
  auto.
Qed.

Lemma ptsto32m_allocated : forall (p : W) (ls : list W) (offset : nat),
  ptsto32m nil p offset ls ===> allocated p offset (length ls).
  intros; eapply Himp_trans.
  apply ptsto32m'_in.
  apply ptsto32m'_allocated.
Qed.

Lemma do_return' : forall ns ns' vs avail avail' p p',
  avail = avail' + length ns'
  -> p' = p ^+ natToW (4 * length ns)
  -> (locals ns vs 0 p * Ex vs', locals ns' vs' avail' p') ===> locals ns vs avail p.
  unfold locals; intros.
  eapply Himp_trans; [ apply Himp_star_assoc | ].
  apply Himp_star_frame; [ apply Himp_refl | ].
  unfold allocated; fold allocated.
  eapply Himp_trans; [ apply Himp_star_Emp | ].
  apply Himp'_ex; intro vs'.
  eapply Himp_trans; [ apply Himp_star_assoc | ].
  apply Himp_star_pure_c; intro.
  subst.
  eapply Himp_trans; [ | apply allocated_join ].
  2: instantiate (1 := length ns'); omega.
  apply Himp_star_frame.
  unfold array.
  words'.
  replace (length ns') with (length (toArray ns' vs')) by apply length_toArray.
  apply ptsto32m_allocated.
  apply allocated_shift_base; try omega.
  words.
Qed.

Lemma unexpose_avail : forall ns vs avail p expose avail',
  (expose <= avail)%nat
  -> avail' = avail - expose
  -> locals ns vs avail' p
  * reserved (p ^+ natToW (4 * (length ns + avail'))) expose
  ===> locals ns vs avail p.
  unfold locals; intros.
  eapply Himp_trans; [ apply Himp_star_assoc | ].
  apply Himp_star_frame; [ apply Himp_refl | ].
  eapply Himp_trans; [ | apply allocated_join ].
  2: instantiate (1 := avail'); omega.
  apply Himp_star_frame; [ apply Himp_refl | ].
  apply allocated_shift_base; try omega.
  subst.
  words.
Qed.

Lemma do_return : forall ns ns' vs avail avail' p p',
  (avail >= avail' + length ns')%nat
  -> p' = p ^+ natToW (4 * length ns)
  -> (locals ns vs 0 p * Ex vs', locals ns' vs' avail' p'
    * reserved (p ^+ natToW (4 * (length ns + length ns' + avail')))
    (avail - length ns' - avail'))
    ===> locals ns vs avail p.
  intros.
  eapply Himp_trans; [ | apply do_return' ].
  3: eassumption.
  Focus 2.
  instantiate (1 := ns').
  instantiate (1 := (avail - avail' - length ns') + avail').
  omega.
  apply Himp_star_frame; [ apply Himp_refl | ].
  apply Himp_ex; intro vs'.
  unfold locals.
  eapply Himp_trans; [ apply Himp_star_assoc | ].
  apply Himp_star_frame; [ apply Himp_refl | ].
  eapply Himp_trans; [ | apply allocated_join ].
  2: instantiate (1 := avail'); omega.
  apply Himp_star_frame; [ apply Himp_refl | ].
  apply allocated_shift_base; try omega.
  subst.
  words.
Qed.

(** ** Point-of-view switch in function preludes *)

Definition agree_on (vs vs' : vals) (ns : list string) :=
  List.Forall (fun nm => sel vs nm = sel vs' nm) ns.

Fixpoint merge (vs vs' : vals) (ns : list string) :=
  match ns with
    | nil => vs'
    | nm :: ns' => upd (merge vs vs' ns') nm (sel vs nm)
  end.

Lemma Forall_weaken : forall A (P P' : A -> Prop),
  (forall x, P x -> P' x)
  -> forall ls, List.Forall P ls
    -> List.Forall P' ls.
Proof.
  induction 2; simpl; intuition.
Qed.

Theorem merge_agree : forall vs vs' ns,
  agree_on (merge vs vs' ns) vs ns.
Proof.
  induction ns; simpl; intuition; constructor.
  unfold sel, upd.
  rewrite string_eq_true; reflexivity.
  eapply Forall_weaken; [ | eassumption ].
  simpl; intros.
  destruct (string_dec a x); subst.
  apply sel_upd_eq; reflexivity.
  rewrite sel_upd_ne; assumption.
Qed.

Lemma NoDup_unapp2 : forall A (ls1 ls2 : list A),
  NoDup (ls1 ++ ls2)
  -> NoDup ls2.
Proof.
  induction ls1; inversion 1; simpl in *; intuition.
Qed.

Lemma toArray_vals_eq : forall vs vs' ns, agree_on vs vs' ns
  -> toArray ns vs = toArray ns vs'.
Proof.
  induction ns; simpl; intuition.
  inversion H; clear H; subst.
  f_equal; auto.
Qed.

Lemma agree_on_symm : forall vs vs' nm, agree_on vs vs' nm
  -> agree_on vs' vs nm.
Proof.
  intros; eapply Forall_weaken; [ | eauto ].
  intuition.
Qed.

Lemma Forall_weaken' : forall A (P P' : A -> Prop) ls,
  List.Forall P ls
  -> (forall x, In x ls -> P x -> P' x)
  -> List.Forall P' ls.
Proof.
  induction 1; simpl; intuition.
Qed.

Lemma ptsto32m'_merge : forall p vs' ns' ns offset vs vs'',
  NoDup (ns ++ ns')
  -> agree_on vs'' (merge vs vs' ns) (ns ++ ns')
  -> ptsto32m' nil p offset (toArray ns vs)
  * ptsto32m' nil p (offset + 4 * length ns) (toArray ns' vs')
  ===> ptsto32m' nil p offset (toArray (ns ++ ns') vs'').
  induction ns; simpl app; intros.

  simpl.
  eapply Himp_trans; [ apply Himp_star_Emp | ].
  apply Himp_refl'.
  f_equal.
  omega.
  simpl in *.
  apply toArray_vals_eq; auto.
  apply agree_on_symm; auto.

  inversion H; clear H; subst.
  simpl in H0.
  simpl toArray; simpl length.
  unfold ptsto32m'; fold ptsto32m'.
  eapply Himp_trans; [ apply Himp_star_assoc | ].
  apply Himp_star_frame.
  apply Himp_refl'.
  f_equal.
  assert (Hin : In a (a :: ns ++ ns')) by (simpl; tauto).
  apply (proj1 (Forall_forall _ _) H0) in Hin.
  rewrite sel_upd_eq in Hin by reflexivity.
  symmetry; assumption.

  eapply Himp_trans; [ | apply IHns ]; auto.
  apply Himp_star_frame.
  apply Himp_refl.
  apply Himp_refl'; f_equal; omega.

  inversion H0; clear H0; subst.
  eapply Forall_weaken'.
  eassumption.
  simpl; intros.
  rewrite H0.
  destruct (string_dec a x); subst.
  tauto.
  rewrite sel_upd_ne by assumption; reflexivity.
Qed.

Lemma ptsto32m_merge : forall p vs' ns' ns offset vs vs'',
  NoDup (ns ++ ns')
  -> agree_on vs'' (merge vs vs' ns) (ns ++ ns')
  -> ptsto32m nil p offset (toArray ns vs)
  * ptsto32m nil p (offset + 4 * length ns) (toArray ns' vs')
  ===> ptsto32m nil p offset (toArray (ns ++ ns') vs'').
Proof.
  intros.
  eapply Himp_trans.
  apply Himp_star_frame; apply ptsto32m'_in.
  eapply Himp_trans; [ | apply ptsto32m'_out ].
  apply ptsto32m'_merge; auto.
Qed.

Lemma agree_on_refl : forall vs ns,
  agree_on vs vs ns.
Proof.
  unfold agree_on; induction ns; simpl; intuition.
Qed.

Lemma ptsto32m'_shift_base : forall p n ls offset,
  (n <= offset)%nat
  -> ptsto32m' nil (p ^+ $ (n)) (offset - n) ls
  ===> ptsto32m' nil p offset ls.
  induction ls.

  intros; apply Himp_refl.

  unfold ptsto32m'; fold ptsto32m'.
  intros.
  intro; apply Himp_star_frame.
  apply Himp_refl'; f_equal.
  rewrite <- wplus_assoc.
  rewrite <- natToW_plus.
  unfold natToW.
  repeat f_equal.
  omega.
  replace (4 + (offset - n)) with ((4 + offset) - n) by omega.
  apply IHls; omega.
Qed.

Lemma ptsto32m_shift_base : forall p n ls offset,
  (n <= offset)%nat
  -> ptsto32m nil (p ^+ $ (n)) (offset - n) ls
  ===> ptsto32m nil p offset ls.
  intros; eapply Himp_trans.
  apply ptsto32m'_in.
  eapply Himp_trans.
  apply ptsto32m'_shift_base; auto.
  apply ptsto32m'_out.
Qed.

Theorem prelude_in : forall ns ns' vs avail p,
  (length ns' <= avail)%nat
  -> NoDup (ns ++ ns')
  -> locals ns vs avail p ===>
  Ex vs', locals (ns ++ ns') (merge vs vs' ns) (avail - length ns') p.
  unfold locals; intros.
  eapply Himp_trans; [ apply Himp_star_assoc | ].
  apply Himp_star_pure_c; intro Hns.
  eapply Himp_trans.
  eapply Himp_star_frame; [ apply Himp_refl | ].
  eapply allocated_split.
  eassumption.
  eapply Himp_trans; [ apply Himp_star_assoc' | ].
  eapply Himp_trans.
  eapply Himp_star_frame.
  apply Himp_star_comm.
  apply Himp_refl.
  eapply Himp_trans; [ apply Himp_star_assoc | ].
  eapply Himp_trans.
  eapply Himp_star_frame.
  apply behold_the_array.
  eapply NoDup_unapp2; eauto.
  apply Himp_refl.
  eapply Himp_trans; [ apply Himp_ex_star | ].
  apply Himp_ex; intro vs'.
  unfold array.
  eapply Himp_trans; [ | apply Himp_star_assoc' ].
  apply Himp_star_pure_cc; auto.
  eapply Himp_trans; [ apply Himp_star_assoc' | ].
  apply Himp_star_frame.
  eapply Himp_trans; [ | apply ptsto32m_merge ]; eauto.
  eapply Himp_trans; [ apply Himp_star_comm | ].
  apply Himp_star_frame.
  apply Himp_refl.
  match goal with
    | [ |- ?P ===> _ ] =>
      replace P
    with (ptsto32m nil (p ^+ $ (Datatypes.length ns * 4)) (0 + 4 * length ns - length ns * 4) (toArray ns' vs'))
      by (f_equal; omega)
  end.
  apply ptsto32m_shift_base.
  omega.
  apply agree_on_refl.

  apply allocated_shift_base; try omega.
  rewrite app_length.
  words.
Qed.

Lemma ptsto32m'_split : forall p ns' ns offset vs,
  ptsto32m' nil p offset (toArray (ns ++ ns') vs)
  ===> ptsto32m' nil p offset (toArray ns vs)
  * ptsto32m' nil p (offset + 4 * length ns) (toArray ns' vs).
Proof.
  induction ns.

  simpl.
  intros.
  eapply Himp_trans; [ | apply Himp_star_Emp' ].
  apply Himp_refl'; f_equal; omega.

  simpl toArray; simpl length.
  unfold ptsto32m'; fold ptsto32m'.
  intros.

  eapply Himp_trans; [ | apply Himp_star_assoc' ].
  apply Himp_star_frame; [ apply Himp_refl | ].
  eapply Himp_trans; [ apply IHns | ].
  apply Himp_star_frame; [ apply Himp_refl | ].
  apply Himp_refl'; f_equal; omega.
Qed.

Lemma ptsto32m_split : forall p ns' ns offset vs,
  ptsto32m nil p offset (toArray (ns ++ ns') vs)
  ===> ptsto32m nil p offset (toArray ns vs)
  * ptsto32m nil p (offset + 4 * length ns) (toArray ns' vs).
  intros; eapply Himp_trans.
  apply ptsto32m'_in.
  eapply Himp_trans.
  apply ptsto32m'_split.
  apply Himp_star_frame; apply ptsto32m'_out.
Qed.

Lemma NoDup_unapp1 : forall A (ls1 ls2 : list A),
  NoDup (ls1 ++ ls2)
  -> NoDup ls1.
  induction ls1; inversion 1; simpl in *; intuition; subst; constructor.
  intro; apply H2.
  apply in_or_app; auto.
  eauto.
Qed.

Lemma ptsto32m'_shift_base' : forall p n ls offset,
  (n <= offset)%nat
  -> ptsto32m' nil p offset ls
  ===> ptsto32m' nil (p ^+ $ (n)) (offset - n) ls.
  induction ls.

  intros; apply Himp_refl.

  unfold ptsto32m'; fold ptsto32m'.
  intros.
  intro; apply Himp_star_frame.
  apply Himp_refl'; f_equal.
  rewrite <- wplus_assoc.
  rewrite <- natToW_plus.
  unfold natToW.
  repeat f_equal.
  omega.
  replace (4 + (offset - n)) with ((4 + offset) - n) by omega.
  apply IHls; omega.
Qed.

Lemma ptsto32m_shift_base' : forall p n ls offset,
  (n <= offset)%nat
  -> ptsto32m nil p offset ls
  ===> ptsto32m nil (p ^+ $ (n)) (offset - n) ls.
  intros; eapply Himp_trans.
  apply ptsto32m'_in.
  eapply Himp_trans.
  apply ptsto32m'_shift_base'.
  2: apply ptsto32m'_out.
  auto.
Qed.

Theorem prelude_out : forall ns ns' vs avail p,
  (length ns' <= avail)%nat
  -> locals (ns ++ ns') vs (avail - length ns') p
  ===> locals ns vs avail p.
  unfold locals; intros.
  eapply Himp_trans; [ apply Himp_star_assoc | ].
  apply Himp_star_pure_c; intro Hboth.
  eapply Himp_trans; [ | apply Himp_star_assoc' ].
  apply Himp_star_pure_cc.
  eapply NoDup_unapp1; eauto.
  unfold array.
  eapply Himp_trans.
  eapply Himp_star_frame.
  apply ptsto32m_split.
  apply Himp_refl.
  eapply Himp_trans; [ apply Himp_star_assoc | ].
  apply Himp_star_frame; [ apply Himp_refl | ].
  eapply Himp_trans; [ | apply allocated_join ].
  2: eassumption.
  apply Himp_star_frame.
  eapply Himp_trans; [ apply ptsto32m_allocated | ].
  apply allocated_shift_base.
  words.
  apply length_toArray.
  apply allocated_shift_base.
  rewrite app_length; words.
  auto.
Qed.

Lemma toArray_sel : forall x V V' ns',
  In x ns'
  -> toArray ns' V' = toArray ns' V
  -> sel V' x = sel V x.
  unfold toArray; induction ns'; simpl; intuition.
  subst.
  injection H0; intros.
  assumption.
  injection H0.
  auto.
Qed.


From discprob.basic Require Import base order nify seq_ext.
From discprob.prob Require Import prob countable finite stochastic_order.
From discprob.monad.finite Require Import monad monad_par_hoare monad_par par_quicksort par_quicksort_correct.
From discprob.monad.finite Require  quicksort_cost.
From discprob.monad.finite Require Import max_triangle.
From discprob.rec Require Import rec_convert quicksort_rec.
From mathcomp Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq div choice fintype.
From mathcomp Require Import tuple finfun bigop prime binomial finset.
From mathcomp Require Import path.
Require Import Reals Fourier Psatz Omega.

Definition h (l: seq nat) :=
  match l with
  | [::] => mret ([::], [::])
  | [::a] => mret ([::], [::])
  | a :: l =>
      p ← draw_pivot a l;
      spl ← dist_ret _ (partition' (sval p) (a :: l));
      mret (lower (sval spl), upper (sval spl))
  end.
Definition rsize (l: seq nat) := INR (size l).

Definition m x :=
  match (Rlt_dec x (4/3)) with
  | left _ => 0
  | _ => x * (3 / 4)
  end.

Lemma uniq_unif n:
  uniq (outcomes (unif n)).
Proof.
  rewrite /unif//=.
  rewrite map_inj_uniq.
  - apply enum_uniq.
  - intros (?&?) (?&?). inversion 1; auto.
    subst; f_equal. apply bool_irrelevance.
Qed.

Lemma uniq_unif2 n:
  uniq ([seq i.2 | i <- outcomes (unif n)]).
Proof.
  rewrite /unif//=.
  rewrite map_inj_in_uniq.
  - apply uniq_unif.
  - intros (?&?) (?&?).
    move /mapP => [? ? Heq1]. inversion Heq1; subst.
    move /mapP => [? ? Heq2]. inversion Heq2; subst.
    rewrite //=. inversion 1. repeat f_equal.
    apply val_inj => //=.
Qed.

Lemma unif_all n x (Hle: (x <= n)%nat):
  {| work := O; span := O; result := exist _ x Hle|} \in [seq i.2 | i <- outcomes (unif n)].
Proof.
  apply /mapP.
  set (a := exist _ x Hle).
  replace {| work := 0; span := 0; result := a|} with
          (1/INR (S n), {| work := 0; span :=0; result := a|}).2; last done.
  do 2 apply /mapP; eexists; eauto.
  rewrite /unif => //=.
  apply /mapP => //=.
  assert (Hlt: (x < S n)%nat) by auto.
  exists (Ordinal Hlt).
  - apply mem_enum.
  - rewrite /a; repeat f_equal. apply bool_irrelevance.
Qed.

Lemma unif_all2 n x (Hle: (x <= n)%nat):
  exist _ x Hle \in [seq (result (i.2)) | i <- outcomes (unif n)].
Proof.
  apply /mapP.
  set (a := exist _ x Hle).
  replace a with
          (result (1/INR (S n), {| work := 0; span :=0; result := a|}).2); last done.
  do 2 apply /mapP; eexists; eauto.
  rewrite /unif => //=.
  apply /mapP => //=.
  assert (Hlt: (x < S n)%nat) by auto.
  exists (Ordinal Hlt).
  - apply mem_enum.
  - rewrite /a; repeat f_equal. apply bool_irrelevance.
Qed.

Lemma unif_cost n a w s :
  {| work := w; span := s; result := a|} \in [seq i.2 | i <- outcomes (unif n)] →
  w = O ∧ s = O.
Proof.
  replace {| work := w; span := s; result := a|} with
          (1/INR (S n), {| work := w; span := s; result := a|}).2; last done.
  move /mapP => [[r' [w' s' a']] Hin].
  move: Hin. rewrite /unif//=.
  move /mapP => [[w'' s'' a''] Hin] [] => ???. subst. inversion Hin. done.
Qed.

Lemma unif_cost2 n:
  [seq {| work := O; span := O; result := result (i.2) |} | i <- unif n] =
  [seq i.2 | i <- unif n].
Proof.
  rewrite -eq_in_map.
  intros (r, a) Hin.
  edestruct (unif_cost n (result a) (work a) (span a)) as [Heq1 Heq2].
  apply /mapP. exists (r, a); destruct a; eauto.
  destruct a as [w s a] => //=. rewrite //= in Heq1 Heq2. subst.
  done.
Qed.

Lemma unif_cost3 n:
  [seq {| work := O; span := O; result := i|}
  | i <- [seq result (i.2) | i <- unif n]] = [seq i.2 | i <- unif n].
Proof.
  rewrite -map_comp -unif_cost2 => //=.
Qed.

Lemma unif_pr n a :
  a \in [seq i.2 | i <- outcomes (unif n)] →
  pr_eq (rvar_of_ldist (unif n)) a = 1 / INR (S n).
Proof.
  intros Hin. rewrite pr_rvar_ldist /unif//=.
  rewrite big_map -big_filter //=.
  destruct a as [w s (x&Hle)] => //=.
  assert (w = O ∧ s = O) as (?&?); last subst.
  { eapply unif_cost. apply Hin. }
  assert (Hlt: (x < S n)%nat) by auto.
  rewrite (bigD1_seq (Ordinal Hlt)) => //=.
  - rewrite -[a in _ = a]Rplus_0_r; f_equal.
    rewrite -big_filter -filter_predI big_filter. apply big_pred0.
    intros i => //=. apply negbTE. apply /andP => [] []. move /eqP => Heq.
    move /eqP => []. intros. subst. apply Heq.
    destruct i. f_equal. apply bool_irrelevance.
  - rewrite mem_filter. apply /andP; split; auto.
    * apply /eqP; f_equal; auto. f_equal. apply bool_irrelevance.
    * apply mem_enum.
  - apply /filter_uniq/enum_uniq.
Qed.

Lemma partition_split l pv:
  let x := partition' pv l in
  lower (sval (result x)) = [ seq n <- l | ltn n pv] ∧
  middle (sval (result x)) = [ seq n <- l | n == pv] ∧
  upper (sval (result x)) = [ seq n <- l | ltn pv n].
Proof.
      induction l as [|a l]; first by rewrite //=.
      rewrite //=; case (ltngtP a pv) => //= ?;
      destruct (IHl) as (?&?&?); repeat split; auto; f_equal; done.
Qed.

Lemma Ex_max_partition_sum l:
  Ex (rvar_comp (rvar_of_ldist (h l)) (λ x, Rmax (rsize (result x).1) (rsize (result x).2))) <=
  match (size l) with
     | O => 0
     | _ => \big[Rplus/0]_(i < size l) (/INR (size l) * (Rmax (INR i) (INR (size l - i - 1))))
  end.
Proof.
  destruct l as [| a l].
  - rewrite Ex_fin_comp.
    rewrite -(big_map _ (λ x, true) (λ a, pr_eq _ a * _ (_ (fst (result a))) (_ (snd (result a))))).
    rewrite img_rvar_of_ldist//=/img/undup//= !big_cons ?big_nil.
    rewrite pr_mret_simpl //= /m/rsize//=.
    rewrite Rmax_left //; last (fourier).
    rewrite /INR. ring_simplify. fourier.
  - destruct l as [| b0 l0].
    {
      rewrite Ex_fin_comp.
      rewrite -(big_map _ (λ x, true) (λ a, pr_eq _ a * _ (_ (fst (result a))) (_ (snd (result a))))).
      rewrite img_rvar_of_ldist//=/img/undup//= !big_cons ?big_nil.
      rewrite pr_mret_simpl //= /m/rsize//=.
      rewrite Rmax_left //; last (fourier).
      replace (INR 0) with 0 by auto. ring_simplify.
      apply Rle_big0 => i _ //=.
      destruct i as (i&Hlt) => //=. assert (i = O) as -> by (nify; omega).
      replace (1 - 0 - 1)%nat with O by (nify; omega).
      replace (INR 0) with 0 by auto. rewrite Rmax_left; last fourier.
      replace (INR 1) with 1 by auto. fourier.
    }
    remember (b0 :: l0) as l eqn:Heql0.

    replace (size (a :: l)) with (S (size l)) by auto.
    rewrite -(Ex_mbind_mret (h (a :: l))).
    rewrite /h Heql0. rewrite -Heql0. clear l0 Heql0.

    rewrite ldist_assoc. rewrite ldist_assoc.
    rewrite Ex_mbind_ldist2.
    rewrite undup_id; last first.
    { apply uniq_unif2. }
    rewrite -unif_cost3 big_map.
    edestruct (quicksort_cost.perm_eq_bij O) as (f&Hfspec&Hfsize&Hinv&Hinj).
    { rewrite perm_sym. apply (permEl (perm_sort leq (a :: l))). }
    eapply sum_reidx_map_le with
        (h := (λ (H : {x : nat | (x <= size l)%nat}),
               let (x, i) := H in
                (Ordinal (n:=(size l).+1) (m:=f x) (Hfsize x i)))).
    * intros (x, Hle) Hin.
      rewrite unif_pr. rewrite /Rdiv Rmult_1_l. apply Rmult_le_compat_l.
      ** left. apply Rinv_0_lt_compat. apply lt_0_INR. rewrite //=. omega.
      ** rewrite -ldist_assoc. rewrite Ex_mbind_mret.
         apply Ex_bound.
         rewrite (ldist_cost_bind_fold (λ x, spl ← dist_ret _ (partition' (sval x) (a :: l));
                                             mret (lower (sval spl), upper (sval spl)))).
         rewrite ?ldist_left_id.
         assert (Hlt: (x < size (a :: l))%nat) by auto.
         rewrite //= in Hlt.
         eapply (@cspec_mspec _ _ (λ x0 : (seq nat * seq nat),
                                      Rmax (rsize x0.1) (rsize x0.2)
                                      <= Rmax (INR (f (Ordinal (n:= S (size l)) Hle)))
                                              (INR (S (size l) - (f (Ordinal (n := S (size l)) Hle))
                                                    - 1)))).
         tbind (λ y, nth 0%nat (a :: l) x = sval y).
         { apply mspec_mret => //=. }
         intros (pv&Hin') Heq.
         tbind (λ x, lower (sval x) = [ seq n <- (a :: l) | ltn n pv] ∧
                     middle (sval x) = [ seq n <- (a :: l) | n == pv] ∧
                     upper (sval x) = [ seq n <- (a :: l) | ltn pv n]).
         { apply mspec_mret. apply partition_split. }
         remember (a :: l) as l0 eqn:Heql0.
         assert (Hsize: S (size l) = (size l0)) by (rewrite Heql0; auto).
         intros (spl&Hin'') => //=. intros (Hl&Hm&Hu).
         apply mspec_mret => //=.
         rewrite /rsize.
         rewrite !Rmax_INR. apply le_INR.
         rewrite Hl Hu.
         apply Nat.max_le_compat.
         *** rewrite //= in Heq. rewrite -Heq.
             apply /leP. rewrite Hfspec.
             specialize (permEl (perm_sort leq l0)) => Hperm.
             rewrite -(perm_size (quicksort_cost.perm_filter _ _ Hperm)).
             apply quicksort_cost.lower_split_size_sorted_nth; auto.
             **** apply sort_sorted => ??. apply leq_total.
             **** rewrite (perm_size (permEl (perm_sort leq l0))) /=.
                  apply Hfsize. rewrite Heql0. done.
             **** rewrite Heql0 //=.
         *** rewrite //= in Heq. rewrite -Heq.
             apply /leP. rewrite Hfspec.
             assert (Hsize': (size l).+1 = size l0) by rewrite Heql0 //.
             rewrite Hsize'.
             specialize (permEl (perm_sort leq l0)) => Hperm.
             rewrite -(perm_size (permEl (perm_sort leq l0))).
             rewrite -(perm_size (quicksort_cost.perm_filter _ _ Hperm)).
             apply quicksort_cost.upper_split_size_sorted_nth; auto.
             **** apply sort_sorted => ??. apply leq_total.
             **** rewrite (perm_size (permEl (perm_sort leq l0))) /=.
                  apply Hfsize. rewrite Heql0. done.
             **** rewrite Heql0 //=.
      ** rewrite -unif_cost3 //. apply /mapP. eexists; eauto.
    * intros (?&?) Hin; split; auto.
      rewrite /index_enum. rewrite -enumT. rewrite mem_enum => //=.
    * intros b Hin _ Hfalse. contradiction Hfalse.
      destruct b as (m, Hle).
      destruct (Hinv m Hle) as (x'&Hle'&Heq).
      exists (exist _ x' Hle'); repeat split; auto.
      ** apply unif_all2.
      ** apply ord_inj => //=.
    * eapply map_uniq with (f := λ x, {| work := O; span := 0; result := x|}).
      rewrite unif_cost3. eapply uniq_unif2.
    * rewrite /index_enum. rewrite -enumT. apply enum_uniq.
    * intros (?&?) (?&?) _ => //=. inversion 1; subst. apply /val_inj/Hinj => //=.
Qed.

Lemma Ex_max_partition l:
  Ex (rvar_comp (rvar_of_ldist (h l)) (λ x, Rmax (rsize (result x).1) (rsize (result x).2))) <=
   m (rsize l).
Proof.
  eapply Rle_trans; [ apply Ex_max_partition_sum | apply quicksort_cost.sum_le_m ].
Qed.

Definition T := λ x, rvar_comp (rvar_of_ldist (qs x)) (λ x, INR (span x)).
  Definition a x :=
    match Rle_dec x 1 with
      | left _ => 0
      | _ =>
        match Rlt_dec x 2 with
        | left _ => (x - 1)
        | _ => 1
        end
    end.
Definition h' x := rvar_comp (rvar_of_ldist (h x)) result.

Lemma Trec:
    ∀ x r,  pr_eq (T x) r =
            \big[Rplus/0]_(x' : imgT (h' x))
                        (pr_eq (h' x) (sval x') *
                         pr_eq (rvar_comp (rvar_pair (T (fst (sval x'))) (T (snd (sval x'))))
                                         (fun xy => Rmax (fst xy) (snd xy))) (r - a (rsize x))).
Proof.
  intros ls r.
  induction ls as [| a0 ls].
  - rewrite /T. rewrite -pr_mbind_mret.
    rewrite -(big_map _ (λ x, true)
     (λ x',
     (pr_eq (h' [::]) x' *
      pr_eq (rvar_comp
               (rvar_pair
                  (rvar_comp (rvar_of_ldist (qs x'.1)) (λ x, INR (span x)))
                  (rvar_comp (rvar_of_ldist (qs x'.2)) (λ x, INR (span x))))
               (λ xy : prod_eqType R_eqType R_eqType, Rmax xy.1 xy.2)) (r - a (rsize [::]))))).
    rewrite img_rvar_comp map_comp.
    rewrite img_rvar_of_ldist /h.
    rewrite big_cons big_nil Rplus_0_r.
    rewrite /a/rsize/size.
    replace (INR 0) with 0 by auto.
    destruct (Rlt_dec); last nra.
    specialize (pr_rvar_ldist ((x ← qs [::]; mret (INR (span x))))) => -> //=.
    rewrite big_cons big_nil /=.
    rewrite /pr_eq; rewrite 2!pr_eq_alt_comp.
    destruct (Rle_dec); last nra.

    rewrite -(big_map _ (λ x, true) (λ v, if result v == _ then
                                            pr_eq _ v
                                          else
                                            0)).
    rewrite -(big_map _ (λ x, true) (λ v, if Rmax (fst v) (snd v) == r - 0 then
                                            pr_eq _ v
                                          else
                                            0)).
    rewrite (perm_big _ (img_pair_rv _ _ _ _)).
    rewrite allpairs_comp.
    rewrite img_rvar_comp map_comp (map_comp span).
    specialize (img_rvar_of_ldist (qs [::])) => ->.
    specialize (img_rvar_of_ldist (h [::])) => ->.
    rewrite ?big_cons ?big_nil ?Rplus_0_r //= ?Rminus_0_r.
    rewrite Rmax_left; last reflexivity.
    case: ifP; last (intros; field).
    rewrite pr_mret_simpl //=. intros. ring_simplify. rewrite pr_eq_rvar_pair //=.
    rewrite /pr_eq pr_eq_alt_comp.
    rewrite -(big_map _ (λ x, true) (λ v, if INR (span (v)) == 0 then pr_eq _ v else 0)).
    rewrite -(big_map _ (λ x, true) (λ v, if INR (span (v)) == 0 then pr_eq _ v else 0)).
    specialize (img_rvar_of_ldist (qs [::])) => -> //=.
    rewrite ?big_cons ?big_nil //= eq_refl.
    rewrite pr_mret_simpl //=. field.
  - destruct ls as [| b0 ls0].
    { rewrite /T. rewrite -pr_mbind_mret.
    rewrite -(big_map _ (λ x, true)
     (λ x',
     (pr_eq (h' _) x' *
      pr_eq (rvar_comp
               (rvar_pair
                  (rvar_comp (rvar_of_ldist (qs x'.1)) (λ x, INR (span x)))
                  (rvar_comp (rvar_of_ldist (qs x'.2)) (λ x, INR (span x))))
               (λ xy : prod_eqType R_eqType R_eqType, Rmax xy.1 xy.2)) (r - a (rsize _))))).
    rewrite img_rvar_comp map_comp.
    rewrite img_rvar_of_ldist /h.
    rewrite big_cons big_nil Rplus_0_r.
    rewrite /a/rsize/size.
    replace (INR 1) with 1 by auto.
    destruct (Rlt_dec); last nra.
    specialize (pr_rvar_ldist ((x ← qs [:: a0]; mret (INR (span x))))) => -> //=.
    rewrite big_cons big_nil /=.
    rewrite /h'/h.
    rewrite {1}/pr_eq. rewrite 1!pr_eq_alt_comp.
    rewrite -(big_map _ (λ x, true) (λ v, if (result v) == _ then
                                            pr_eq _ v
                                          else
                                            0)).
    specialize (img_rvar_of_ldist (h [::a0])) => ->. rewrite /h.
    rewrite ?big_cons ?big_nil ?Rplus_0_r //= ?Rminus_0_r.
    rewrite pr_mret_simpl //=. ring_simplify.
    rewrite {1}/pr_eq. rewrite 1!pr_eq_alt_comp.
    destruct (Rle_dec); last nra.
    rewrite /Rminus Ropp_0 Rplus_0_r.
    rewrite -(big_map _ (λ x, true) (λ v, if Rmax (fst v) (snd v) == r then
                                            pr_eq _ v
                                          else
                                            0)).
    rewrite (perm_big _ (img_pair_rv _ _ _ _)).
    rewrite allpairs_comp.
    rewrite img_rvar_comp map_comp (map_comp span).
    specialize (img_rvar_of_ldist (qs [::])) => -> //=.
    rewrite ?big_cons ?big_nil //=. replace (INR 0) with 0 by auto.
    rewrite ?Rplus_0_r.
    rewrite Rmax_left; last reflexivity.
    case: ifP; intros; last field.
    rewrite pr_eq_rvar_pair.
    f_equal.
    * rewrite /pr_eq pr_eq_alt_comp.
      rewrite -(big_map _ (λ x, true) (λ v, if INR (span (v)) == 0 then pr_eq _ v else 0)).
      specialize (img_rvar_of_ldist (qs [::])) => -> //=.
      rewrite ?big_cons ?big_nil //= eq_refl.
      rewrite pr_mret_simpl //=. field.
    * rewrite /pr_eq pr_eq_alt_comp.
      rewrite -(big_map _ (λ x, true) (λ v, if INR (span (v)) == 0 then pr_eq _ v else 0)).
      specialize (img_rvar_of_ldist (qs [::])) => -> //=.
      rewrite ?big_cons ?big_nil //= eq_refl.
      rewrite pr_mret_simpl //=. field.
    }
    remember (b0 :: ls0) as ls eqn:Heql0.
   rewrite /T.
    rewrite qs_unfold.
    transitivity
  (pr_eq (rvar_comp (rvar_of_ldist
         ('(ll, lu) ← h (a0 :: ls);
            rpar2 (qs ll) (qs lu)
            )) (λ x, INR (span x)))  r); last first.
    {
      rewrite /h'.
    rewrite -(big_map _ (λ x, true)
     (λ x',
     (pr_eq (h' _) x' *
      pr_eq (rvar_comp
               (rvar_pair
                  (rvar_comp (rvar_of_ldist (qs x'.1)) (λ x, INR (span x)))
                  (rvar_comp (rvar_of_ldist (qs x'.2)) (λ x, INR (span x))))
               (λ xy : prod_eqType R_eqType R_eqType, Rmax xy.1 xy.2)) (r - a (rsize _))))).

    rewrite img_rvar_comp map_comp.
    rewrite img_rvar_of_ldist.
    rewrite (cost_bind_const (3 * (size (a0 :: ls)))%nat (S O)).
      * rewrite -undup_map. rewrite -map_comp.
        eapply eq_bigr. intros (ll&lu) _.
        f_equal.
        specialize (ldist_cost_rpair_span (qs ll) (qs lu)
                                    (λ x, INR (x + 1))) => ->.
        rewrite !rvar_pair_comp !rvar_comp_comp.
          rewrite {1}/pr_eq {1}[a in _ = a]/pr_eq.
          rewrite ?pr_eq_alt_comp /=. eapply eq_bigr => x ?.
          apply if_case_match. rewrite ?plus_INR ?Rmax_INR /rsize//=/a//=.
          rewrite Heql0 //=. specialize (S_INR (size ls0)) => /= => ->.
          destruct (Rlt_dec).
          {specialize (pos_INR (size ls0)). intros. nra. }
          destruct (Rle_dec); first nra.
          apply /eqP; apply /eqP. case: ifP; first by (move /eqP => ->; nra).
          move /eqP. intros. nra.
      * intros d'. rewrite map_comp. move /mapP. intros [? Hin Heq]. rewrite Heq.
        cut (cspec (h (a0 :: ls )) (λ x, work x = 3 * size (a0 :: ls)))%nat; first by auto.
        rewrite /h. rewrite Heql0. rewrite -Heql0.
        cbind (λ x, work x = O).
        {
          rewrite /draw_pivot.
          cbind (λ x, work x = O).
          { rewrite /cspec/coutput. destruct y as [w s a].
            rewrite /work. eapply unif_cost; auto. }
          intros ? => /= ->.
          apply cspec_mret => //=.
        }
        intros pv ->.
        cbind (λ x, work x = 3 * size (a0 :: ls))%nat.
        {
         eapply cspec_dist_ret.
         clear. rewrite /result. destruct pv as [w0 s0 (pv&?)]. rewrite /sval.
         apply (partition_work (a0 :: ls) pv).
        }
        intros ? ->.
        apply cspec_mret => //=. nify. omega.
      (* Should re-work the lemma, because much of this is tedious and the same,
         it's just the final application of work/span of partition calculation *)
      * intros d'. rewrite map_comp. move /mapP. intros [? Hin Heq]. rewrite Heq.
        cut (cspec (h (a0 :: ls )) (λ x, span x = 1))%nat; first by auto.
        rewrite /h. rewrite Heql0. rewrite -Heql0.
        cbind (λ x, span x = O).
        {
          rewrite /draw_pivot.
          cbind (λ x, span x = O).
          { rewrite /cspec/coutput. destruct y as [w s a].
            rewrite /work. eapply unif_cost; auto. }
          intros ? => /= ->.
          apply cspec_mret => //=.
        }
        intros pv ->.
        cbind (λ x, span x = 1)%nat.
        {
         eapply cspec_dist_ret.
         clear. rewrite /result. destruct pv as [w0 s0 (pv&?)]. rewrite /sval.
         apply (partition_span a0 ls pv).
        }
        intros ? ->.
        apply cspec_mret => //=.
    }
    (* TODO TODO: a good deal of this could be automated *)
    rewrite Heql0.
    rewrite /h.
    rewrite -?pr_mbind_mret.
    f_equal.
    apply outcomes_eq_dist.
    rewrite ?ldist_assoc.
    f_equal; eapply ldist_bind_ext.
    intros ?.
    eapply ldist_bind_ext.
    intros ?.
    rewrite ?ldist_assoc.
    eapply ldist_bind_ext.
    intros ?.
    rewrite ?ldist_assoc.
    rewrite ?ldist_left_id ?ldist_right_id.
    rewrite ?ldist_assoc.
    eapply ldist_bind_ext.
    intros ?.
    rewrite ?ldist_assoc.
    eapply ldist_bind_ext.
    intros ?.
    rewrite ?ldist_left_id ?ldist_right_id.
    f_equal => //=. f_equal. nify. omega.
Qed.

Definition k := -/ ln(3/4).

Theorem bound x w:
    rsize x > 1 →
    pr_gt (T x) ((k * ln (rsize x) + 1) + INR w)
       ≤ (rsize x) * (3/4)^w.
Proof.
  specialize (quicksort_rec.recurrence_span2.qs_span_bound _ _ _ _ T h' (λ x, true)).
  rewrite /size/rsize => Hrec. eapply Hrec; clear; try done.
  - intros l ?. rewrite //=.
    rewrite /quicksort_rec.recurrence_span2.size //=.
    cut (∀ n, INR (length (fst (result (rvar_of_ldist (h l) n)))) +
              INR (length (snd (result (rvar_of_ldist (h l) n)))) <=
                   INR (length l)); first by rewrite //=.
    intros n'. apply fun_to_cspec.
    rewrite /h.
    destruct l as [| a l].
    { apply cspec_mret => //=. replace (INR 0) with 0 by auto. nra. }
    destruct l as [| b l0].
    { apply cspec_mret => //=. replace (INR 0) with 0 by auto. replace (INR 1) with 1 by auto. nra. }
    remember (b::l0) as l eqn:Heql0.
    clear b l0 Heql0.
    eapply (cspec_mspec _ (λ x, INR (length (fst x)) + INR (length (snd x)) <= INR (length _))).
    tbind (λ x, sval x \in a :: l).
    { intros (?&?) => //. }
    intros (pv&Hin) _.
    tbind (λ x, lower (sval x) = [ seq n <- (a :: l) | ltn n pv] ∧
                middle (sval x) = [ seq n <- (a :: l) | n == pv] ∧
                upper (sval x) = [ seq n <- (a :: l) | ltn pv n]).
    { remember (a :: l) as l0 eqn:Heql0.
      apply mspec_mret => //=. clear. induction l0 as [|a l]; first by rewrite //=.
      rewrite //=; case (ltngtP a pv) => //= ?;
      destruct (IHl) as (?&?&?); repeat split; auto; f_equal; done.
    }
    remember (a :: l) as l0 eqn:Heql0.
    intros (spl&Hin') => //= ?. apply mspec_mret.
    move /andP in Hin'.
    destruct Hin' as (pf1&pf2); move /implyP in pf2.
    replace (length l0) with (size l0) by auto.
    rewrite -(perm_size pf1) //= ?size_cat -?plusE //.
    assert (Hlt: (lt O (size (middle spl)))) by
            ( apply /ltP; apply pf2 => //=; destruct p; eauto; subst; rewrite //=).
    rewrite -plus_INR. apply le_INR. rewrite //=.
    assert (length (lower spl) = size (lower spl)) as Heq by auto.
    rewrite Heq. clear Heq.
    assert (length (upper spl) = size (upper spl)) as Heq by auto.
    rewrite Heq. clear Heq.
    clear -Hlt. rewrite //=. omega.
  - rewrite /quicksort_rec.recurrence_span2.size //=.
    intros l ? Hgt. rewrite //=.
    cut (∀ n, INR (length (fst (result (rvar_of_ldist (h l) n)))) +
              INR (length (snd (result (rvar_of_ldist (h l) n)))) <=
                   INR (length l) - 1); first by rewrite //=.
    intros n'. apply fun_to_cspec.
    rewrite /h.
    destruct l as [| a l].
    { move : Hgt. rewrite //=. replace (INR 0) with 0 by auto. nra. }
    destruct l as [| b l0].
    { move : Hgt. rewrite //=. replace (INR 1) with 1 by auto. nra. }
    remember (b::l0) as l eqn:Heql0.
    clear b l0 Heql0.
    eapply (cspec_mspec _ (λ x, INR (length (fst x)) + INR (length (snd x)) <= INR (length _) - 1)).
    tbind (λ x, sval x \in a :: l).
    { intros (?&?) => //. }
    intros (pv&Hin) _.
    tbind (λ x, lower (sval x) = [ seq n <- (a :: l) | ltn n pv] ∧
                middle (sval x) = [ seq n <- (a :: l) | n == pv] ∧
                upper (sval x) = [ seq n <- (a :: l) | ltn pv n]).
    { remember (a :: l) as l0 eqn:Heql0.
      apply mspec_mret => //=. clear. induction l0 as [|a l]; first by rewrite //=.
      rewrite //=; case (ltngtP a pv) => //= ?;
      destruct (IHl) as (?&?&?); repeat split; auto; f_equal; done.
    }
    remember (a :: l) as l0 eqn:Heql0.
    intros (spl&Hin') => //= ?. apply mspec_mret.
    move /andP in Hin'.
    destruct Hin' as (pf1&pf2); move /implyP in pf2.
    replace (length l0) with (size l0) by auto.
    rewrite -(perm_size pf1) //= ?size_cat -?plusE //.
    assert (Hlt: (lt O (size (middle spl)))) by
            ( apply /ltP; apply pf2 => //=; destruct p; eauto; subst; rewrite //=).
    rewrite ?plus_INR.
    assert (length (lower spl) = size (lower spl)) as Heq by auto.
    rewrite Heq. clear Heq.
    assert (length (upper spl) = size (upper spl)) as Heq by auto.
    rewrite Heq. clear Heq.
    specialize (pos_INR (size (lower (spl)))).
    specialize (pos_INR (size (upper (spl)))).
    rewrite //=. intros.
    assert (Hge1: 1 <= INR (size (middle spl))).
    { replace 1 with (INR 1) by auto. apply le_INR. omega. }
    rewrite //= in Hge1. nra.
  - rewrite /quicksort_rec.recurrence_span2.size/quicksort_rec.recurrence_span2.rec_solution.d //=.
    intros x n Hle.
    replace 1 with (INR 1) in Hle by auto. apply INR_le in Hle.
    cut (INR (span (rvar_of_ldist (qs x) n)) = 0); first by rewrite //=.
    apply fun_to_cspec.
    destruct x; [| destruct x].
    * rewrite qs_unfold.
      apply cspec_mret => //=.
    * rewrite qs_unfold.
      apply cspec_mret => //=.
    * rewrite //= in Hle. omega.
  - intros. eapply (rec_pr_rec_gt _ rsize _ _ _ _ T h' (λ x, true) (λ xy, Rmax (fst xy) (snd xy)));
              auto; intros; apply Trec.
  - intros x.
    rewrite /quicksort_rec.recurrence_span2.size/quicksort_rec.recurrence_span2.rec_solution.d
            /quicksort_rec.recurrence_span2.rec_solution.m
            /quicksort_rec.recurrence_span2.qs_factor.alpha.
    etransitivity; first eapply Ex_max_partition.
    rewrite /m/rsize/size/length. do 2 destruct Rlt_dec; try nra.
Qed.


Require Import Program.
Require Import Vector.
Require Import alphabet.

Ltac invert_existT H := subst; inversion H; subst;
                        repeat (match goal with
                                | H : existT _ _ _ = existT _ _ _ |- _ => try apply inj_pair2 in H
                                end; subst).

Theorem vec_0_is_nil :
  forall {A} (v : Vec A 0),
    v = nil A.
Proof.
  intros A v. unfold Vec in *.
  refine (match v with
          | nil _ => _
          | cons _ x _ v => _
          end).
  reflexivity.
  apply idProp.
Qed.

Ltac nilify := repeat (match goal with
                       | H : Vec _ 0 |- _ => rewrite (vec_0_is_nil H) in *
                       end; simpl in *; subst; simpl in *).


(* This file is generated by Why3's Coq driver *)
(* Beware! Only edit allowed sections below    *)
Require Import BuiltIn.
Require BuiltIn.
Require int.Int.
Require map.Map.

(* Why3 assumption *)
Definition unit := unit.

(* Why3 assumption *)
Inductive list
  (a:Type) {a_WT:WhyType a} :=
  | Nil : list a
  | Cons : a -> (list a) -> list a.
Axiom list_WhyType : forall (a:Type) {a_WT:WhyType a}, WhyType (list a).
Existing Instance list_WhyType.
Implicit Arguments Nil [[a] [a_WT]].
Implicit Arguments Cons [[a] [a_WT]].

(* Why3 assumption *)
Fixpoint length {a:Type} {a_WT:WhyType a} (l:(list a)) {struct l}: Z :=
  match l with
  | Nil => 0%Z
  | (Cons _ r) => (1%Z + (length r))%Z
  end.

Axiom Length_nonnegative : forall {a:Type} {a_WT:WhyType a}, forall (l:(list
  a)), (0%Z <= (length l))%Z.

Axiom Length_nil : forall {a:Type} {a_WT:WhyType a}, forall (l:(list a)),
  ((length l) = 0%Z) <-> (l = (Nil :(list a))).

Axiom set : forall (a:Type) {a_WT:WhyType a}, Type.
Parameter set_WhyType : forall (a:Type) {a_WT:WhyType a}, WhyType (set a).
Existing Instance set_WhyType.

Parameter mem: forall {a:Type} {a_WT:WhyType a}, a -> (set a) -> Prop.

(* Why3 assumption *)
Definition infix_eqeq {a:Type} {a_WT:WhyType a} (s1:(set a)) (s2:(set
  a)): Prop := forall (x:a), (mem x s1) <-> (mem x s2).

Axiom extensionality : forall {a:Type} {a_WT:WhyType a}, forall (s1:(set a))
  (s2:(set a)), (infix_eqeq s1 s2) -> (s1 = s2).

(* Why3 assumption *)
Definition subset {a:Type} {a_WT:WhyType a} (s1:(set a)) (s2:(set
  a)): Prop := forall (x:a), (mem x s1) -> (mem x s2).

Axiom subset_refl : forall {a:Type} {a_WT:WhyType a}, forall (s:(set a)),
  (subset s s).

Axiom subset_trans : forall {a:Type} {a_WT:WhyType a}, forall (s1:(set a))
  (s2:(set a)) (s3:(set a)), (subset s1 s2) -> ((subset s2 s3) -> (subset s1
  s3)).

Parameter empty: forall {a:Type} {a_WT:WhyType a}, (set a).

(* Why3 assumption *)
Definition is_empty {a:Type} {a_WT:WhyType a} (s:(set a)): Prop :=
  forall (x:a), ~ (mem x s).

Axiom empty_def1 : forall {a:Type} {a_WT:WhyType a}, (is_empty (empty :(set
  a))).

Axiom mem_empty : forall {a:Type} {a_WT:WhyType a}, forall (x:a), ~ (mem x
  (empty :(set a))).

Parameter add: forall {a:Type} {a_WT:WhyType a}, a -> (set a) -> (set a).

Axiom add_def1 : forall {a:Type} {a_WT:WhyType a}, forall (x:a) (y:a),
  forall (s:(set a)), (mem x (add y s)) <-> ((x = y) \/ (mem x s)).

Parameter remove: forall {a:Type} {a_WT:WhyType a}, a -> (set a) -> (set a).

Axiom remove_def1 : forall {a:Type} {a_WT:WhyType a}, forall (x:a) (y:a)
  (s:(set a)), (mem x (remove y s)) <-> ((~ (x = y)) /\ (mem x s)).

Axiom subset_remove : forall {a:Type} {a_WT:WhyType a}, forall (x:a) (s:(set
  a)), (subset (remove x s) s).

Parameter union: forall {a:Type} {a_WT:WhyType a}, (set a) -> (set a) -> (set
  a).

Axiom union_def1 : forall {a:Type} {a_WT:WhyType a}, forall (s1:(set a))
  (s2:(set a)) (x:a), (mem x (union s1 s2)) <-> ((mem x s1) \/ (mem x s2)).

Parameter inter: forall {a:Type} {a_WT:WhyType a}, (set a) -> (set a) -> (set
  a).

Axiom inter_def1 : forall {a:Type} {a_WT:WhyType a}, forall (s1:(set a))
  (s2:(set a)) (x:a), (mem x (inter s1 s2)) <-> ((mem x s1) /\ (mem x s2)).

Parameter diff: forall {a:Type} {a_WT:WhyType a}, (set a) -> (set a) -> (set
  a).

Axiom diff_def1 : forall {a:Type} {a_WT:WhyType a}, forall (s1:(set a))
  (s2:(set a)) (x:a), (mem x (diff s1 s2)) <-> ((mem x s1) /\ ~ (mem x s2)).

Axiom subset_diff : forall {a:Type} {a_WT:WhyType a}, forall (s1:(set a))
  (s2:(set a)), (subset (diff s1 s2) s1).

Parameter choose: forall {a:Type} {a_WT:WhyType a}, (set a) -> a.

Axiom choose_def : forall {a:Type} {a_WT:WhyType a}, forall (s:(set a)),
  (~ (is_empty s)) -> (mem (choose s) s).

Parameter cardinal: forall {a:Type} {a_WT:WhyType a}, (set a) -> Z.

Axiom cardinal_nonneg : forall {a:Type} {a_WT:WhyType a}, forall (s:(set a)),
  (0%Z <= (cardinal s))%Z.

Axiom cardinal_empty : forall {a:Type} {a_WT:WhyType a}, forall (s:(set a)),
  ((cardinal s) = 0%Z) <-> (is_empty s).

Axiom cardinal_add : forall {a:Type} {a_WT:WhyType a}, forall (x:a),
  forall (s:(set a)), (~ (mem x s)) -> ((cardinal (add x
  s)) = (1%Z + (cardinal s))%Z).

Axiom cardinal_remove : forall {a:Type} {a_WT:WhyType a}, forall (x:a),
  forall (s:(set a)), (mem x s) -> ((cardinal s) = (1%Z + (cardinal (remove x
  s)))%Z).

Axiom cardinal_subset : forall {a:Type} {a_WT:WhyType a}, forall (s1:(set a))
  (s2:(set a)), (subset s1 s2) -> ((cardinal s1) <= (cardinal s2))%Z.

Axiom cardinal1 : forall {a:Type} {a_WT:WhyType a}, forall (s:(set a)),
  ((cardinal s) = 1%Z) -> forall (x:a), (mem x s) -> (x = (choose s)).

Axiom vertex : Type.
Parameter vertex_WhyType : WhyType vertex.
Existing Instance vertex_WhyType.

Parameter vertices: (set vertex).

Parameter edges: (set (vertex* vertex)%type).

(* Why3 assumption *)
Definition edge (x:vertex) (y:vertex): Prop := (mem (x, y) edges).

Axiom edges_def : forall (x:vertex) (y:vertex), (mem (x, y) edges) -> ((mem x
  vertices) /\ (mem y vertices)).

Parameter s: vertex.

Axiom s_in_graph : (mem s vertices).

Axiom vertices_cardinal_pos : (0%Z < (cardinal vertices))%Z.

(* Why3 assumption *)
Fixpoint infix_plpl {a:Type} {a_WT:WhyType a} (l1:(list a)) (l2:(list
  a)) {struct l1}: (list a) :=
  match l1 with
  | Nil => l2
  | (Cons x1 r1) => (Cons x1 (infix_plpl r1 l2))
  end.

Axiom Append_assoc : forall {a:Type} {a_WT:WhyType a}, forall (l1:(list a))
  (l2:(list a)) (l3:(list a)), ((infix_plpl l1 (infix_plpl l2
  l3)) = (infix_plpl (infix_plpl l1 l2) l3)).

Axiom Append_l_nil : forall {a:Type} {a_WT:WhyType a}, forall (l:(list a)),
  ((infix_plpl l (Nil :(list a))) = l).

Axiom Append_length : forall {a:Type} {a_WT:WhyType a}, forall (l1:(list a))
  (l2:(list a)), ((length (infix_plpl l1
  l2)) = ((length l1) + (length l2))%Z).

(* Why3 assumption *)
Fixpoint mem1 {a:Type} {a_WT:WhyType a} (x:a) (l:(list
  a)) {struct l}: Prop :=
  match l with
  | Nil => False
  | (Cons y r) => (x = y) \/ (mem1 x r)
  end.

Axiom mem_append : forall {a:Type} {a_WT:WhyType a}, forall (x:a) (l1:(list
  a)) (l2:(list a)), (mem1 x (infix_plpl l1 l2)) <-> ((mem1 x l1) \/ (mem1 x
  l2)).

Axiom mem_decomp : forall {a:Type} {a_WT:WhyType a}, forall (x:a) (l:(list
  a)), (mem1 x l) -> exists l1:(list a), exists l2:(list a),
  (l = (infix_plpl l1 (Cons x l2))).

(* Why3 assumption *)
Inductive path : vertex -> (list vertex) -> vertex -> Prop :=
  | Path_empty : forall (x:vertex), (path x (Nil :(list vertex)) x)
  | Path_cons : forall (x:vertex) (y:vertex) (z:vertex) (l:(list vertex)),
      (edge x y) -> ((path y l z) -> (path x (Cons x l) z)).

Axiom path_right_extension : forall (x:vertex) (y:vertex) (z:vertex) (l:(list
  vertex)), (path x l y) -> ((edge y z) -> (path x (infix_plpl l (Cons y
  (Nil :(list vertex)))) z)).

Axiom path_right_inversion : forall (x:vertex) (z:vertex) (l:(list vertex)),
  (path x l z) -> (((x = z) /\ (l = (Nil :(list vertex)))) \/
  exists y:vertex, exists l':(list vertex), (path x l' y) /\ ((edge y z) /\
  (l = (infix_plpl l' (Cons y (Nil :(list vertex))))))).

Axiom path_trans : forall (x:vertex) (y:vertex) (z:vertex) (l1:(list vertex))
  (l2:(list vertex)), (path x l1 y) -> ((path y l2 z) -> (path x
  (infix_plpl l1 l2) z)).

Axiom empty_path : forall (x:vertex) (y:vertex), (path x (Nil :(list vertex))
  y) -> (x = y).

Axiom path_decomposition : forall (x:vertex) (y:vertex) (z:vertex) (l1:(list
  vertex)) (l2:(list vertex)), (path x (infix_plpl l1 (Cons y l2)) z) ->
  ((path x l1 y) /\ (path y (Cons y l2) z)).

Parameter weight: vertex -> vertex -> Z.

(* Why3 assumption *)
Fixpoint path_weight (l:(list vertex)) (dst:vertex) {struct l}: Z :=
  match l with
  | Nil => 0%Z
  | (Cons x Nil) => (weight x dst)
  | (Cons x ((Cons y _) as r)) => ((weight x y) + (path_weight r dst))%Z
  end.

Axiom path_weight_right_extension : forall (x:vertex) (y:vertex) (l:(list
  vertex)), ((path_weight (infix_plpl l (Cons x (Nil :(list vertex))))
  y) = ((path_weight l x) + (weight x y))%Z).

Axiom path_weight_decomposition : forall (y:vertex) (z:vertex) (l1:(list
  vertex)) (l2:(list vertex)), ((path_weight (infix_plpl l1 (Cons y l2))
  z) = ((path_weight l1 y) + (path_weight (Cons y l2) z))%Z).

Axiom path_in_vertices : forall (v1:vertex) (v2:vertex) (l:(list vertex)),
  (mem v1 vertices) -> ((path v1 l v2) -> (mem v2 vertices)).

(* Why3 assumption *)
Definition pigeon_set (s1:(set vertex)): Prop := forall (l:(list vertex)),
  (forall (e:vertex), (mem1 e l) -> (mem e s1)) ->
  (((cardinal s1) < (length l))%Z -> exists e:vertex, exists l1:(list
  vertex), exists l2:(list vertex), exists l3:(list vertex),
  (l = (infix_plpl l1 (Cons e (infix_plpl l2 (Cons e l3)))))).

Axiom Induction : (forall (s1:(set vertex)), (is_empty s1) -> (pigeon_set
  s1)) -> ((forall (s1:(set vertex)), (pigeon_set s1) -> forall (t:vertex),
  (~ (mem t s1)) -> (pigeon_set (add t s1))) -> forall (s1:(set vertex)),
  (pigeon_set s1)).

Axiom corner : forall (s1:(set vertex)) (l:(list vertex)),
  ((length l) = (cardinal s1)) -> ((forall (e:vertex), (mem1 e l) -> (mem e
  s1)) -> ((exists e:vertex, (exists l1:(list vertex), (exists l2:(list
  vertex), (exists l3:(list vertex), (l = (infix_plpl l1 (Cons e
  (infix_plpl l2 (Cons e l3))))))))) \/ forall (e:vertex), (mem e s1) ->
  (mem1 e l))).

Axiom pigeon_0 : (pigeon_set (empty :(set vertex))).

Axiom pigeon_1 : forall (s1:(set vertex)), (pigeon_set s1) ->
  forall (t:vertex), (pigeon_set (add t s1)).

Axiom pigeon_2 : forall (s1:(set vertex)), (pigeon_set s1).

Axiom pigeonhole : forall (s1:(set vertex)) (l:(list vertex)),
  (forall (e:vertex), (mem1 e l) -> (mem e s1)) ->
  (((cardinal s1) < (length l))%Z -> exists e:vertex, exists l1:(list
  vertex), exists l2:(list vertex), exists l3:(list vertex),
  (l = (infix_plpl l1 (Cons e (infix_plpl l2 (Cons e l3)))))).

Axiom long_path_decomposition_pigeon1 : forall (l:(list vertex)) (v:vertex),
  (path s l v) -> ((~ (l = (Nil :(list vertex)))) -> forall (v1:vertex),
  (mem1 v1 (Cons v l)) -> (mem v1 vertices)).

Axiom long_path_decomposition_pigeon2 : forall (l:(list vertex)) (v:vertex),
  (forall (v1:vertex), (mem1 v1 (Cons v l)) -> (mem v1 vertices)) ->
  (((cardinal vertices) < (length (Cons v l)))%Z -> exists e:vertex,
  exists l1:(list vertex), exists l2:(list vertex), exists l3:(list vertex),
  ((Cons v l) = (infix_plpl l1 (Cons e (infix_plpl l2 (Cons e l3)))))).

Axiom long_path_decomposition_pigeon3 : forall (l:(list vertex)) (v:vertex),
  (exists e:vertex, (exists l1:(list vertex), (exists l2:(list vertex),
  (exists l3:(list vertex), ((Cons v l) = (infix_plpl l1 (Cons e
  (infix_plpl l2 (Cons e l3))))))))) -> ((exists l1:(list vertex),
  (exists l2:(list vertex), (l = (infix_plpl l1 (Cons v l2))))) \/
  exists n:vertex, exists l1:(list vertex), exists l2:(list vertex),
  exists l3:(list vertex), (l = (infix_plpl l1 (Cons n (infix_plpl l2 (Cons n
  l3)))))).

Axiom long_path_decomposition : forall (l:(list vertex)) (v:vertex), (path s
  l v) -> (((cardinal vertices) <= (length l))%Z -> ((exists l1:(list
  vertex), (exists l2:(list vertex), (l = (infix_plpl l1 (Cons v l2))))) \/
  exists n:vertex, exists l1:(list vertex), exists l2:(list vertex),
  exists l3:(list vertex), (l = (infix_plpl l1 (Cons n (infix_plpl l2 (Cons n
  l3))))))).

Axiom simple_path : forall (v:vertex) (l:(list vertex)), (path s l v) ->
  exists l':(list vertex), (path s l' v) /\
  ((length l') < (cardinal vertices))%Z.

(* Why3 assumption *)
Definition negative_cycle (v:vertex): Prop := (mem v vertices) /\
  ((exists l1:(list vertex), (path s l1 v)) /\ exists l2:(list vertex), (path
  v l2 v) /\ ((path_weight l2 v) < 0%Z)%Z).

Axiom key_lemma_1 : forall (v:vertex) (n:Z), (forall (l:(list vertex)), (path
  s l v) -> (((length l) < (cardinal vertices))%Z -> (n <= (path_weight l
  v))%Z)) -> ((exists l:(list vertex), (path s l v) /\ ((path_weight l
  v) < n)%Z) -> exists u:vertex, (negative_cycle u)).

(* Why3 assumption *)
Inductive t :=
  | Finite : Z -> t
  | Infinite : t.
Axiom t_WhyType : WhyType t.
Existing Instance t_WhyType.

(* Why3 assumption *)
Definition add1 (x:t) (y:t): t :=
  match x with
  | Infinite => Infinite
  | (Finite x1) =>
      match y with
      | Infinite => Infinite
      | (Finite y1) => (Finite (x1 + y1)%Z)
      end
  end.

(* Why3 assumption *)
Definition lt (x:t) (y:t): Prop :=
  match x with
  | Infinite => False
  | (Finite x1) =>
      match y with
      | Infinite => True
      | (Finite y1) => (x1 < y1)%Z
      end
  end.

(* Why3 assumption *)
Definition le (x:t) (y:t): Prop := (lt x y) \/ (x = y).

Axiom Refl : forall (x:t), (le x x).

Axiom Trans : forall (x:t) (y:t) (z:t), (le x y) -> ((le y z) -> (le x z)).

Axiom Antisymm : forall (x:t) (y:t), (le x y) -> ((le y x) -> (x = y)).

Axiom Total : forall (x:t) (y:t), (le x y) \/ (le y x).

(* Why3 assumption *)
Inductive ref (a:Type) {a_WT:WhyType a} :=
  | mk_ref : a -> ref a.
Axiom ref_WhyType : forall (a:Type) {a_WT:WhyType a}, WhyType (ref a).
Existing Instance ref_WhyType.
Implicit Arguments mk_ref [[a] [a_WT]].

(* Why3 assumption *)
Definition contents {a:Type} {a_WT:WhyType a} (v:(ref a)): a :=
  match v with
  | (mk_ref x) => x
  end.

(* Why3 assumption *)
Definition t1 (a:Type) {a_WT:WhyType a} := (ref (set a)).

(* Why3 assumption *)
Definition distmap := (map.Map.map vertex t).

(* Why3 assumption *)
Definition inv1 (m:(map.Map.map vertex t)) (pass:Z) (via:(set (vertex*
  vertex)%type)): Prop := forall (v:vertex), (mem v vertices) ->
  match (map.Map.get m
  v) with
  | (Finite n) => (exists l:(list vertex), (path s l v) /\ ((path_weight l
      v) = n)) /\ ((forall (l:(list vertex)), (path s l v) ->
      (((length l) < pass)%Z -> (n <= (path_weight l v))%Z)) /\
      forall (u:vertex) (l:(list vertex)), (path s l u) ->
      (((length l) < pass)%Z -> ((mem (u, v) via) -> (n <= ((path_weight l
      u) + (weight u v))%Z)%Z)))
  | Infinite => (forall (l:(list vertex)), (path s l v) ->
      (pass <= (length l))%Z) /\ forall (u:vertex), (mem (u, v) via) ->
      forall (lu:(list vertex)), (path s lu u) -> (pass <= (length lu))%Z
  end.

(* Why3 assumption *)
Definition inv2 (m:(map.Map.map vertex t)) (via:(set (vertex*
  vertex)%type)): Prop := forall (u:vertex) (v:vertex), (mem (u, v) via) ->
  (le (map.Map.get m v) (add1 (map.Map.get m u) (Finite (weight u v)))).

Axiom key_lemma_2 : forall (m:(map.Map.map vertex t)), (inv1 m
  (cardinal vertices) (empty :(set (vertex* vertex)%type))) -> ((inv2 m
  edges) -> forall (v:vertex), ~ (negative_cycle v)).

Require Import Why3.
Ltac ae := why3 "alt-ergo".

(* Why3 goal *)
Theorem WP_parameter_bellman_ford : let o := ((cardinal vertices) - 1%Z)%Z in
  ((1%Z <= o)%Z -> forall (m:(map.Map.map vertex t)), (inv1 m (o + 1%Z)%Z
  (empty :(set (vertex* vertex)%type))) -> ((inv1 m (cardinal vertices)
  (empty :(set (vertex* vertex)%type))) -> forall (es:(set (vertex*
  vertex)%type)), (es = edges) -> forall (es1:(set (vertex* vertex)%type)),
  ((subset es1 edges) /\ (inv2 m (diff edges es1))) -> forall (o1:bool),
  ((o1 = true) <-> (is_empty es1)) -> ((o1 = true) -> ((inv2 m edges) ->
  forall (v:vertex), (mem v vertices) -> match (map.Map.get m
  v) with
  | (Finite n) => forall (l:(list vertex)), (path s l v) ->
      (n <= (path_weight l v))%Z
  | Infinite => True
  end)))).
(* Why3 intros o h1 m h2 h3 es h4 es1 (h5,h6) o1 h7 h8 h9 v h10. *)
intros o _ m _ hinv1. subst o.
intros _ _ _ _ _ _ _ hinv2.
intros v hv.
destruct (Map.get m v) as [] _eqn; auto.
intros l hl.
assert (case: (z <= path_weight l v \/ path_weight l v < z)%Z) by omega.
destruct case; auto.
destruct (key_lemma_1 v z) as (u, hu).
generalize (hinv1 v hv); clear hinv1 hinv2.
rewrite Heqt0; ae.
exists l; intuition.
ae.
Qed.