Require Import Containers.Sets Containers.Maps.
Require Import Theory.
Require Import Term.

Generalizable All Variables.
Set Implicit Arguments.
Unset Strict Implicit.

Section WithTheory.
  Context `{Th : Theory}.

  Structure t_ := mk_t {
    this :> Map[term, R];
    canon : term -> R
  }.
  Definition t := t_.

  Definition empty : t := mk_t [] make.

  Definition find (m : t) (t : term) : R :=
    match m[t] with
      | Some r => r
      | None => canon m t
    end.
  Global Coercion find : t >-> Funclass.

  Definition mem (m : t) (a : term) : bool := mem a m.
  Definition add (m : t) (a : term) : t :=
    match m[a] with
      | Some _ => m
      | None => mk_t (m[a <- canon m a]) (canon m)
    end.

  Definition merge (m : t) (p P : R) : t :=
    mk_t (map (subst p P) m) (fun t => subst p P (canon m t)).

  Definition merge_touched (m : Map[term,R]) (p P : R) :
    Map[term,R] * terms :=
    fold (key:=term) (fun a rep mt =>
      let '(m, touched) := mt in
        let rep' := subst p P rep in
          if rep == rep' then mt
            else (m[a <- rep'], a::touched))
    m (m, nil).

  Definition merge' (m : t) (p P : R) : t * list term :=
    let '(m', touched) := merge_touched m p P in
      (mk_t m' (fun t => subst p P (canon m t)), touched).

  Definition congruent (m : t) (a b : term) : bool :=
    m a == m b.

  (* The next 3 functions used to be useful but not anymore *)
  Definition range (m : t) : set term :=
    fold (fun k _ acc => {k; acc}) m {}.
  Definition reprs (m : t) : set R :=
    fold (fun _ r acc => {r; acc}) m {}.
  Definition num_classes (m : t) : nat := SetInterface.cardinal (reprs m).
End WithTheory.

Section WithTheorySpecs.
  Context `{Th: Theory}.

  (** The UF map [{this; canon}] is well-formed if it such that
     [this] maps terms [t] to [canon t]. In other terms, while
     [canon] accumulates all the merges in the structure, the
     map [this] memoizes the result of [canon] on the terms
     that have been added. *)
  Class Wf (m : t) := {
    is_wf : forall t, mem m t = true -> m t === canon m t
  }.

  (* About empty *)
  Property empty_mem : forall t, mem empty t = false.
  Proof.
    intros; unfold mem; simpl; apply MapFacts.empty_a.
  Qed.

  Instance Wf_empty : Wf empty.
  Proof.
    constructor; intros.
    rewrite empty_mem in H; discriminate.
  Qed.

  Property empty_find : forall t, empty t = make t.
  Proof.
    intro; reflexivity.
  Qed.

  (* About add *)
  Property add_mem_1 : forall m a, mem (add m a) a = true.
  Proof.
    intros; unfold mem, add; simpl.
    rewrite MapFacts.mem_find_b.
    case_eq (m[a]); intros; simpl.
    rewrite H; reflexivity.
    rewrite MapFacts.add_eq_o; auto.
  Qed.
  Property add_mem_2 : forall m a t, mem m t = true -> mem (add m a) t = true.
  Proof.
    intros; unfold mem, add; simpl.
    rewrite MapFacts.mem_find_b.
    case_eq (m[a]); intros; simpl.
    rewrite <- MapFacts.mem_find_b; exact H.
    rewrite MapFacts.add_neq_o.
    rewrite <- MapFacts.mem_find_b; exact H.
    intro R; rewrite R in H0.
    unfold mem in H; rewrite MapFacts.mem_find_b in H.
    rewrite H0 in H; discriminate.
  Qed.
  Property add_mem_3 : forall m a t, mem (add m a) t = true ->
    a <> t -> mem m t = true.
  Proof.
    intros; unfold mem, add in *; simpl in *.
    rewrite MapFacts.mem_find_b in *.
    case_eq (m[t0]); intros; simpl; auto.
    case_eq (m[a]); intros; simpl; rewrite H2 in H.
    rewrite MapFacts.mem_find_b in H; rewrite H1 in H; discriminate.
    rewrite MapFacts.mem_find_b in H; unfold find in H; simpl in H.
    rewrite MapFacts.add_neq_o, H1 in H; auto; discriminate.
  Qed.
  Corollary add_mem_iff : forall m a t,
    mem (add m a) t = true <-> a === t \/ mem m t = true.
  Proof.
    intros; destruct (eq_dec a t0); split; intro.
    left; assumption.
    rewrite H; apply add_mem_1.
    right; apply add_mem_3 with a; auto.
    destruct H0; try contradiction; apply add_mem_2; auto.
  Qed.

  Instance Wf_add `{Wf m} (a : term) : Wf (add m a).
  Proof.
    constructor; intros.
    destruct (eq_dec a t0).
    rewrite H1 in *; clear H1.
    unfold add, find in *; simpl in *.
    case_eq (m[t0]); intros; rewrite H1 in *.
    assert (r = m t0).
    unfold find; rewrite H1; auto.
    rewrite H2; apply is_wf; auto.
    unfold add, find in *; simpl in *.
    rewrite MapFacts.add_eq_o; auto.
    assert (Ht := add_mem_3 H0 H1); clear H0.
    unfold add, find; simpl.
    case_eq (m[a]); intros; auto.
    unfold mem in Ht; rewrite MapFacts.mem_find_b in Ht.
    case_eq (m[t0]); intros.
    assert (r0 = m t0).
    unfold find; rewrite H2; auto.
    rewrite H3; apply is_wf; auto.
    rewrite <- MapFacts.mem_find_b in Ht; exact Ht.
    rewrite H2 in Ht; discriminate.
    unfold find; simpl.
    rewrite MapFacts.add_neq_o; auto.
    case_eq (m[t0]); intros; auto.
    assert (r = m t0).
    unfold find; rewrite H2; auto.
    rewrite H3; apply is_wf; auto.
  Qed.

  Property add_find_1 : forall m `{Wf m} a, find (add m a) a === canon m a.
  Proof.
    intros; assert (Ha := @is_wf m H a);
      unfold mem, add, find, canon in *; simpl in *.
    rewrite MapFacts.mem_find_b in Ha.
    destruct m[a] as [ra|]_eqn:Hma.
    rewrite Hma; exact (Ha (refl_equal _)).
    destruct m as [m can]; simpl in *.
    rewrite MapFacts.add_eq_o; reflexivity.
  Qed.
  Property add_find_2 :
    forall m a a', a =/= a' -> find (add m a) a' = find m a'.
  Proof.
    intros.
    unfold add, find in *; destruct m as [m can]; simpl in *.
    destruct m[a] as [ra|]_eqn:Hma; simpl.
    reflexivity.
    rewrite MapFacts.add_neq_o; trivial.
  Qed.
  Property add_find : forall m `{Wf m} a a', find (add m a) a' === find m a'.
  Proof.
    intros.
    unfold add, find in *; destruct m as [m can]; simpl in *.
    destruct m[a] as [ra|]_eqn:Hma; simpl.
    reflexivity.
    destruct (eq_dec a a').
    rewrite MapFacts.add_eq_o; trivial.
    rewrite H0 in Hma; rewrite Hma; rewrite H0; reflexivity.
    rewrite MapFacts.add_neq_o; trivial.
  Qed.

  Remark add_conservative :
    forall (m : t) a x y, m x === m y -> (add m a) x === (add m a) y.
  Proof.
    intros; unfold add, find, mem in *; simpl in *.
    destruct m[a] as [ra|]_eqn:Ha; simpl in *.
    assumption.
    destruct (eq_dec a x).
    rewrite MapFacts.add_eq_o by auto.
    destruct (eq_dec a y).
    rewrite MapFacts.add_eq_o; auto.
    rewrite MapFacts.add_neq_o by auto.
    rewrite H0 in *; rewrite Ha in H; assumption.
    rewrite MapFacts.add_neq_o by auto; rewrite H; clear H.
    destruct (eq_dec a y).
    rewrite MapFacts.add_eq_o; auto.
    rewrite H in *; rewrite Ha; reflexivity.
    rewrite MapFacts.add_neq_o; auto.
  Qed.

  (* About merge *)
  Property merge_mem :
    forall m p P t, mem (merge m p P) t = mem m t.
  Proof.
    intros; unfold mem, merge; simpl.
    apply MapFacts.map_b.
  Qed.

  Instance Wf_merge `{ThSpecs : @TheorySpecs Th, Wf m}
    (p P : R) : Wf (merge m p P).
  Proof.
    constructor; intros.
    unfold merge, mem, find in *; simpl in *.
    rewrite MapFacts.map_o.
    rewrite MapFacts.map_b in H0.
    assert (Ht := is_wf H0).
    rewrite MapFacts.mem_find_b in H0.
    unfold find in Ht; simpl in Ht.
    destruct (m[t0]); simpl.
    rewrite Ht; reflexivity.
    reflexivity.
  Qed.

  Property merge_find :
    forall m p P t, (merge m p P) t = subst p P (m t).
  Proof.
    intros; unfold find, merge; simpl.
    rewrite !MapFacts.map_o.
    destruct m[t0]; simpl; reflexivity.
  Qed.

  (* About merge' *)
  Definition merge_touched_spec (m : Map[term, R]) (p P : R)
    (mvu : Map[term, R]) (mt : Map[term, R] * list term) :=
    forall t, MapInterface.mem t (fst mt) = MapInterface.mem t m.
  Property merge_touched_mem :
    forall m p P t, MapInterface.mem t (fst (merge_touched m p P))
      = MapInterface.mem t m.
  Proof.
    intros m p P; apply (@MapFacts.fold_rec_bis _ _ _ _ _ _
      (merge_touched_spec m p P)).
    (* - morphism *)
    intros m1 m2 [mr tr] Heq; unfold merge_touched_spec; simpl; intros.
    exact (H t0).
    (* - empty *)
    intro; reflexivity.
    (* - add *)
    intros a r [mr tr] m' Hm Hk; unfold merge_touched_spec; simpl; intros.
    destruct (eq_dec r (subst p P r)); simpl; auto.
    rewrite MapFacts.add_b.
    destruct (eq_dec a t0); simpl; auto.
    symmetry; rewrite <- MapFacts.mem_in_iff; exists r; rewrite <- H1; auto.
  Qed.
  Corollary merge'_mem :
    forall m p P t, mem (fst (merge' m p P)) t = mem m t.
  Proof.
    intros m p P t0; unfold mem, merge'; destruct m as [m can]; simpl.
    assert (H := merge_touched_mem m p P t0); revert H.
    case_eq (merge_touched m p P); intro; simpl; auto.
  Qed.

  Definition merge_touched_spec_2 (m : Map[term, R]) (p P : R)
    (mvu : Map[term, R]) (mt : Map[term, R] * list term) :=
    forall t, MapInterface.find t (fst mt) ===
      match MapInterface.find t mvu with
        | Some r => Some (subst p P r)
        | None => MapInterface.find t m
      end.
  Property merge_touched_find :
    forall m p P,
    merge_touched_spec_2 m p P m (merge_touched m p P).
(* TODO : Why does this expanded version of the statement take forever to typecheck ?!
      MapInterface.find t (fst (merge_touched m p P)) ===
      match MapInterface.find t m with
        | Some r => Some (subst p P r)
        | None => MapInterface.find t m
      end.
*)
  Proof.
    unfold merge_touched_spec_2.
    intros m p P; apply (@MapFacts.fold_rec_bis _ _ _ _ _ _
      (merge_touched_spec_2 m p P)).
    (* - morphism *)
    intros m1 m2 [mr tr] Heq; unfold merge_touched_spec_2; simpl; intros.
    rewrite <- Heq; apply H.
    (* - empty *)
    intros t0; rewrite MapFacts.empty_o; reflexivity.
    (* - add *)
    intros a r [mr tr] m' Hm Hk; unfold merge_touched_spec_2; simpl; intros.
    assert (H0 := H t0); clear H.
    destruct (eq_dec r (subst p P r)); simpl.
    destruct (eq_dec a t0); simpl; auto.
    rewrite H1 in *; clear H1.
    rewrite MapFacts.add_eq_o; auto.
    rewrite MapFacts.not_find_in_iff in Hk; rewrite Hk in H0.
    rewrite MapFacts.find_mapsto_iff in Hm.
    rewrite H0, Hm; constructor; exact H.
    rewrite MapFacts.add_neq_o; auto.
    destruct (eq_dec a t0); simpl.
    rewrite H1 in *; clear H1.
    rewrite !MapFacts.add_eq_o in *; auto.
    rewrite !MapFacts.add_neq_o; auto.
  Qed.
  Corollary merge'_find :
    forall m p P t, find (fst (merge' m p P)) t === subst p P (find m t).
  Proof.
    intros; unfold find, merge'; simpl.
    assert (H := merge_touched_find m p P t0).
    destruct (merge_touched m p P) as [mr tr]; simpl in *.
    destruct (m[t0]).
    inversion H; subst; auto.
    inversion H; reflexivity.
  Qed.

  Instance Wf_merge' `{ThSpecs : @TheorySpecs Th, Wf m}
    (p P : R) : Wf (fst (merge' m p P)).
  Proof.
    constructor; intros.
    rewrite merge'_find.
    rewrite merge'_mem in H0.
    unfold merge'; simpl in *.
    destruct (merge_touched m p P) as [ ]_eqn; simpl in *.
    apply subst_m; auto; apply is_wf; auto.
  Qed.

  (* About congruent *)
  Inductive congruent_spec (m : t) (a b : term) : bool -> Prop :=
  | congruent_true : m a === m b -> congruent_spec m a b true
  | congruent_false : m a =/= m b -> congruent_spec m a b false.
  Theorem congruent_dec : forall m a b,
    congruent_spec m a b (congruent m a b).
  Proof.
    intros; unfold congruent; destruct (eq_dec (m a) (m b));
      constructor; auto.
  Qed.

  (* About range *)
  Property range_mem : forall m t, mem m t = (t \in range m).
  Proof.
    intros; unfold mem, range in *; destruct m as [m can]; simpl.
    apply (@MapFacts.fold_rec_bis _ _ _ _ _ _
      (fun m' a => MapInterface.mem t0 m' = (t0 \in a)));
    intros; simpl in *.
    rewrite MapFacts.mem_find_b in H0 |- *; rewrite <- H; exact H0.
    reflexivity.
    destruct (eq_dec k t0).
    rewrite MapFacts.add_eq_b; auto.
    symmetry; apply SetInterface.mem_1; apply SetInterface.add_1; auto.
    rewrite MapFacts.add_neq_b; auto.
    rewrite SetFacts.add_neq_b; auto.
  Qed.

  Property range_empty : range empty [=] {}.
  Proof.
    reflexivity.
  Qed.
  Property range_add : forall a m, range (add m a) [=] {a; range m}.
  Proof.
    intros a m u; rewrite SetFacts.add_iff, !SetFacts.mem_iff.
    rewrite <- !range_mem.
    apply add_mem_iff.
  Qed.
  Property range_merge : forall m u v, range (merge m u v) [=] range m.
  Proof.
    intros m u v a.
    rewrite !SetFacts.mem_iff, <- !range_mem, merge_mem.
    reflexivity.
  Qed.
  Property range_merge' : forall m u v, range (fst (merge' m u v)) [=] range m.
  Proof.
    intros m u v a.
    rewrite !SetFacts.mem_iff, <- !range_mem, merge'_mem.
    reflexivity.
  Qed.

  (* About reprs *)
  Property reprs_mem :
    forall (m : t) r,
      (exists t, m[t] === Some r) <-> SetInterface.In r (reprs m).
  Proof.
    intros; unfold find, reprs in *; destruct m as [m can]; simpl.
    apply (@MapFacts.fold_rec_bis _ _ _ _ _ _
      (fun m' a => (exists t, m'[t] === Some r) <-> r \In a));
    intros; simpl in *.
    (* - morphism *)
    rewrite <- H0; split; intros [u Hu]; exists u.
    rewrite H; assumption. rewrite <- H; assumption.
    (* - empty *)
    split; intro H.
    destruct H; rewrite MapFacts.empty_o in H; inversion H.
    contradiction (SetInterface.empty_1 H).
    (* - add *)
    rewrite SetFacts.add_iff, <- H1; split; intro Z; clear H1.
    destruct Z as [u Hu].
    destruct (eq_dec k u); [left | right].
    rewrite MapFacts.add_eq_o in Hu; auto.
    inversion Hu; assumption.
    rewrite MapFacts.add_neq_o in Hu; auto; exists u; auto.
    destruct Z as [Heq | [u  Hu]].
    exists k; rewrite MapFacts.add_eq_o; auto; constructor; auto.
    destruct (eq_dec k u); [exists k | exists u].
    rewrite H1 in *; rewrite MapFacts.not_find_in_iff in H0.
    rewrite H0 in Hu; inversion Hu.
    rewrite MapFacts.add_neq_o; auto.
  Qed.

  Property reprs_empty : reprs empty [=] {}.
  Proof.
    reflexivity.
  Qed.
  Property reprs_add_1 : forall a m, reprs (add m a) [<=] {canon m a; reprs m}.
  Proof.
    intros a m r; rewrite SetFacts.add_iff, <- !reprs_mem; intro.
    destruct H as [u Hu].
    unfold add in Hu; simpl in Hu; destruct m[a].
    right; exists u; auto.
    destruct (eq_dec a u); simpl in Hu.
    rewrite MapFacts.add_eq_o in Hu; auto; inversion_clear Hu; left; auto.
    rewrite MapFacts.add_neq_o in Hu; auto; right; exists u; auto.
  Qed.
  Property reprs_add_2 : forall a m, reprs m [<=] reprs (add m a).
  Proof.
    intros a m r; rewrite <- !reprs_mem; intro.
    destruct H as [u Hu].
    destruct (eq_dec a u); simpl.
    exists u; rewrite H in *.
    unfold add; simpl; destruct m[u] as [ ]_eqn.
    inversion Hu; rewrite Heqo; auto.
    inversion Hu.
    exists u; unfold add; simpl; destruct m[a]; auto.
    simpl; rewrite MapFacts.add_neq_o ; auto.
  Qed.
  Property reprs_merge `{ThSpecs : @TheorySpecs Th} :
    forall m p P r, r \In reprs (merge m p P) <->
    (exists r', r' \In reprs m /\ subst p P r' === r).
  Proof.
    intros m p P r; rewrite <- !reprs_mem; split; intros [u Hu].
    assert (H := merge_find m p P u); unfold find, merge in *; simpl in *.
    rewrite MapFacts.map_o in Hu, H |-.
    destruct m[u] as [ ]_eqn; inversion Hu; subst; simpl in *.
    exists r0; split; auto.
    rewrite <- reprs_mem; exists u; rewrite Heqo; reflexivity.
    destruct Hu as [Hu Heq].
    rewrite <- reprs_mem in Hu; destruct Hu as [t' Ht']; exists t'.
    unfold merge, find in *; simpl.
    rewrite MapFacts.map_o; inversion Ht'; subst; simpl.
    constructor. rewrite H1; auto.
  Qed.
  Property reprs_merge' `{ThSpecs : @TheorySpecs Th} :
    forall m p P r, r \In reprs (fst (merge' m p P)) <->
    (exists r', r' \In reprs m /\ subst p P r' === r).
  Proof.
    intros m p P r; rewrite <- !reprs_mem; split; intros [u Hu].
    assert (Hfind := merge'_find m p P u).
    assert (Hmem := merge'_mem m p P u).
    exists (m u); split.
    rewrite <- reprs_mem; exists u.
    unfold find, mem in *; simpl.
    rewrite !MapFacts.mem_find_b in Hmem.
    destruct m[u]; auto.
    inversion Hu; rewrite <- H in Hmem; discriminate.
    rewrite <- Hfind; unfold find.
    inversion Hu; auto.
    destruct Hu as [Hu Heq].
    rewrite <- reprs_mem in Hu; destruct Hu as [t' Ht']; exists t'.
    assert (Hfind := merge'_find m p P t').
    assert (Hmem := merge'_mem m p P t').
    unfold find, mem in *; simpl in *.
    rewrite !MapFacts.mem_find_b in Hmem.
    inversion Ht'; subst; rewrite <- H in *.
    destruct ((fst (merge' m p P)) [t']).
    constructor; rewrite Hfind, H1; auto.
    discriminate.
  Qed.

  (* Cardinal *)
  Property num_classes_empty : num_classes empty = 0.
  Proof.
    reflexivity.
  Qed.

Require Import Containers.SetEqProperties.
  Property num_classes_add : forall m a, num_classes m <= num_classes (add m a).
  Proof.
    intros; unfold num_classes.
    apply subset_cardinal; apply subset_1; apply reprs_add_2.
  Qed.

  Lemma cardinal_map_le (f : R -> R) `{fm: Proper _ (_eq ==> _eq) f} :
    forall (S S' : set R),
    (forall r, r \In S' <-> (exists r', r' \In S /\ f r' === r)) ->
    SetInterface.cardinal S' <= SetInterface.cardinal S.
  Proof.
    intros S S' Hmerge; revert S' Hmerge; pattern S;
      apply SetProperties.set_induction_bis; intros.
    (* - morphism *)
    rewrite <- H; apply H0; intro r; rewrite Hmerge.
    split; intros [r' Hr']; exists r'; (rewrite H || rewrite <- H); auto.
    (* - empty *)
    rewrite SetProperties.cardinal_1; auto.
    intros r Hr; rewrite Hmerge in Hr; destruct Hr as [r' [abs _]].
    contradiction (SetInterface.empty_1 abs).
    (* - add *)
    rewrite SetProperties.add_cardinal_2 by assumption.
    set (f' := fun y => f y == f x).
    assert (f'm : Proper (_eq ==> @Logic.eq bool) f').
    intros a b Heq; unfold f'.
    destruct (eq_dec (f a) (f x)); rewrite Heq in *;
      destruct (eq_dec (f b) (f x)); intuition.
    destruct (SetFacts.exists_dec s (f := f')).
    destruct Htrue as [u [Hu1 Hu2]]; unfold f' in Hu2.
    destruct (eq_dec (f u) (f x)); try discriminate; clear Hu2.
    constructor; apply H0; intro r; rewrite Hmerge.
    split; intros [r' [Hin Hsubst]].
    rewrite SetFacts.add_iff in Hin; destruct Hin.
    exists u; split; auto; rewrite H1, H2; exact Hsubst.
    exists r'; split; auto.
    exists r'; split; auto; apply SetInterface.add_2; auto.
    set (S'' := SetInterface.remove (f x) S').
    assert (cut : SetInterface.cardinal S'' <= SetInterface.cardinal s).
    apply H0; intro r; unfold S''; rewrite SetFacts.remove_iff, Hmerge.
    split.
    intros [[r' [Hin' Heq']] Hns].
    exists r'; split; auto; apply SetInterface.add_3 with x; auto.
    intro abs; rewrite abs in Hns; contradiction (Hns Heq').
    intros [r' [Hin' Heq']]; split.
    exists r'; split; auto; apply SetInterface.add_2; auto.
    intro abs; apply Hfalse; exists r'; split; auto.
    unfold f'; destruct (eq_dec (f r') (f x)); auto.
    contradiction H1; transitivity r; auto.
    rewrite <- remove_cardinal_1 with S' (f x).
    fold S''; auto with arith.
    apply SetInterface.mem_1; rewrite Hmerge; exists x;
      split; auto; apply SetInterface.add_1; auto.
  Qed.
  Corollary num_classes_merge'  `{ThSpecs : @TheorySpecs Th} :
    forall m p P, num_classes (fst (merge' m p P)) <= num_classes m.
  Proof.
    intros; unfold num_classes.
    apply (@cardinal_map_le (subst p P) _).
    apply reprs_merge'.
  Qed.

  Theorem num_classes_merge'_lt  `{ThSpecs : @TheorySpecs Th} :
    forall m p P r r', r \In reprs m -> r' \In reprs m -> r =/= r' ->
      subst p P r === subst p P r' ->
        num_classes (fst (merge' m p P)) < num_classes m.
  Proof.
    intros; unfold num_classes.
    assert (Hmerge := reprs_merge' m p P).
    set (S := reprs m) in *; clearbody S.
    set (S' := reprs (fst (merge' m p P))) in *; clearbody S'.
    rewrite <- SetProperties.remove_cardinal_1 with (s := S) (x := r) by auto.
    apply le_lt_n_Sm.
    apply (@cardinal_map_le (subst p P) _).
    intro a; rewrite Hmerge; split; intros [a' [Hina Heqa]].
    destruct (eq_dec r a').
    exists r'; split.
    apply SetInterface.remove_2; auto.
    rewrite <- H3, H2 in Heqa; exact Heqa.
    exists a'; split; try apply SetInterface.remove_2; auto.
    exists a'; split; try apply SetInterface.remove_3 with r; auto.
  Qed.

  Property touched_spec :
    forall m p P t,
      List.In t (snd (merge_touched m p P)) <->
      (exists r, MapsTo t r m /\ r =/= subst p P r).
  Proof.
    intros m p P t0.
    apply (@MapFacts.fold_rec_bis _ _ _ _ _ _
      (fun (mvu : Map[term, R]) (mt : Map[term,R] * terms) =>
        List.In t0 (snd mt) <->
        exists r, MapsTo t0 r mvu /\ r =/= subst p P r)).
    (* - morphism *)
    intros; rewrite H0; split; intros [r Hr]; exists r;
      [rewrite <-H| rewrite H]; exact Hr.
    (* - empty *)
    simpl; split; intro. contradiction.
    destruct H as [r [Hr _]].
    rewrite MapFacts.empty_mapsto_iff in Hr; contradiction.
    (* - add *)
    intros; destruct a; simpl in *.
    destruct (eq_dec e (subst p P e)); simpl.
    rewrite H1; split; intros [r [Hr1 Hr2]].
    exists r; split; auto.
    rewrite MapFacts.add_neq_mapsto_iff; auto.
    intro abs; apply H0; exists r; rewrite abs; exact Hr1.
    exists r; split; auto.
    rewrite MapFacts.add_mapsto_iff in Hr1; auto.
    destruct Hr1 as [[? ?]|[? ?]]; subst; auto.
    contradiction (Hr2 H2).
    rewrite H1; clear H1; split; intro.
    destruct H1 as [?|[r [Hr1 Hr2]]]; subst.
    exists e; split; auto; apply add_1; auto.
    exists r; split; auto.
    apply add_2; auto; intro abs; apply H0;
      rewrite abs; exists r; auto.
    destruct H1 as [r [Hr1 Hr2]].
    rewrite MapFacts.add_mapsto_iff in Hr1; destruct Hr1.
    left; exact (proj1 H1).
    right; exists r; tauto.
  Qed.

  Property merge'_touched_spec :
    forall m p P t,
      List.In t (snd (merge' m p P)) <->
      (mem m t = true /\ m t =/= subst p P (m t)).
  Proof.
    intros m p P t0; unfold merge'.
    assert (Htouched := touched_spec m p P t0).
    destruct (merge_touched m p P) as [mr tr]; simpl in *.
    rewrite Htouched; clear Htouched; unfold mem, find; simpl.
    rewrite MapFacts.mem_find_b.
    destruct (m[t0]) as [ ]_eqn; split; intro.
    split; auto; destruct H as [r' [Hr'1 Hr'2]].
    rewrite MapFacts.find_mapsto_iff in Hr'1.
    rewrite Heqo in Hr'1; inversion Hr'1; subst; auto.
    exists r; split; auto.
    apply find_2; auto. tauto.
    destruct H as [r' [Hr'1 _]].
    rewrite MapFacts.find_mapsto_iff, Heqo in Hr'1; discriminate.
    destruct H; discriminate.
  Qed.
End WithTheorySpecs.

Global Opaque t empty find add merge merge_touched
  merge' congruent range reprs num_classes.


(* seplog (c) AIST 2005-2013. R. Affeldt, N. Marti, et al. GNU GPLv3. *)
(* seplog (c) AIST 2014-2018. R. Affeldt et al. GNU GPLv3. *)
Require Import ClassicalChoice.
From mathcomp Require Import ssreflect ssrbool.
Require Import Init_ext.

(** * %\while%#While#: A Low-level Language

   %\label{sec:while}%

   This section corresponds to Appendix A in %\cite{saabasuustalu2007}%#[Saabas&Uustalu2007]#.

   Our formalization of %\cite{saabasuustalu2007}%#[Saabas&Uustalu2007]# can be instantiated
   with any %\while%#While#-like language. In this section, we isolate more precisely what we
   expect from such a language.
*)

(** ** Generic definition of then %\while\%#While# Language and Hoare logic *)

Declare Scope lang_scope.
Declare Scope while_cmd_scope.
Declare Scope while_assert_scope.
Declare Scope while_hoare_scope.

Section Lang.

(** A state is a pair of a store and a mutable memory. *)

Variable store : Type.
Variable heap : Type.
Let state : Type := (store * heap)%type.

(** We are given one-step, non-branching instructions: *)
Variable cmd0 : Type.

(** One-step, non-branching instructions are given an appropriate operational semantics. We use
   an option type to model error-states. *)

Variable exec0 : option state -> cmd0 -> option state -> Prop.
Notation "s '--' c '---->' t" := (exec0 s c t) (at level 74 , no associativity) : lang_scope.
Local Open Scope lang_scope.

(** Structured commands (if-then-else's and while-loops) are parameterized by a type
   for boolean expressions. *)

Variable expr_b : Type.
Variable eval_b : expr_b -> state -> bool.

(** Using above types, we define the commands of %\while\%#While# languages. *)

Inductive cmd : Type :=
| cmd_cmd0 : 	cmd0 -> cmd
| seq : 	cmd -> cmd -> cmd
| ifte : 	expr_b -> cmd -> cmd -> cmd
| while : 	expr_b -> cmd -> cmd.
Coercion cmd_cmd0 : cmd0 >-> cmd.
Notation "c ; d" := (seq c d) (at level 81, right associativity) : lang_scope.

(** We now define the operational semantics of %\while\%#While# languages. Structured commands
   are given the textbook big-step operational semantics. *)

Reserved Notation "s -- c ---> t" (at level 74, no associativity).
Inductive exec : option state -> cmd -> option state -> Prop :=
| exec_none : forall c, None -- c ---> None
| exec_cmd0 : forall s c s', s -- c ----> s' -> s -- c ---> s'
| exec_seq : forall s s' s'' c d, s -- c ---> s' -> s' -- d ---> s'' -> s -- c ; d ---> s''
| exec_ifte_true : forall s s' t c d, eval_b t s -> |_ s _| -- c ---> s' ->
  |_ s _| -- ifte t c d ---> s'
| exec_ifte_false : forall s s' t c d, ~~ eval_b t s -> |_ s _| -- d ---> s' ->
  |_ s _| -- ifte t c d ---> s'
| exec_while_true : forall s s' s'' t c, eval_b t s -> |_ s _| -- c ---> s' ->
  s' -- while t c ---> s'' -> |_ s _| -- while t c ---> s''
| exec_while_false : forall s t c,
  ~~ eval_b t s -> |_ s _| -- while t c ---> |_ s _|
where "s -- c ---> t" := (exec s c t) : lang_scope.

(** We now come to the formalization of textbook Hoare logic. Actually, we allow
   for an extension of Hoare logic with a notion of pointer and mutable memory (or heap for short) known
   as Separation logic. Assertions are shallow-encoded. *)

Let assert := store -> heap -> Prop.

Definition TT : assert := fun _ _ => True.
Definition FF : assert := fun _ _ => False.
Definition And (P Q : assert) : assert := fun s h => P s h /\ Q s h.
Definition Or (P Q : assert) : assert := fun s h => P s h \/ Q s h.
Definition Not (P : assert) : assert := fun s h => ~ P s h.
Definition entails (P Q : assert) : Prop := forall s h, P s h -> Q s h.
Notation "P ===> Q" := (entails P Q) (at level 90, no associativity) : lang_scope.
Definition equiv (P Q : assert) : Prop := forall s h, P s h <-> Q s h.
Notation "P <==> Q" := (equiv P Q) (at level 90, no associativity) : lang_scope.

(** The axioms of Hoare logic are encoded as an inductive type,
    assuming given Hoare triples for one-step, non-branching instructions. *)

Variable hoare0 : assert -> cmd0 -> assert -> Prop.

Reserved Notation "{[ P ]} c {[ Q ]}" (at level 82, no associativity).
Inductive hoare : assert -> cmd -> assert -> Prop :=
| hoare_hoare0 : forall P Q c, hoare0 P c Q -> {[ P ]} c {[ Q ]}
| hoare_seq : forall Q P R c d, {[ P ]} c {[ Q ]} -> {[ Q ]} d {[ R ]} -> {[ P ]} c ; d {[ R ]}
| hoare_conseq : forall P P' Q Q' c, Q' ===> Q -> P ===> P' ->
  {[ P' ]} c {[ Q' ]} -> {[ P ]} c {[ Q ]}
| hoare_while : forall P t c, {[ fun s h => P s h /\ eval_b t (s, h) ]} c {[ P ]} ->
  {[ P ]} while t c {[ fun s h => P s h /\ ~~ eval_b t (s, h) ]}
| hoare_ifte : forall P Q t c d, {[ fun s h => P s h /\ eval_b t (s, h) ]} c {[ Q ]} ->
  {[ fun s h => P s h /\ ~~ eval_b t (s, h) ]} d {[ Q ]} ->
  {[ P ]} ifte t c d {[ Q ]}
where "{[ P ]} c {[ Q ]}" := (hoare P c Q) : lang_scope.

Definition hoare_semantics (P : assert) (c : cmd) (Q : assert) : Prop :=
  forall s h, P s h -> ~ |_ s, h _| -- c ---> None /\
    (forall s' h', |_ s, h _| -- c ---> |_ s', h' _| -> Q s' h').

Definition wp_semantics (c : cmd) (Q : assert) : assert :=
  fun s h => ~ |_ s, h _| -- c ---> None /\
    forall s' h', |_ s, h _| -- c ---> |_ s', h' _| -> Q s' h'.

Reserved Notation "{{{[ P ]}}} c {{{[ Q ]}}}" (at level 82, no associativity).
Inductive hoare_total : assert -> cmd -> assert -> Prop :=
| hoaret_hoare0 : forall P Q c, hoare0 P c Q -> {{{[ P ]}}} c {{{[ Q ]}}}
| hoaret_seq : forall P Q R c d, {{{[ P ]}}} c {{{[ Q ]}}} -> {{{[ Q ]}}} d {{{[ R ]}}} -> {{{[ P ]}}} c ; d {{{[ R ]}}}
| hoaret_conseq : forall P P' Q Q' c, (Q' ===> Q) -> (P ===> P') ->
  {{{[ P' ]}}} c {{{[ Q' ]}}} -> {{{[ P ]}}} c {{{[ Q ]}}}
| hoaret_while : forall P t c
  A (R : A -> A -> Prop) (Rwf : well_founded R) (V : state -> A) a,
  (forall a, {{{[ fun s h => P s h /\ eval_b t (s, h) /\ V (s,h) = a ]}}}
    c {{{[ fun s h => P s h /\ R (V (s,h)) a ]}}}) ->
  {{{[ fun s h => P s h /\ V (s,h) = a ]}}}
    while t c {{{[ fun s h => P s h /\ ~~ eval_b t (s, h) ]}}}
| hoaret_ifte : forall P Q t c d,
  {{{[ fun s1 h => P s1 h /\ eval_b t (s1, h) ]}}} c {{{[ Q ]}}} ->
  {{{[ fun s1 h => P s1 h /\ ~~ eval_b t (s1, h) ]}}} d {{{[ Q ]}}} ->
  {{{[ P ]}}} ifte t c d {{{[ Q ]}}}
where "{{{[ P ]}}} c {{{[ Q ]}}}" := (hoare_total P c Q) : lang_scope.

Definition hoare_semantics_total (P : assert) (c : cmd) (Q : assert) : Prop :=
  forall s h, P s h ->
    exists s' h', |_ s, h _| -- c ---> |_ s', h' _| /\  Q s' h'.

End Lang.

Arguments cmd {cmd0 expr_b}.
Arguments cmd_cmd0 [cmd0 expr_b].
Arguments seq [cmd0 expr_b].
Arguments ifte [cmd0 expr_b].
Arguments while [cmd0 expr_b].

Arguments Not [store heap].

(** ** Generic Properties of the Operational Semantics of %\while%#While# *)

(** We pack the generic syntax and the corresponding operational semantics above as a module: *)

Module Type WHILE_SEMOP.

Parameter store : Type.
Parameter heap : Type.
Definition state : Type := (store * heap)%type.

Parameter cmd0 : Type.
Parameter exec0 : option state -> cmd0 -> option state -> Prop.
Notation "s -- c ----> t" := (exec0 s c t) (at level 74 , no associativity) : while_cmd_scope.
Local Open Scope while_cmd_scope.
Delimit Scope while_cmd_scope with while_cmd.

(* www
Parameter exec0_deter : forall (st : option state) (c : cmd0) (st' : option state),
  st -- c ----> st' ->
  forall st'', st -- c ----> st'' -> st' = st''.
*)

Parameter from_none0 : forall s (c : cmd0), None -- c ----> s -> s = None.
Parameter cmd0_terminate : forall (c : cmd0) s, exists s', |_ s _| -- c ----> s'.

Parameter expr_b : Type.
Parameter neg : expr_b -> expr_b.
Parameter eval_b : expr_b -> state -> bool.
Parameter eval_b_neg : forall t s, eval_b (neg t) s = ~~ eval_b t s.
Definition cmd := @cmd cmd0 expr_b.
Notation "c ; d" := (@seq cmd0 expr_b c d) (at level 81, right associativity) : while_cmd_scope.
Coercion cmd_cmd0_coercion := @cmd_cmd0 cmd0 expr_b.
Definition exec := (@exec store heap cmd0 exec0 expr_b eval_b).
Notation "s -- c ---> t" := (exec s c t) (at level 74, no associativity) : while_cmd_scope.

End WHILE_SEMOP.

(** We can derive some generic properties from the module above: *)

Module While_Semop_Prop (while_semop_m : WHILE_SEMOP).

Import while_semop_m.
Local Open Scope while_cmd_scope.

Lemma from_none : forall c s, None -- c ---> s -> s = None.
Proof.
move Hs0 : None => s0.
move=> c s H; move: H Hs0; elim => //.
- destruct s1 => // c' s'.
  by move/from_none0.
- move=> s1 s' s'' _ _ _ H _ H' H''; subst.
  have {H}H'' : s' = None by apply H.
  subst; by apply H'.
Qed.

(* Inversion lemmas: *)

Lemma exec_cmd0_inv s (c : cmd0) s' :
  |_ s _| -- c ---> s' -> |_ s _| -- c ----> s'.
Proof. move: s'. by inversion 1. Qed.

Lemma exec0_not_None_to_exec_not_None s h (c : cmd0) :
  ~ |_ s, h _| -- cmd_cmd0 c ---> None -> ~ |_ s, h _| -- c ----> None.
Proof. move=> H H'. by apply H, exec_cmd0. Qed.

Lemma exec_seq_inv c d s s' : s -- c ; d ---> s' ->
  exists s'', s -- c ---> s'' /\ s'' -- d ---> s'.
Proof.
inversion 1; subst.
- exists None; by split; apply exec_none.
- by exists s'0.
Qed.

(*
Lemma exec_seq_inv_Some : forall c d s h s' h',
  Some (s, h) -- c ; d ---> Some (s', h') ->
  exists s'', exists h'', Some (s, h) -- c ---> Some (s'', h'') /\
                          Some (s'', h'') -- d ---> Some (s', h').
Proof.
move=> c d s h s' h' H.
inversion H as [ | | s0 s1 s2 c1 c2 Hc1 Hc2 Hs0 Htmp Hs2 | | | | ]; subst.
destruct s1 as [[s1 h1]|].
by exists s1; exists h1.
by move/from_none : Hc2.
Qed.*)

Lemma exec_seq_inv_Some c d s s' :
  Some s -- c ; d ---> Some s' ->
  exists s'', Some s -- c ---> Some s'' /\ Some s'' -- d ---> Some s'.
Proof.
move=> H.
inversion H as [ | | s0 s1 s2 c1 c2 Hc1 Hc2 Hs0 Htmp Hs2 | | | | ]; subst.
destruct s1 as [[s1 h1]|].
by exists (s1, h1).
by move/from_none : Hc2.
Qed.

Lemma exec_while_inv_false b c s h s' h' : ~~ eval_b b (s, h) ->
  |_ s, h _| -- while b c ---> |_ s', h' _| -> s = s' /\ h = h'.
Proof.
move=> H H'; inversion H'; subst.
by rewrite H3 in H.
by inversion H'.
Qed.

Lemma exec_while_inv_true b s h : eval_b b (s, h) ->
  forall c s' h', |_ s, h _| -- while b c ---> |_ s', h' _| ->
  exists s'' h'', |_ s, h _| -- c ---> |_ s'', h'' _| /\
                  |_ s'', h'' _| -- while b c ---> |_ s', h' _|.
Proof.
move=> H c s' h'.
inversion 1; subst.
destruct s'0 as [[s'' h'']|].
by exists s'', h''.
by move/from_none : H7.
by rewrite H in H3.
Qed.

(*Lemma exec_ifte_true_inv : forall t c1 c2 s h s' h', eval_b t s ->
  Some (s, h) -- ifte t c1 c2 ---> Some (s', h') ->
  Some (s, h) -- c1 ---> Some (s', h').
Proof. move=> t c1 c2 s h s' h' Ht; inversion 1. by subst. by rewrite Ht in H6. Qed.*)

Lemma exec_ifte_true_inv t c1 c2 s h s' : eval_b t (s, h) ->
  |_ s, h _| -- ifte t c1 c2 ---> s' -> |_ s, h _| -- c1 ---> s'.
Proof.
move=> Ht; inversion 1. by subst.
by rewrite Ht in H5.
Qed.

(*Lemma exec_ifte_false_inv : forall t c1 c2 s h s' h', ~~ eval_b t s ->
  Some (s, h) -- ifte t c1 c2 ---> Some (s', h') ->
  Some (s, h) -- c2 ---> Some (s', h').
Proof. move=> t c1 c2 s h s' h' Ht; inversion 1. by rewrite H6 in Ht. by subst. Qed.*)

Lemma exec_ifte_false_inv t c1 c2 s h s' : ~~ eval_b t (s, h) ->
  |_ s, h _| -- ifte t c1 c2 ---> s' -> |_ s, h _| -- c2 ---> s'.
Proof.
move=> Ht; inversion 1.
by rewrite H5 in Ht. by subst.
Qed.

Lemma exec_seq_assoc s s' c0 c1 c2 :
  s -- (c0 ; c1) ; c2 ---> s' -> s -- c0 ; c1 ; c2 ---> s'.
Proof.
case/exec_seq_inv => s'' [].
case/exec_seq_inv => s''' [H1 H2] H3.
apply exec_seq with s''' => //.
by apply exec_seq with s''.
Qed.

Lemma exec_seq_assoc' s s' c0 c1 c2 :
  s -- c0 ; c1 ; c2 ---> s' -> s -- (c0 ; c1) ; c2 ---> s'.
Proof.
case/exec_seq_inv => s'' [] H1.
case/exec_seq_inv => s''' [] H2 H3.
apply exec_seq with s''' => //.
by apply exec_seq with s''.
Qed.

Lemma while_seq s h t : eval_b t (s, h) -> forall s' c,
  |_ s, h _| -- while t c ---> s' -> |_ s, h _| -- c ; while t c ---> s'.
Proof.
move=> Ht sigma' c.
inversion 1 as [ | | | | | | ]; subst.
- by apply exec_seq with s'.
- by rewrite Ht in H0.
Qed.

Lemma while_seq' s h t : eval_b t (s, h) -> forall s' c,
  |_ s, h _| -- c ; while t c ---> s' -> |_ s, h _| -- while t c ---> s'.
Proof.
move=> Hneq s' c; inversion 1; subst.
by apply exec_while_true with s'0.
Qed.

(* www
Lemma exec_deter : forall ST c ST', ST -- c ---> ST' ->
  forall ST'', ST -- c ---> ST'' -> ST' = ST''.
Proof.
move=> ST c ST'; induction 1 => st'' H'.
- symmetry; by apply from_none with c.
- inversion H'; subst.
  apply from_none with c => //.
  apply exec_cmd0 => //.
  eapply exec0_deter; eauto.
- (* seq *) inversion H'; subst.
  + apply from_none in H; subst s'.
    apply from_none in H0 => //.
  + have X : s' = s'0 by apply IHexec1 => //.
    subst.
    by apply IHexec2.
- (* ifte true *) inversion_clear H' => //.
  by apply IHexec.
- (* ifte false *)
  inversion_clear H'; by apply IHexec.
- (* while true *) inversion_clear H' => //.
  apply IHexec2.
  have [->//] : s' = s'0.
    by apply IHexec1.
- (* while false *) by inversion_clear H'.
Qed.
*)

Lemma exec_seq1_not_None s h c1 c2 :
  ~ |_ s, h _| -- c1 ; c2 ---> None -> ~ |_ s, h _| -- c1 ---> None.
Proof.
move=> H; contradict H; apply exec_seq with None=> //; apply exec_none.
Qed.

Lemma exec_seq2_not_None s h s' h' c1 c2 :
  ~ |_ s, h _| -- c1 ; c2 ---> None -> |_ s, h _| -- c1 ---> |_ s', h' _| ->
  ~ |_ s', h' _| -- c2 ---> None.
Proof.
move=> H H'. contradict H. by apply exec_seq with (Some (s', h')).
Qed.

Lemma exec_ifte1_not_None s h c1 c2 t :
  ~ |_ s, h _| -- ifte t c1 c2 ---> None -> eval_b t (s, h) ->
  ~ |_ s, h _| -- c1 ---> None.
Proof. move=> H ?. contradict H. by apply exec_ifte_true. Qed.

Lemma exec_ifte2_not_None s h c1 c2 t :
  ~ |_ s, h _| -- ifte t c1 c2 ---> None -> ~~ eval_b t (s, h) ->
  ~ |_ s, h _| -- c2 ---> None.
Proof. move=> H ?. contradict H. by apply exec_ifte_false. Qed.

Lemma exec_while1_not_None s h t c :
  ~ |_ s, h _| -- while t c ---> None -> eval_b t (s, h) ->
  ~ |_ s, h _| -- c ---> None.
Proof.
move=> H ?. contradict H. apply exec_while_true with None=> //. by apply exec_none.
Qed.

Lemma exec_while2_not_None s h c t s0 h0 :
  ~ |_ s, h _| -- while t c ---> None -> eval_b t (s, h) ->
  |_ s, h _| -- c ---> |_ s0, h0 _| -> ~ |_ s0, h0 _| -- while t c ---> None.
Proof.
move=> H ? ?. contradict H. by apply exec_while_true with (Some (s0, h0)).
Qed.

Lemma not_exec_seq_inv_Some c d s h : ~ |_ s, h _| -- c ; d ---> None ->
  ~ |_ s, h _| -- c  ---> None /\
  forall s', |_ s, h _| -- c ---> Some s' -> ~ (Some s' -- d ---> None).
Proof.
move=> H; split.
- contradict H; apply exec_seq with None => //; by apply exec_none.
- move=> s' Hc H'; apply H; by apply exec_seq with (Some s').
Qed.

Lemma not_exec_ifte_inv_Some b c d s h :
  ~ |_ s, h _| -- ifte b c d ---> None ->
  (eval_b b (s, h) -> ~ |_ s, h _| -- c  ---> None) /\
  (~~ eval_b b (s, h) -> ~ |_ s, h _| -- d  ---> None).
Proof.
move=> H.
case/boolP : (eval_b b (s, h)) => Hb.
- split=> [_ H'|Ht] //.
  apply H; by constructor.
- split=> X H'.
  + by move/negP : Hb.
  + apply H; by apply exec_ifte_false.
Qed.

(* Lemma while_preserves : forall t c (P : store -> Prop) s h s' h', P s ->
  Some (s, h) -- while t c ---> Some (s', h') ->
  (forall s h s' h', P s -> Some (s, h) -- c ---> Some (s', h') -> P s') ->
  P s'.
Proof.
move=> t c P s h s' h' HP.
move HS : (Some (s, h)) => S.
move HS' : (Some (s', h')) => S'.
move HC : (while t c) => C Hexec.
move: Hexec s h HS s' h' HS' t c HC HP; elim => //.
- move=> [s h] s' s'' t c H H0 _ H2 H3 s0 h0 HS s'0 h'0 HS' t0 c0 HC HP H4.
  case: HS => ? ?; subst s0 h0.
  case: HC => ? ?; subst t0 c0.
  destruct s'' as [[s0 h0]|]; last by done.
  case: HS' => ? ?; subst s'0 h'0.
  destruct s' as [[s1 h1]|].
  + apply (H3 _ _ (refl_equal _) _ _ (refl_equal _) _ _ (refl_equal _)) => //.
    by apply (H4 _ _ _ _ HP H0).
  + by move/from_none : H2.
- move=> [s h] t c H s0 h0 HS s' h' HS' t0 c0 HC HP H0.
  case: HS => ? ?; subst s0 h0.
  case: HS' => ? ?; by subst s' h'.
Qed. *)

Lemma while_preserves t c (P : store -> Prop) s h s' h' : P s ->
  |_ s, h _| -- while t c ---> |_ s', h' _| ->
  (forall s h s' h', P s -> eval_b t (s, h) -> |_ s, h _| -- c ---> |_ s', h' _| -> P s') ->
  P s'.
Proof.
move=> HP.
move HS : (Some (s, h)) => S.
move HS' : (Some (s', h')) => S'.
move HC : (while t c) => C Hexec.
move: Hexec s h HS s' h' HS' t c HC HP; elim => //.
- move=> [s h] s' s'' t c H H0 _ H2 H3 s0 h0 HS s'0 h'0 HS' t0 c0 HC HP H4.
  case: HS => ? ?; subst s0 h0.
  case: HC => ? ?; subst t0 c0.
  destruct s'' as [[s0 h0]|]; last by [].
  case: HS' => ? ?; subst s'0 h'0.
  destruct s' as [[s1 h1]|].
  + apply (H3 _ _ (refl_equal _) _ _ (refl_equal _) _ _ (refl_equal _)) => //.
    by apply (H4 _ _ _ _ HP H H0).
  + by move/from_none : H2.
- move=> [s h] t c H s0 h0 HS s' h' HS' t0 c0 HC HP H0.
  case: HS => ? ?; subst s0 h0.
  case: HS' => ? ?; by subst s' h'.
Qed.

Lemma while_condition_inv s h s' h' b c :
  |_ s, h _| -- while b c ---> |_ s', h' _| -> ~~ eval_b b (s', h').
Proof.
move HS : (Some (s, h)) => S.
move HS' : (Some (s', h')) => S'.
move HC : (while b c) => C Hexec.
move: Hexec s h HS s' h' HS' b c HC; elim => //.
- move=> [s h] s' s'' t c t_s exec_c _ exec_while_t_c IH s0 h0.
  case=> ? ?; subst s0 h0.
  move=> s'0 h'0 Hs'' t0 c0.
  case=> ? ?; subst t0 c0.
  destruct s' as [[s' h']|].
  by eapply IH; eauto.
  move/from_none : exec_while_t_c => ?; by subst s''.
- move=> s t c t_s s0 h0 Hs s' h' Hs'h' t0 c0.
  case=> ? ?; subst t0 c0.
  rewrite -Hs in Hs'h'.
  case: Hs'h' => ? ?; subst s0 h0.
  by case: Hs => ->.
Qed.

End While_Semop_Prop.

Module Type WHILE_SEMOP_DETER.

Include WHILE_SEMOP.

Local Open Scope while_cmd_scope.

Parameter exec0_deter : forall (st : option state) (c : cmd0) (st' : option state),
  st -- c ----> st' -> forall st'', st -- c ----> st'' -> st' = st''.

End WHILE_SEMOP_DETER.

Module While_Semop_Deter_Prop (while_semop_deter_m : WHILE_SEMOP_DETER).

Import while_semop_deter_m.

Module Import while_semop_prop_m := While_Semop_Prop while_semop_deter_m.

Local Open Scope while_cmd_scope.

Lemma exec_deter ST c ST' : ST -- c ---> ST' ->
  forall ST'', ST -- c ---> ST'' -> ST' = ST''.
Proof.
induction 1 => st'' H'.
- symmetry; by apply from_none with c.
- inversion H'; subst.
  apply from_none with c => //.
  by apply exec_cmd0.
  by eapply exec0_deter; eauto.
- (* seq *) inversion H'; subst.
  + apply from_none in H; subst s'.
    by move/from_none : H0.
  + have : s' = s'0 by apply IHexec1.
    move=> ?; subst; by apply IHexec2.
- (* ifte true *) inversion_clear H'. by apply IHexec. by rewrite H in H1.
- (* ifte false *) inversion_clear H'. by rewrite H1 in H. by apply IHexec.
- (* while true *) inversion_clear H'.
  + apply IHexec2.
    suff : s' = s'0 by move=> ->.
    by apply IHexec1.
  + by rewrite H in H2.
- (* while false *) inversion_clear H' => //; by rewrite H0 in H.
Qed.

End While_Semop_Deter_Prop.

(** ** Generic Properties of the Hoare Logic of %\while%#While# *)

(** We then pack the generic Hoare logic above as a module: *)

Module Type WHILE_HOARE.

Include WHILE_SEMOP.

Local Open Scope while_cmd_scope.

Definition assert := store -> heap -> Prop.
Notation "'FF'" := (@FF store heap) (at level 80, no associativity) : while_assert_scope.
Notation "'TT'" := (@TT store heap) (at level 80, no associativity) : while_assert_scope.
Notation "P '//\\' Q" := (@And store heap P Q) (at level 80, right associativity) : while_assert_scope.
Notation "P ===> Q" := (@entails store heap P Q) (at level 90, no associativity) : while_assert_scope.
Notation "P <==> Q" := (@equiv store heap P Q) (at level 90, no associativity) : while_assert_scope.

Parameter hoare0 : assert -> cmd0 -> assert -> Prop.

Notation "'hoare_semantics'" := (@hoare_semantics store heap _ exec0 _ eval_b) : while_hoare_scope.

Local Open Scope while_hoare_scope.

Parameter soundness0 : forall P Q c, hoare0 P c Q -> hoare_semantics P c Q.

Definition hoare := @hoare store heap cmd0 _ eval_b hoare0.

Notation "{{ P }} c {{ Q }}" := (hoare P c Q) (at level 82, no associativity) : while_hoare_scope.

Notation "'wp_semantics'" := (@wp_semantics store heap _ exec0 _ eval_b) : while_hoare_scope.

Parameter wp_semantics_sound0 : forall (c : cmd0) Q, {{ wp_semantics c Q }} c {{ Q }}.

(** The definition of Hoare logic for %\sgoto\%#SGoto# %(Sect.~\ref{sec:sgoto_hoare})%
    will require a function to compute the weakest precondition of one-step, non-branching
    instructions: *)

Parameter wp0 : cmd0 -> assert -> assert.
Parameter wp0_no_err : forall s h c P,  wp0 c P s h -> ~ (Some (s,h) -- c ----> None).

End WHILE_HOARE.

(** Finally, the Hoare logic must be shown to be sound and (relatively) complete,
    as capture by this last module: *)

Module While_Hoare_Prop (while_hoare_m : WHILE_HOARE).

Import while_hoare_m.

Module Import while_semop_prop_m := While_Semop_Prop while_hoare_m.

Local Open Scope while_cmd_scope.
Local Open Scope while_assert_scope.
Local Open Scope while_hoare_scope.

Lemma entails_id P : P ===> P. Proof. by rewrite /entails. Qed.

Lemma entails_trans P Q R : P ===> Q -> Q ===> R -> P ===> R.
Proof. move=> H1 H2 s h HP. by apply H2, H1. Qed.

Lemma ex_falso Q : FF ===> Q. Proof. by rewrite /entails. Qed.

Lemma ex_falso' P : P ===> TT. Proof. by rewrite /entails. Qed.

Lemma FF_is_not_TT : FF <==> Not (TT). Proof. move=> s h; split=> //; by apply. Qed.

Lemma entail_assoc P Q R : (P //\\ Q) //\\ R ===> P //\\ Q //\\ R.
Proof. move=> s h [] [] H1 H2 H3. by intuition. Qed.

Lemma entail_assoc2 P Q R : P //\\ Q //\\ R ===> (P //\\ Q) //\\ R.
Proof. move=> s h [] H1 [] H2 H3. by intuition. Qed.

(* TODO:
Lemma AndAE P Q R : (Q //\\ P //\\ R) = ((Q //\\ P) //\\ R).
*)

Lemma hoare_stren P' P Q c :
  P ===> P' -> {{ P' }} c {{ Q }} -> {{ P }} c {{ Q }}.
Proof. move=> H H'; by apply hoare_conseq with P' Q. Qed.

Lemma hoare_stren_seq (P P' Q Q' : assert) c c' :
  {{ P' }} c {{ Q' }} -> P ===> P' -> {{ Q' }} c' {{ Q }} -> {{ P }} c; c' {{ Q }}.
Proof.
move=> Hc HP Hc'; apply (hoare_seq _ _ _ _ _ _ Q') => //; by apply (hoare_stren P').
Qed.

Lemma hoare_weak (Q' P Q : assert) c : Q' ===> Q -> {{ P }} c {{ Q' }} -> {{ P }} c {{ Q }}.
Proof. move=> H H'. by apply hoare_conseq with P Q'. Qed.

Lemma hoare_con_assoc_pre P Q R c U :
  {{ P //\\ Q //\\ R }} c {{ U }} -> {{ (P //\\ Q) //\\ R }} c {{ U }}.
Proof. move=> H. apply (hoare_stren (P //\\ Q //\\ R)) => //; by apply entail_assoc. Qed.

Lemma hoare_con_assoc_post P Q R c U :
  {{ U }} c {{ P //\\ Q //\\ R }} -> {{ U }} c {{ (P //\\ Q) //\\ R }}.
Proof. move=> H; apply (hoare_weak (P //\\ Q //\\ R)) => //; by apply entail_assoc2. Qed.

Lemma hoare_seq_inv P Q c d : {{ P }} c ; d {{ Q }} ->
  exists R, {{ P }} c {{ R }} /\ {{ R }} d {{ Q }}.
Proof.
move H : (c;d) => Hcd.
move=> H'; move: H' c d H.
elim=> //; clear P Q Hcd.
- move=> Q P R c d Hc H1 Hd H2 c0 d0.
  case=> X Y; subst; by exists Q.
- move=> P P' Q Q' c HQ HP Hc IH c0 d.
  case/IH => R [H1 H2].
  exists R; split; by [eapply hoare_stren; eauto | eapply hoare_weak; eauto].
Qed.

Lemma hoare_seq_inv_special : forall (A : Type) (P Q : A -> assert) c d,
  (forall x, {{ P x }} c ; d {{ Q x }}) ->
  exists R : A -> assert,
    (forall x, {{ P x }} c {{ R x }}) /\ (forall x, {{ R x }} d {{ Q x }}).
Proof.
move=> A P Q c d H.
have Y : forall x : A, exists R, {{ P x }} c{{ R }} /\ {{ R }} d {{ Q x }}.
  move=> ?; by eapply hoare_seq_inv; eauto.
case/choice : Y => f Y.
exists f; split=> a; by [apply (proj1 (Y a)) | apply (proj2 (Y a))].
Qed.

Lemma hoare_seq_inv_special' : forall (A : Type) (P Q : A -> assert) c d,
  (forall x, exists y, {{ P x }} c ; d {{ Q y }}) ->
  exists R : A -> assert,
    (forall x, exists y, {{ P x }} c {{ R y }}) /\ (forall x, exists y, {{ R x }} d {{ Q y }}).
Proof.
move=> A P Q c d H.
have Y : forall x : A, exists y, exists R, {{ P x }} c{{ R }} /\ {{ R }} d {{ Q y }}.
  - move => x; move: {H}(H x) => [] y Hy; exists y.
    by eapply hoare_seq_inv; eauto.
case/choice : Y => f Y.
case/choice : Y => f2 Y.
exists f2; split=> a.
exists a.
apply (proj1 (Y a)).
exists (f a).
apply (proj2 (Y a)).
Qed.

Lemma hoare_seq_assoc P c0 c1 c2 Q :
  {{ P }} c0 ; c1 ; c2 {{ Q }}  ->  {{ P }} (c0 ; c1) ; c2 {{ Q }}.
Proof.
case/hoare_seq_inv => s'' [] Hc0.
case/hoare_seq_inv => s''' [] Hc1 Hc2.
apply (hoare_seq _ _ _ _ _ _ s''') => //; by apply (hoare_seq _ _ _ _ _ _ s'').
Qed.

Lemma hoare_seq_assoc' P c0 c1 c2 Q :
  {{ P }} (c0 ; c1) ; c2 {{ Q }} ->  {{ P }} c0 ; c1 ; c2 {{ Q }}.
Proof.
case/hoare_seq_inv => s'' [].
case/hoare_seq_inv => s''' [] Hc0 Hc1 Hc2.
apply (hoare_seq _ _ _ _ _ _ s''') => //; by apply (hoare_seq _ _ _ _ _ _ s'').
Qed.

Lemma hoare_ifte_inv P Q b c d : {{ P }} ifte b c d {{ Q }} ->
  {{ fun s h => P s h /\ eval_b b (s, h) }} c {{ Q }} /\
  {{ fun s h => P s h /\ ~~ eval_b b (s, h) }} d {{ Q }}.
Proof.
move H : (ifte b c d) => Hbcd.
move=> H'; move: H' b c d H.
elim=> //; clear P Q Hbcd.
- move=> P P' Q Q' c0 HQ HP Hc IH b c d Hifte.
  case: {IH Hifte}(IH _ _ _ Hifte) => H1 H2; split.
  + eapply hoare_weak; eauto.
    eapply hoare_stren; eauto.
    move=> s h /= [H3 H4]; split => //.
    by apply HP.
  + eapply hoare_weak; eauto.
    eapply hoare_stren; eauto.
    move=> s h /= [H3 H4]; split => //.
    by apply HP.
- move=> P Q b c d Hc IHc Hd IHd b' c' d'.
  case=> X Y Z; by subst.
Qed.

Lemma hoare_while_invariant P t c Q Inv : P ===> Inv ->
  (fun s h => Inv s h /\ ~~ eval_b t (s, h)) ===> Q ->
  {{ fun s h => Inv s h /\ eval_b t (s, h) }} c {{ Inv }} ->
  {{ P }} while t c {{ Q }}.
Proof.
move=> HP HQ H.
apply (hoare_stren Inv) => //.
apply (hoare_weak (fun s h => Inv s h /\ ~~ eval_b t (s, h))) => //.
by apply hoare_while.
Qed.

Lemma hoare_while_invariant_seq b c I P Q c1 :
  P ===> I ->
  {{ fun s h => I s h /\ eval_b b (s, h) }} c {{ I }} ->
  {{ fun s h => I s h /\ ~~ eval_b b (s, h) }} c1 {{ Q }} ->
  {{ P }} while b c; c1 {{ Q }}.
Proof.
intros.
apply (hoare_seq _ _ _ _ _ _ (fun s => fun h => I s h /\ ~~ eval_b b (s, h))) => //.
by eapply hoare_while_invariant; eauto.
Qed.

Lemma hoare_while_inv' P Q b c : {{ P }} while b c {{ Q }} ->
  exists R, (P ===> R) /\
    {{ fun s h => R s h /\ eval_b b (s, h) }} c {{ R }} /\
    ((fun s h => R s h /\ ~~ eval_b b (s, h)) ===> Q).
Proof.
move Hwhile : (while b c) => c'.
move=> H.
move: H b c Hwhile.
elim => //; clear P Q c'.
- move=> P P' Q Q' c' HQ HP Hc IHc b c Hwhile.
  move: {IHc Hwhile}(IHc _ _ Hwhile) => [R [X1 [X2 X3] ] ].
  exists R; split.
  by apply entails_trans with P'.
  split => //.
  by eapply entails_trans; eauto.
- move=> P b c Hc IH b' c'.
  case=> X Y; subst.
  exists P; split; first by [].
  by split.
Qed.

Lemma hoare_while_inv_special : forall (A : Type) (P Q : A -> assert) b c,
  (forall x, {{ P x }} while b c {{ Q x }}) ->
  exists R : A -> assert,
    (forall x, {{ fun s h => R x s h /\ eval_b b (s, h) }} c {{ R x }}) /\
    (forall x, (P x ===> R x)) /\
    (forall x, ((fun s h =>  R x s h /\ ~~ eval_b b (s, h)) ===> Q x)).
Proof.
move=> A P Q b c H.
have Y : forall x : A, exists R : A -> assert,
    {{ fun s h => R x s h /\ eval_b b (s, h) }} c {{ R x }} /\
    (P x ===> R x) /\
    ((fun s h =>  R x s h /\ ~~ eval_b b (s, h)) ===> Q x).
  move=> a.
  move: (H a) => Ha.
  case: (hoare_while_inv' _ _ _ _ Ha) => R [X1 [X2 X3]].
  by exists (fun x : A => R).
case/choice : Y=> f Y.
exists (fun x => f x x); split.
- move=> a; by apply (proj1 (Y a)).
- split => a; by [apply (proj1 (proj2 (Y a))) | apply (proj2 (proj2 (Y a)))].
Qed.
(*
Lemma hoare_while_inv_special' : forall (A : Type) (P Q : A -> assert) b c,
  (forall x, exists y, {{ P x }} while b c {{ Q y }}) ->
  exists R : A -> assert,
    (forall x: A, exists y, {{ fun s h => R x s h /\ eval_b b (s, h) }} c {{ R y }}) /\
    (forall x, exists y, (P x ===> R y)) /\
    (forall x:A, exists y, ((fun s h => R y s h /\ ~~ eval_b b (s, h)) ===> Q x)).
move=> A P Q b c H.
have Y : forall x : A, exists y, exists R : A -> assert,
    {{ fun s h => R x s h /\ eval_b b (s, h) }} c {{ R y }} /\
    (P x ===> R y) /\
    ((fun s h => R y s h /\ ~~ eval_b b (s, h)) ===> Q y)
.
  move=> a.
  move: (H a) => [] y Ha.
  case: (hoare_while_inv' _ _ _ _ Ha) => R [X1 [X2 X3]].
  exists y.
  by exists (fun x : A => R).

case/choice : Y => f Y.
case/choice : Y => f2 Y.

exists (fun x => f2 x (f x)); split.
- move => a; exists a ; by apply (proj1 (Y a)).
- split => a.
- exists a; by apply (proj1 (proj2 (Y a))).
- exists (f a); by apply (proj2 (proj2 (Y a))).

- split => a; by [apply (proj1 (proj2 (Y a))) | apply (proj2 (proj2 (Y a)))].
Qed.
*)
Lemma hoare_frame_rule_and'' : (forall P Q c, hoare0 P c Q ->
  forall P' Q', {{P'}} c {{Q'}} -> {{ P //\\ P' }} cmd_cmd0 c {{ Q //\\ Q' }}) ->
  forall c P Q, {{ P }} c {{ Q }} ->
    forall P' Q' d, {{ P' }} d {{ Q' }} ->
      c = d -> {{ P //\\ P' }} c {{ Q //\\ Q' }}.
Proof.
move=> H0 c P Q; elim=> //; clear c P Q.
- move=> P Q c P_c_Q P' Q' d P'_d_Q' c_d.
  apply H0 => //.
  subst d.
  by inversion P'_d_Q'.
- (* case seq *) move=> Q P R c d P_c_Q IHc Q_d_R IHd P' Q' d0; elim => //; clear d0.
  - move=> Q0 P0 R0 c0 d0 P0_c0_Q0 _ Q0_d0_R0 _ [] ? ?; subst c0 d0.
    apply (hoare_seq _ _ _ _ _ _ (Q //\\ Q0)); by [apply (IHc _ _  c) | apply (IHd _ _ d)].
  - move=> {Q' P'} P0 P' Q0 Q' c0 Q'_Q0 P0_P' P'_c0_Q' IHc0 Hc0.
    apply hoare_conseq with (P //\\ P') (R //\\ Q').
    rewrite /And /entails => *; by intuition.
    rewrite /And /And /entails => *; by intuition.
    by apply IHc0.
- (* case conseq *)
  move=> P P' Q Q' c Q'_Q P_P' P'_c_Q' IH P'0 Q'0 d H2 H3.
  apply hoare_conseq with (P' //\\ P'0) (Q' //\\ Q'0).
  rewrite /And /entails => *; by intuition.
  rewrite /And /entails => *; by intuition.
  by apply (IH _ _ d).
- (* case while *) move=> P t c Hoare_c IH P' Q' d; elim => //; clear d P' Q'.
  - move=> P0 P' Q Q' c0 Q'_Q P_P' P'_c0_Q' IHc0 Hc0.
    apply hoare_conseq with (P //\\ P') ((fun s h => P s h /\ ~~ eval_b t (s, h)) //\\ Q').
    rewrite /And /entails => *; by intuition.
    rewrite /And /entails => *; by intuition.
    by apply IHc0.
  - move=> P0 t0 c0 Hc0 _ [] ? ?; subst t0 c0.
    apply (hoare_weak (fun s h => (P //\\ P0) s h /\ ~~ eval_b t (s, h))).
    rewrite /And /entails => *; by intuition.
    apply hoare_while.
    apply (hoare_stren ((fun s h => P s h /\ eval_b t (s, h)) //\\ (fun s h => P0 s h /\ eval_b t (s, h)))).
    rewrite /And /entails => *; by intuition.
    by apply (IH _ _ c).
- (* case ifte *) move=> P Q t c d Hoare_c IHc Hoare_d IHd P' Q' d0; elim=> //; clear d0 P' Q'.
  - move=> P0 P' Q0 Q' c0 Q'_Q0 P0_P'0 P'_c0_Q' IHc0 Hc0.
    apply hoare_conseq with (P //\\ P') (Q //\\ Q').
    rewrite /And /entails => *; by intuition.
    rewrite /And /entails => *; by intuition.
    by apply IHc0.
  - move=> P0 Q0 t0 c0 d0 Hoare_c0 IHc0 Hoare_d0 IHd0 [] ? ? ?; subst t0 c0 d0.
    apply hoare_ifte.
    + apply (hoare_stren ((fun s h => P s h /\ eval_b t (s, h)) //\\ (fun s h => P0 s h /\ eval_b t (s, h)))).
      rewrite /And /entails => *; by intuition.
      by apply (IHc _ _ c).
    + apply (hoare_stren ((fun s h => P s h /\ ~~ eval_b t (s, h)) //\\ (fun s h => P0 s h /\ ~~ eval_b t (s, h)))).
      rewrite /And /entails => *; by intuition.
      by apply (IHd _ _ d).
Qed.

Lemma hoare_frame_rule_and' : (forall P Q c, hoare0 P c Q ->
  forall P' Q', {{P'}} c {{Q'}} ->{{P //\\ P'}}cmd_cmd0 c {{Q //\\ Q'}}) ->
forall c P Q P' Q',
  {{ P }} c {{ Q }} -> {{ P' }} c {{ Q' }} ->
  {{ P //\\ P' }} c {{ Q //\\ Q' }}.
Proof. intros. by apply hoare_frame_rule_and'' with c. Qed.

Lemma hoare_false' : (forall P (c0 : cmd0), {{ FF }} c0 {{ P }}) -> forall c P, {{ FF }} c {{ P }}.
Proof.
move=> Hp; induction c.
- intro P; by apply Hp.
- intro P; apply (hoare_seq _ _ _ _ _ _ (FF)); by [apply IHc1 | apply IHc2].
- intro P; apply hoare_ifte.
  + apply (hoare_stren (FF)).
    rewrite /entails; by intuition.
    by apply IHc1.
  + apply (hoare_stren (FF)).
    rewrite /entails; by intuition.
    by apply IHc2.
- intro P; apply (hoare_weak (fun s h => (fun s' h' => P s' h' /\ ~~ eval_b e (s', h')) s h /\ ~~ eval_b e (s, h))).
  + rewrite /entails; by intuition.
  + apply (hoare_stren (fun s h => P s h /\ ~~ eval_b e (s, h))).
    * rewrite /entails; contradiction.
    * apply hoare_while.
      apply (hoare_stren (FF)).
      - rewrite /entails => s h [[H H2] H1]; by rewrite H1 in H2.
      - by apply IHc.
Qed.

Lemma pull_out_conjunction' : (forall P (c0 : cmd0), {{ FF }} c0 {{ P }}) -> forall (A : Prop) P Q c,
  (A -> {{ P }} c {{ Q }}) ->
  {{ fun s h => A /\ P s h }} c {{ Q }}.
Proof.
move=> X A P Q c H.
case: (Classical_Prop.classic A) => HA.
eapply hoare_stren; last by apply H.
by move=> s h [].
eapply hoare_stren; last by apply hoare_false'.
move => s h []; by move/HA.
Qed.

(** The statement of this lemma as well as the proof idea of using ClassicalChoice comes from Andrew W. Appel, septacs.pdf *)
Lemma extract_exists :
  (forall (c : cmd0) (A : Type) (P Q : A -> assert),
    (forall x, {{ P x }} c {{ Q x }}) ->
    {{ fun s h => exists x, P x s h }} c {{ fun s h => exists x, Q x s h }}) ->
  forall (A : Type) (P Q : A -> assert) c,
  (forall x, {{ P x }} c {{ Q x}}) ->
  {{ fun s h => exists x, P x s h}} c {{ fun s h => exists x, Q x s h }}.
Proof.
move=> extract_exists0 A P Q c; move: c A P Q; elim.
- exact extract_exists0.
- move=> c IHc d IHd A P Q Hseq.
  have [R [X1 X2] ] : exists R : A -> assert,
    {{ fun s h => exists x, P x s h }} c {{ fun s h => exists x, R x s h }} /\
    {{ fun s h => exists x, R x s h }} d {{ fun s h => exists x, Q x s h }}.
    case: (hoare_seq_inv_special A P Q c d Hseq) => R [H1 H2].
    exists R; split.
    by apply IHc.
    by apply IHd.
  eapply hoare_seq; eauto.
- move=> b c IHc d IHd A P Q H.
  apply hoare_ifte.
  apply (hoare_stren (fun s h => (exists x0, P x0 s h /\ eval_b b (s, h)))).
    move=> s h /= [ [a H1] H2].
    by exists a.
  apply IHc.
  move=> a.
  case/hoare_ifte_inv: (H a) => H' _ //.
  apply (hoare_stren (fun s h => (exists x0, P x0 s h /\ ~~ eval_b b (s, h)))).
    move=> s h /= [ [a H1] H2].
    by exists a.
  apply IHd.
  move=> a.
  case/hoare_ifte_inv: (H a) => H' _ //.
- move=> b c IH A P Q H.
  have [R [X1 [X2 X3]]] : exists R : A -> assert,
    (forall s h, (exists x, P x s h) -> exists x, R x s h) /\
    {{ fun s h => (exists x, R x s h) /\ eval_b b (s, h) }} c {{ fun s h => exists x, R x s h }} /\
    (forall s h, ((exists x, R x s h) /\ ~~ eval_b b (s, h)) -> exists x, Q x s h).
    move: (hoare_while_inv_special _ _ _ _ _ H) => [R [X1 [X2 X3]]].
    exists R; split.
    + move=> s h /= [a X].
      exists a.
      by apply X2.
    + split.
      * move: {IH}(IH A _ _ X1) => IH.
        eapply hoare_stren; eauto.
        move=> s h /= [[a H1] H2].
        by exists a.
      * move=> s h [[a H1] H2].
        exists a.
        by apply X3.
  by apply hoare_while_invariant with (fun s h => exists x, R x s h).
Qed.

Lemma pull_out_exists' :
  (forall (c :cmd0) (A : Type) (P Q : A -> assert),
    (forall x, {{ P x }} c {{ Q x }}) ->
    {{ fun s h => exists x, P x s h }} c {{ fun s h => exists x, Q x s h }}) ->
  forall (A : Type) (P : A -> assert) c (Q : assert),
  (forall x, {{ P x }} c {{ Q }}) ->
  {{ fun s h => exists x, P x s h }} c {{ Q }}.
Proof.
move=> H0 A P c Q Hc.
eapply hoare_weak; last first.
apply (extract_exists H0 A P (fun x => Q) c) => //.
by move=> s h [].
Qed.

Lemma soundness P Q c : {{ P }} c {{ Q }} -> hoare_semantics P c Q.
Proof.
elim; clear P Q c.
- (* cmd0 *) move=> P Q c H; by apply soundness0.
- (* seq *) move=> P Q R c d HPcQ IHc HQdR IHd; split.
  + move=> HNone; inversion HNone; subst.
    destruct s' as [[s'h']|].
    * move: (proj2 (IHc _ _ H) _ _ H3) => HQ.
      by apply (proj1 (IHd _ _ HQ)).
    * by apply (proj1 (IHc _ _ H)).
  + move=> s' h' Hexec; inversion Hexec; subst.
    case: (IHc _ _ H) => HcNone HcSome.
    destruct s'0 as [[s'' h'']|].
    * move: (HcSome _ _ H3) => HQ.
      case: (IHd _ _ HQ) => HdNone.
      by apply.
    * by move/while_semop_prop_m.from_none : H5.
- (* conseq *) move=> P P' Q Q' c HQ'Q HPP' HP'cQ' IH; split.
  + move: (HPP' _ _ H) => HP'.
    apply (proj1 (IH _ _ HP')).
  + move=> s' h' Hc.
    move: (HPP' _ _ H) => HP'.
    case: (IH _ _ HP') => HcNone HcSome.
    apply HQ'Q => //.
    by apply HcSome.
- (* while *) move=> P t c H IH; split.
  + move Hd : (while t c) => d.
    move HS : (Some (s, h)) => S.
    move HS' : (@None state) => S'.
    move=> H1; move: t H IH s h H0 Hd HS HS'; elim: H1 => //.
    move=> [s h] s' s'' t c' H1 H2 _ H3 IHexec t' Hd IH s3 h1 HS [] X Y; subst.
    case => X Y; subst=> Hs''.
    case: (IH _ _ (conj HS H1)) => Hc'None Hc'Some.
    destruct s' as [[s' h']|] => //.
    move: {Hc'Some}(Hc'Some  _ _ H2) => HP'.
    by move: (IHexec _ Hd IH _ _ HP' (refl_equal _) (refl_equal _) Hs'').
  + move=> s' h'.
    move HC : (while t c) => C.
    move Hsigma : (Some (s, h)) => sigma.
    move Hsigma' : (Some (s', h')) => sigma'.
    move=> H1; move: P t c H IH s h s' h' H0 HC Hsigma Hsigma'; elim: H1 => //.
    * (* case exec_while true *) move=> [s h] sigma'' sigma''' t c Ht H0 _ H2 IHexec P t' c1 HC IH s0 h0 s' h' Hsigma'.
      case => X Y; subst.
      case => X Y; subst => Hsigma'''.
      (* we know s,m,h |= P /\ eval_b true, by the inductive hypothesis IH we have sigma'' |= P *)
      destruct sigma'' as [[s'' h'']|].
      - have HP'' : P s'' h''.
          case: (IH _ _ (conj Hsigma' Ht)) => _; apply; auto.
        (* since sigma'' --while t c---> sigma' and {P}while t c{P /\ eval_b false }, then we have sigma' |= P /\ ~b *)
        by move: (IHexec _ _ _ HC IH _ _ s'  h' HP'' (refl_equal (while t c)) (refl_equal (Some (s'',h''))) Hsigma''').
      - apply while_semop_prop_m.from_none in H2.
        by rewrite H2 in Hsigma'''.
    * (* case exec_while false *) move=> [s h] t c Ht P t' c' _ _ s1 h1 s2 h2 HP [] X Y; subst; case=> X Y; subst; case=> X Y; by subst.
- (* ifte *) move=> P Q t c d H1 IH1 H2 IH2; split.
  + move=> H4; inversion H4; subst.
    * by case: (IH1 _ _ (conj H H8)).
    * by case: (IH2 _ _ (conj H H8)).
  + move=> s' h' H4; inversion H4; subst.
    * case: (IH1 _ _  (conj H H8)) => _; by apply.
    * case: (IH2 _ _  (conj H H8)) => _; by apply.
Qed.

(** from a triple and a termination proof, we can deduce that the program does not fail *)
Lemma termi c P Q : {{ P }} c {{ Q }} ->
  (forall s h, P s h -> {s' | Some (s, h) -- c ---> s' } ) ->
  forall s h, P s h ->
    {s' | Some (s, h) -- c ---> Some s' }.
Proof.
move=> Hhoare Hterm s h HP.
move/soundness : Hhoare.
rewrite /hoare_semantics.
move/(_ _ _ HP) => [Hno_err Hsome].
case: {Hterm}(Hterm _ _ HP).
case=> [s' Hexec | ].
by exists s'.
tauto.
Qed.

Lemma wp_semantics_sound : forall c Q, {{ wp_semantics c Q }} c {{ Q }}.
Proof.
elim.
- move=> c Q; by apply wp_semantics_sound0.
- (* seq *) move=> c1 IHc1 c2 IHc2 Q.
  apply (hoare_stren (wp_semantics c1 (wp_semantics c2 Q))); last first.
    by eapply hoare_seq; [apply IHc1 | apply IHc2].
  move=> s h [H0 H1]; split.
  + by apply exec_seq1_not_None with c2.
  + move=> s' h' H; split.
    * by apply exec_seq2_not_None with s h c1.
    * move=> s'0 h'0 H2.
      apply H1.
      by apply exec_seq with (Some (s', h')).
- (* ifte *) move=> b c1 IHc1 c2 IHc2 Q; apply hoare_ifte.
  + eapply hoare_stren; last by apply IHc1.
    move=> s h [H0 H1].
    rewrite /wp_semantics in H0 *.
    case: H0 => H H2.
    split.
    by apply exec_ifte1_not_None with c2 b.
    move=> s' h' H0; apply H2.
    by apply exec_ifte_true.
  + eapply hoare_stren; last by apply IHc2.
    rewrite /entails => s h [[H H2] H1]; rewrite /wp_semantics; split.
    by apply exec_ifte2_not_None with c1 b.
    move=> s' h' H0; by apply H2, exec_ifte_false.
- (* while_bne *) move=> b c IHc Q; apply (hoare_weak (fun s h' => (wp_semantics (while b c) Q) s h' /\ ~~ eval_b b (s, h'))).
  + move=> s h [[H H2] H1]; by apply H2, exec_while_false.
  + apply hoare_while.
    apply (hoare_stren (wp_semantics c (wp_semantics (while b c) Q))).
    * move=> s h [[H H2] H1]; red; split.
      by apply exec_while1_not_None with b.
      move=> s' h' H0; red; split.
      by apply exec_while2_not_None with s h.
      move=> s'0 h'0 H3; by apply H2, exec_while_true with (Some (s', h')).
    * by apply IHc.
Qed.

Lemma hoare_complete P Q c : hoare_semantics P c Q -> {{ P }} c {{ Q }}.
Proof.
Proof.
move=> H.
apply (hoare_stren (wp_semantics c Q)).
move=> s h; split.
apply (proj1 (H _ _ H0)).
move=> s' h' H'.
apply (proj2 (H _ _ H0) _ _ H').
by apply wp_semantics_sound.
Qed.

(*****************)
(*  new versions *)
(*****************)

Lemma intro_exists_postcond (A : Type) P (Q : A -> assert) c :
  (exists y, {{ P }} c {{ Q y }}) ->
  {{ P }} c {{ fun s h => exists x, Q x s h }}.
Proof.
move=> [] y Hoare.
eapply hoare_conseq; last first.
  by apply Hoare.
  by apply entails_id.
move=> s h //= HQ; exists y; done.
Qed.

Lemma intro_exists_precond (A : Type) Q (P : A -> assert) c :
  (forall x, {{ P x }} c {{ Q }}) ->
  {{ fun s h => exists x, P x s h }} c {{ Q }}.
Proof.
move => Hoare.
apply hoare_complete => s h [] x Hx.
by move: {Hoare}(soundness _ _ _ (Hoare x) s h Hx).
Qed.

Lemma intro_and_prepostcond P P' Q Q' c :
    ({{ P }} c {{ Q }} /\ {{ P' }} c {{ Q' }}) ->
    {{ P //\\ P' }} c {{ Q //\\ Q' }}.
Proof.
move=> [] H1 H2.
apply hoare_complete => s h [] HP HP'.
move: {H1}(soundness _ _ _ H1 s h HP) => [] H11 H12.
move: {H2}(soundness _ _ _ H2 s h HP') => [] H21 H22.
split => //= s' h' Hc.
split => //=.
by apply H12.
by apply H22.
Qed.

Definition pure (P : assert) :=
  forall s h s' h', P s h <-> P s' h'.

Lemma hoare_pure_left P P' Q Q' c :
    pure P ->
    ((P ===> Q) /\ {{ P' }} c {{ Q' }}) ->
    {{ P //\\ P' }} c {{ Q //\\ Q' }}.
Proof.
move => Ppure [] H1 H2.
apply hoare_complete => s h [] HP HP'.
move: {H2}(soundness _ _ _ H2 s h HP') => [] H21 H22.
split => //=.
move => s' h' Hc.
split; last first.
by apply H22 => //=.
apply H1.
rewrite Ppure.
apply HP.
Qed.

Lemma hoare_frame_rule_and_left (P P' Q Q': assert) c :
    (forall s h s' h',
      Some (s, h) -- c ---> Some (s', h') ->
      P s h -> Q s' h'
    ) -> {{ P' }} c {{ Q' }} ->
    {{ P //\\ P' }} c {{ Q //\\ Q' }}.
Proof.
move=> H H1.
apply hoare_complete => s h [] HP HP'.
move: {H1}(soundness _ _ _ H1 s h HP') => [] H21 H22.
split => //= s' h' Hc.
split; last first.
  by apply H22.
by apply (H s h).
Qed.

(**)

Notation "'hoare_semantics_total'" := (@hoare_semantics_total store heap _ exec0 _ eval_b)
  : while_hoare_scope.

Notation "{{{ P }}} c {{{ Q }}}" := (@hoare_total store heap _ _ eval_b hoare0 P c Q) (at level 82, no associativity)
  : while_hoare_scope.

Lemma hoare_total_sound' :
  (forall (P Q : assert) c, hoare0 P c Q ->
    hoare_semantics_total P c Q) ->
  forall P Q c, {{{ P }}} c {{{ Q }}} -> hoare_semantics_total P c Q.
Proof.
move=> H0 P Q c; elim; clear P Q c.
- (* cmd0 *) move=> P Q c H.
  by apply H0.
- (* seq *) move=> P Q R c d H1 IHhoare1 H2 IHhoare2 s h HP.
  case: (IHhoare1 _ _ HP) => [s' [h' [K2 K3]]].
  case: (IHhoare2 _ _ K3) => [s'' [h'' [K5 K6]]].
  exists s'', h''; split => //.
  by eapply exec_seq; eauto.
- (* conseq *) move=> P P' Q Q' c H1 H2 H3 IHhoare s h HP.
  move: (H2 _ _ HP) => H'.
  case: (IHhoare _ _ H') => [s' [h' K2]].
  exists s', h'; split; first by tauto.
  apply H1; tauto.
- (* while *) move=> P t c A R Rwf V a.
  elim a using (well_founded_induction Rwf).
  move=> {}a Hrec H IHhoare s h [HP Ha].
  case/boolP : (eval_b t (s, h)) => Htest.
  - case: (IHhoare a _ _ (conj HP (conj Htest Ha))) => s' [h' [Hexec [HP' HR]]].
    move: {Hrec}(Hrec _ HR H IHhoare) => Hrec.
    case: {Hrec}(Hrec _ _ (conj HP' refl_equal)) => s'' [h'' [H1 [H2 H3]]].
    exists s'', h''; split => //.
    apply while_seq' => //.
    by apply exec_seq with (Some (s',h')).
  - exists s, h; split; last by [].
    by apply exec_while_false.
- (* ifte *) move=> P Q t c d H1 IHhoare1 H2 IHhoare2 s h HP.
  case/boolP : (eval_b t (s, h)) => Htest.
  - case: (IHhoare1 s h) => // s' [h' K1].
    exists s', h'; split; last by tauto.
    constructor; tauto.
  - case: (IHhoare2 s h); first by [].
    move=> s' [h' [K1 K2]].
    exists s', h'; split; last by [].
    by apply exec_ifte_false.
Qed.

End While_Hoare_Prop.

Module Type WHILE_HOARE_DETER.

Include WHILE_HOARE.

Local Open Scope while_cmd_scope.

Parameter exec0_deter : forall (st : option state) (c : cmd0) (st' : option state),
  st -- c ----> st' ->
  forall st'', st -- c ----> st'' -> st' = st''.

Parameter exec0_wp0 : forall s h (c : cmd0) s' h', Some (s, h) -- c ----> Some (s', h') ->
  forall (P : assert), wp0 c P s h <-> P s' h'.

End WHILE_HOARE_DETER.


From discprob.basic Require Import base order nify.
From discprob.prob Require Import prob countable finite stochastic_order uniform.
From discprob.monad Require Import monad permutation.
From discprob.monad Require quicksort quicksort_cost.
From mathcomp Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq div choice fintype.
From mathcomp Require Import tuple finfun bigop prime binomial finset.
From Coq Require Import Omega Psatz Program.Wf MSets.MSetInterface MSets.MSetGenTree Structures.OrdersEx.
Local Open Scope nat_scope.

(* The Coq standard library includes a generic implementation of
   binary search trees, parametrized by a generic "information" type
   that is stored in each node. This library is used in the
   implementation of Red-Black and AVL trees, in which the information
   stored is the color/height. Obviously, insertion cannot be
   generically defined, because these self-balancing trees do
   different things when inserting. However, the operations that do
   not build or alter the tree can be defined generically since they
   do not make use of the information field.

   Since we are going to analyze non-balancing binary search trees,
   we do not need to track any extra information, so we will just
   instantiate this generic machinery taking the information type
   to be unit. *)

Module unit.
  Definition t := unit.
End unit.

Include MSetGenTree.Ops Nat_as_OT unit.
Include MSetGenTree.Props Nat_as_OT unit.

Scheme tree_rect := Induction for tree Sort Type.

(* The notion of tree equality in the MSetGenTree library is actually about equivalence as sets,
   not them being literally equal. So, to make trees into an eqType we need our own decidable
   equality routine *)
Fixpoint tree_eq_bool (t1 t2 : tree) : bool :=
  match t1, t2 with
    | Leaf, Leaf => true
    | Node _ t1l v1 t1r, Node _ t2l v2 t2r =>
      (v1 == v2) && (tree_eq_bool t1l t2l) && (tree_eq_bool t1r t2r)
    | _, _ => false
  end.
Lemma eq_tree : Equality.axiom tree_eq_bool.
Proof.
  move=> t1 t2.
  revert t2. induction t1 using tree_rect => t2.
  { apply: (iffP idP); rewrite /tree_eq_bool //=.
    - destruct t2; auto; try inversion 1.
    - destruct t2; auto; try inversion 1. }
  apply: (iffP idP); rewrite //=.
  - destruct t2; auto; try (inversion 1; done).
    move /andP => [].
    move /andP => [].
    move /eqP => ?; subst.
    move /IHt1_1 => ->. move /IHt1_2 => ->; f_equal. destruct t, t0; done.
  - inversion 1; subst.
    apply /andP; split; auto.
    apply /andP; split; auto.
    * by apply /IHt1_1.
    * by apply /IHt1_2.
Qed.
Canonical tree_eqMixin := EqMixin (@eq_tree).
Canonical tree_eqType := Eval hnf in EqType tree (tree_eqMixin).

Fixpoint height (t: tree) :=
  match t with
    | Leaf => 0
    | Node _ Leaf v Leaf => 0
    | Node _ tl v tr =>
      S (max (height tl) (height tr))
  end.

Fixpoint add (x: nat) (t: tree) :=
  match t with
    | Leaf => Node tt Leaf x Leaf
    | Node _ tl v tr =>
      match (Nat.compare x v) with
        | Eq => t
        | Lt => Node tt (add x tl) v tr
        | Gt => Node tt tl v (add x tr)
      end
  end.

(* We prove the add function satisfies the same properties
   as the add functions for the AVL and RB trees. These proofs
   are not intended to be optimal! *)
Lemma add_spec': ∀ t x y,
    InT y (add x t) ↔ y = x ∨ InT y t.
Proof.
  induction t using tree_ind.
  - rewrite //= => x y; split.
    * inversion 1; subst; auto.
    * destruct 1 as [|Hinl]; subst.
      ** by econstructor.
      ** by inversion Hinl.
  - rewrite //= => x y.
    specialize (Nat.compare_eq x t3).
    destruct (Nat.compare x t3).
    * intros -> => //; split; auto.
      inversion 1; auto. subst. econstructor; done.
    * intros _. split.
      ** inversion 1; subst.
         *** right. econstructor; done.
         *** edestruct (proj1 (IHt1 x y)); eauto. right.
             eapply (InLeft); eauto.
         *** right. eapply (InRight); eauto.
      ** inversion 1 as [Heq|Hin].
         *** subst. apply InLeft; eapply IHt1; firstorder.
         *** inversion Hin; subst.
             **** econstructor; eauto.
             **** apply InLeft. apply IHt1; firstorder.
             **** apply InRight. done.
    * intros _. split.
      ** inversion 1; subst.
         *** right. econstructor; done.
         *** right. eapply (InLeft); eauto.
         *** edestruct (proj1 (IHt2 x y)); eauto. right.
             eapply (InRight); eauto.
      ** inversion 1 as [Heq|Hin].
         *** subst. apply InRight; eapply IHt2; firstorder.
         *** inversion Hin; subst.
             **** econstructor; eauto.
             **** apply InLeft. done.
             **** apply InRight. apply IHt2; firstorder.
Qed.

Lemma add_spec: ∀ t x y `{Ok t},
    InT y (add x t) ↔ y = x ∨ InT y t.
Proof.
  intros; apply add_spec'.
Qed.

Instance add_ok t x `{HOk: Ok t} : Ok (add x t).
Proof.
  induction HOk as [|? v tl tr Hl Hok' Hr ? Hlt Hgt].
  - rewrite //=; econstructor; try (econstructor); eauto;
      rewrite /lt_tree/gt_tree//= => y; inversion 1.
  - rewrite //=. specialize (Nat.compare_spec x v) => Hspec.
    destruct (Nat.compare x v) => //=.
    * intros. econstructor; eauto.
    * intros. econstructor; eauto.
      intros y. rewrite add_spec'. intros [Heq|Hin]; subst.
      ** inversion Hspec; done.
      ** apply Hlt; done.
    * intros. econstructor; eauto.
      intros y. rewrite add_spec'. intros [Heq|Hin]; subst.
      ** inversion Hspec; done.
      ** apply Hgt; done.
Qed.

Module examples.
Definition t1 := (add 7 (add 3 (add 5 (add 2 Leaf)))).
(*
Eval compute in t1.
Eval compute in (height t1).
*)

Definition t2 := (add 9 (add 8 (add 7 (add 6 (add 5 (add 4 (add 3 (add 2 (add 1 Leaf))))))))).
(*
Eval compute in t2.
Eval compute in (height t2).
*)
End examples.

Fixpoint add_list (l: list nat) (t: tree) :=
  match l with
    | [::] => t
    | n :: l => add_list l (add n t)
  end.

Lemma add_list_rec x (l: list nat) (tl tr: tree) :
  add_list l (Node tt tl x tr) =
  Node tt (add_list [seq i <- l | i < x] tl) x (add_list [seq i <- l | i > x] tr).
Proof.
  revert x tl tr.
  induction l as [| a l] => x tl tr.
  - rewrite //=.
  - rewrite //=.
    specialize (Nat.compare_spec a x) => Hspec.
    destruct (a ?= x); inversion Hspec; subst.
    * case: ifP; first (intros; nify; exfalso; omega); auto.
    * do 2 (case: ifP; move /ltP); try (intros; omega); [].
      intros _ _. rewrite IHl; f_equal.
    * do 2 (case: ifP; move /ltP); try (intros; omega); [].
      intros _ _. rewrite IHl; f_equal.
Qed.

Lemma add_list_rec_empty a (l: list nat):
  add_list (a :: l) Leaf =
  Node tt (add_list [seq i <- l | i < a] Leaf) a (add_list [seq i <- l | i > a] Leaf).
Proof.
  rewrite //= add_list_rec //.
Qed.

Definition add_list_random : list nat → tree → ldist tree.
  refine(Fix (measure_wf lt_wf size) (fun _ => tree → ldist tree)
  (fun l add_list_random =>
     λ t,
     match l as l' return (l = l' → ldist tree) with
     | [::] => λ eq, mret t
     | [::a] => λ eq, mret (add a t)
     | (a :: b :: l') => λ eq,
                         p ← draw_next a (b :: l');
                         add_list_random (rem (sval p) (a :: b :: l')) _ (add (sval p) t)
     end (Init.Logic.eq_refl))); rewrite /MR; auto.
  - abstract (destruct p as (x&Hin); rewrite size_rem //; subst; rewrite //=).
Defined.

Lemma alr_unfold_aux l t:
  add_list_random l t =
  match l as l' return (l = l' → ldist tree) with
    | [::] => λ eq, mret t
    | [:: a] => λ eq, mret (add a t)
    | (a :: b :: l') => λ eq,
      p ← draw_next a (b :: l');
      add_list_random (rem (sval p) (a :: b :: l')) (add (sval p) t)
  end (Init.Logic.eq_refl).
Proof. rewrite /add_list_random quicksort.easy_fix_eq; done. Qed.

Lemma alr_unfold l t:
  add_list_random l t =
  (match l with
    | [::] => mret t
    | [::a] => mret (add a t)
    | (a :: l) =>
      p ← draw_next a l;
      add_list_random (rem (sval p) (a :: l)) (add (sval p) t)
  end).
Proof.
  rewrite alr_unfold_aux. destruct l => //. destruct l => //.
Qed.

Lemma size_filter_lt {A: eqType} (l: seq A) (P: pred A):
  (∃ i, i \in l ∧ ~ P i) → (size [seq i <- l | P i] < size l)%nat.
Proof.
  induction l => //=.
  - intros (i&Hin&Hnot). rewrite in_nil in Hin. done.
  - intros Hin. case: ifP.
    * intros HP. rewrite //=.
      assert (size [seq i <- l | P i] < size l)%nat.
      { apply IHl. edestruct Hin as (i&Hin'&?).  exists i. split; auto. rewrite in_cons in Hin'.
        move /orP in Hin'. destruct Hin' as [Heq|?]; auto. move /eqP in Heq; subst; auto.
      }
      nify. omega.
    * intros. rewrite size_filter. specialize (count_size P l). rewrite //=.
Qed.

Lemma size_filter_le {A: eqType} (l: seq A) (P: pred A):
  (size [seq i <- l | P i] <= size l)%coq_nat.
Proof.
  rewrite size_filter.
  specialize (count_size P l). intros; nify. rewrite //=.
Qed.

Lemma alr_rand_perm l t:
  eq_dist (rvar_of_ldist (add_list_random l t))
          (rvar_of_ldist (l' ← rand_perm_list l; mret (add_list l' t))).
Proof.
  remember (size l) as k eqn:Heq.
  revert l t Heq.
  induction k as [k IH] using (well_founded_induction lt_wf) => l t Heq.
  destruct l as [| a l]; last destruct l as [| b l].
  - apply outcomes_eq_dist => //=; repeat f_equal; nra.
  - rewrite alr_unfold; rewrite rand_perm_list_unfold.
    apply outcomes_eq_dist => //=; repeat f_equal; nra.
  - rewrite alr_unfold; rewrite rand_perm_list_unfold.
    rewrite (ldist_assoc (draw_next a (b :: l))).
    apply eq_dist_ldist_bind_ext. intros (x&Hin). rewrite /sval.
    rewrite (ldist_assoc (rand_perm_list _)).
    eapply eq_dist_trans; first eapply IH; try eauto.
    { rewrite size_rem //; subst; rewrite //=. }
    apply eq_dist_ldist_bind_ext. intros l'.
    rewrite ldist_left_id //=.
Qed.

(* Here we give a version that looks closer to the kind of recursion in quicksort,
   and which matches the format needed for the span2 lemma *)
Definition rand_tree_rec : list nat → ldist tree.
  refine(Fix (measure_wf lt_wf size) (fun _ => ldist tree)
  (fun l rand_tree_rec =>
     match l as l' return (l = l' → ldist tree) with
     | [::] => λ eq, mret Leaf
     | [::a] => λ eq, mret (Node tt Leaf a Leaf)
     | (a :: b :: l') => λ eq,
                         p ← draw_next a (b :: l');

                         tl ← rand_tree_rec [seq i <- (a :: b :: l') | (i < sval p)%nat] _;
                         tr ← rand_tree_rec [seq i <- (a :: b :: l') | (i > sval p)%nat] _;
                         mret (Node tt tl (sval p) tr)
     end (Init.Logic.eq_refl))); rewrite /MR; auto.
  - abstract (apply /ltP; subst; apply size_filter_lt;
              exists (sval p); split; destruct p as (?&Hin); auto => //= ?; nify; omega).
  - abstract (apply /ltP; subst; apply size_filter_lt;
              exists (sval p); split; destruct p as (?&Hin); auto => //= ?; nify; omega).
Defined.

Lemma rt_unfold_aux l:
  rand_tree_rec l =
  match l as l' return (l = l' → ldist tree) with
     | [::] => λ eq, mret Leaf
     | [::a] => λ eq, mret (Node tt Leaf a Leaf)
     | (a :: b :: l') => λ eq,
                         p ← draw_next a (b :: l');

                         tl ← rand_tree_rec [seq i <- (a :: b :: l') | (i < sval p)%nat];
                         tr ← rand_tree_rec [seq i <- (a :: b :: l') | (i > sval p)%nat];
                         mret (Node tt tl (sval p) tr)
  end (Init.Logic.eq_refl).
Proof. rewrite /rand_tree_rec quicksort.easy_fix_eq; done. Qed.

Lemma rt_unfold l:
  rand_tree_rec l =
  (match l with
    | [::] => mret Leaf
    | [::a] => mret (Node tt Leaf a Leaf)
    | (a :: l) =>
                         p ← draw_next a l;

                         tl ← rand_tree_rec [seq i <- (a :: l) | (i < sval p)%nat];
                         tr ← rand_tree_rec [seq i <- (a :: l) | (i > sval p)%nat];
                         mret (Node tt tl (sval p) tr)
  end).
Proof.
  rewrite rt_unfold_aux. destruct l => //. destruct l => //.
Qed.

Lemma rt_gen_perm l:
  uniq l →
  eq_dist (rvar_of_ldist (rand_tree_rec l))
          (rvar_of_ldist (l' ← rand_perm_list l; mret (add_list l' Leaf))).
Proof.
  remember (size l) as k eqn:Heq.
  revert l Heq.
  induction k as [k IH] using (well_founded_induction lt_wf) => l Heq Huniq.
  destruct l as [| a l]; last destruct l as [| b l].
  - apply outcomes_eq_dist => //=; repeat f_equal; nra.
  - rewrite rt_unfold; rewrite rand_perm_list_unfold.
    apply outcomes_eq_dist => //=; repeat f_equal; nra.
  - rewrite rt_unfold; rewrite rand_perm_list_unfold.
    rewrite (ldist_assoc (draw_next a (b :: l))).
    apply eq_dist_ldist_bind_ext. intros (x&Hin). rewrite /sval.
    rewrite (ldist_fmap_bind).
    eapply eq_dist_trans; last first.
    { f_equal. eapply eq_dist_ldist_bind_ext => l'.
      rewrite add_list_rec_empty. apply eq_dist_refl.  }
    rewrite -(ldist_fmap_bind _ (λ l, ([seq i <- l | i < x], [seq i <- l | x < i ]))
                              (λ ls, mret (Node tt (add_list (fst ls) Leaf) x
                                                   (add_list (snd ls) Leaf)))).
    eapply eq_dist_trans; last first.
    { eapply eq_dist_ldist_bind_congr; last done.
      apply eq_dist_sym. by eapply rand_perm_list_split, rem_uniq. }
    rewrite ?ldist_assoc.
    eapply eq_dist_trans; last first.
    { eapply eq_dist_ldist_bind_ext => x0.
      rewrite (ldist_fmap_bind _ (λ l2, (x0, l2))).
      rewrite /fst/snd.
      rewrite -(ldist_fmap_bind _ (λ l, add_list l Leaf)
                                 (λ ls, mret (Node tt (add_list x0 Leaf) x ls))).
      eapply eq_dist_ldist_bind_congr.
      eapply IH; eauto.
      * eapply le_lt_trans; first eapply size_filter_le.
        rewrite size_rem //. subst => //=.
      * by apply filter_uniq, rem_uniq.
      * done.
    }
    eapply eq_dist_trans; last first.
    { eapply ldist_bind_swap. }
    eapply eq_dist_trans; last first.
    { eapply eq_dist_ldist_bind_ext => tr.
      rewrite -(ldist_fmap_bind _ (λ l, add_list l Leaf)
                                 (λ tl, mret (Node tt tl x tr))).
      eapply eq_dist_ldist_bind_congr.
      eapply IH; eauto.
      * eapply le_lt_trans; first eapply size_filter_le.
        rewrite size_rem //. subst => //=.
      * by apply filter_uniq, rem_uniq.
      * done.
    }
    eapply eq_dist_trans; last apply ldist_bind_swap.
    rewrite ?filter_rem ?rem_id; first apply eq_dist_refl.
    * rewrite mem_filter. apply /andP. intros (?&?). nify. omega.
    * rewrite mem_filter. apply /andP. intros (?&?). nify. omega.
Qed.

Lemma alr_rt_perm l:
  uniq l →
  eq_dist (rvar_of_ldist (add_list_random l Leaf))
          (rvar_of_ldist (rand_tree_rec l)).
Proof.
  intros Huniq. eapply eq_dist_trans.
  - apply alr_rand_perm.
  - apply eq_dist_sym. apply rt_gen_perm.
  done.
Qed.


Require Import Coq.Structures.OrderedType.
Require Import Coq.FSets.FMapAVL.
Require Import Coq.Structures.OrderedTypeEx.
Require Import Phaser.
Require Import Vars.

(** * Phaser map *)

(** A phaser map is a map from phaser identifier to a [phaser] state. *)

Import Map_PHID.
Definition phasermap := t phaser.

(** Function [make] creates an empty phasermap. *)

Definition make := empty phaser.

(** Function [newPhaser pm t p] expects a phaser map [pm] a task identifier [t]
  and a phaser identifier [p] and assigns a new phaser state to identifier [p];
  the phaser state is registered with task [t], as per [Phaser.make]. *)

Definition newPhaser (pm:phasermap) (t:tid) (p:phid) : phasermap :=
  add p (Phaser.make t) pm.

(** Thus, there are two possible operations, either we create a phaser
  with [NEW] or we invoke a phaser operation with [APP]. *)

Inductive op :=
  | NEW : phid -> op
  | APP : phid -> Phaser.op -> op.

(** Function [ph_apply pm t p o] looks up the phaser associated with
identifier [p] and applies a phaser operation [o] to that phaser, prefixed
with task [t]. *)

Definition ph_apply (pm:phasermap) (t:tid) (p:phid) (o:Phaser.op) : phasermap :=
  match find p pm with
    | Some ph => add p (Phaser.eval ph t o) pm
    | None => pm
  end.

(** The semantics can be summarized with operation [eval]. *)

Definition eval (pm:phasermap) (t:tid) (o:op) : phasermap :=
  match o with
    | NEW p => newPhaser pm t p
    | APP p o' => ph_apply pm t p o'
  end.