From AlphaPearl Require Import Util.Seq Util.PlfTactics.
From Coq Require Import Bool List ssreflect.
Import ListNotations.
From mathcomp Require Import bigop eqtype seq ssrbool ssrnat.
From extructures Require Import fmap fset ord.

Set Asymmetric Patterns.
Set Bullet Behavior "Strict Subproofs".
Set Implicit Arguments.
Unset Printing Implicit Defensive.

#[local] Open Scope fset_scope.
#[local] Open Scope list_scope.

Notation "'∅'" := fset0 : fset_scope.

Notation "x '∪' y" := (x :|: y) (at level 52) : fset_scope.

Notation "x '∩' y" := (x :&: y) (at level 48) : fset_scope.

Notation "⋃_( x ∈ s ) y" :=
  (\bigcup_(x <- s) y)
    (at level 41, x, s at level 50, y at level 200) : fset_scope.

Notation "∑_( x ∈ s ) y" :=
  (\sum_(x <- s) y)
    (at level 41, x, s at level 50, y at level 200) : fset_scope.

Infix "⊆" := fsubset (at level 40) : fset_scope.

(** Coercions can't be overridden, so we'll define a wrapper type (and some new, yet similar-looking)
    notation to convince Coq to use this coercion instead. *)
Definition fmap_of' (S : ordType) (T : Type) := @FMap.fmap_of _ _ (Phant (S -> T)).

Notation "'{' 'fmap' S '→' T '}'" := (fmap_of' S T) (at level 0) : type_scope.

Definition fmap_to_Prop (A : ordType) (B : Type) (R : {fmap A → B}) (k : A) (v : B) : Prop :=
  getm R k = Some v.

Coercion fmap_to_Prop : fmap_of' >-> Funclass.

Arguments getmP {_ _ _ _ _}.

Arguments injectivemP {_ _ _}.

Arguments pimfsetP {_ _ _ _ _}.

Lemma fset_uniq :
  forall (A : ordType) (s : {fset A}),
    uniq s.
Proof.
  intros ?.
  apply fset_ind; auto. intros.
  rewrite -[s]fsvalK -fset_cons /=.
  assert (uniq (x :: s)). { rewrite /= H H0 //. }
  rewrite -> uniq_size_fset in *.
  rewrite fsvalK //.
Qed.

Lemma size_cons :
  forall (A : ordType) (s : {fset A}) (x : A),
    x ∉ s ->
    size (x |: s) = S (size s).
Proof.
  intros.
  assert (uniq (x :: s)). { rewrite cons_uniq H fset_uniq //. }
  rewrite uniq_size_fset in H0.
  rewrite -[s]fsvalK -fset_cons.
  apply (rwP eqP) in H0.
  rewrite -H0 fsvalK //.
Qed.

Lemma In_mem :
  forall (A : ordType) (l : list A) (x : A),
    In x l <-> x ∈ l.
Proof.
  intros.
  split; intros;
  induction l; auto.
  - inverts H.
    + apply mem_head.
    + rewrite in_cons.
      apply (rwP orP).
      auto.
  - inverts H.
  - rewrite in_cons in H.
    apply (rwP orP) in H.
    inverts H.
    + left.
      apply (rwP eqP) in H0. auto.
    + right. auto.
Qed.

Lemma In_mem_fset :
  forall (A : ordType) (l : list A) (x : A),
    In x l <-> x ∈ fset l.
Proof.
  intros.
  split; intros;
  induction l; auto.
  - rewrite fset_cons in_fsetU.
    inverts H.
    + rewrite in_fset1 eq_refl //.
    + rewrite IHl // orbT //.
  - rewrite -fset0E in H.
    inverts H.
  - rewrite fset_cons in_fsetU in H.
    apply (rwP orP) in H. inverts H.
    + rewrite in_fset1 in H0.
      apply (rwP eqP) in H0. subst.
      left. auto.
    + right. auto.
Qed.

Lemma fset1_repeat :
  forall (A : ordType) (x : A),
    fset [x; x] = fset1 x.
Proof.
  intros.
  apply eq_fset. intro.
  apply Bool.eq_true_iff_eq.
  split; intros.
  - rewrite in_fset1.
    apply In_mem_fset in H.
    inverts H; auto.
    + apply eq_refl.
    + inverts H0; auto.
      apply eq_refl.
  - rewrite in_fset1 in H.
    apply In_mem_fset.
    left.
    apply (rwP eqP) in H. auto.
Qed.

Lemma size_fset2 :
  forall (A : ordType) (x y : A),
    x <> y ->
    size (fset [x; y]) = 2.
Proof.
  intros.
  replace 2 with (size [x; y]); auto.
  symmetry.
  apply (introF eqP) in H. apply Bool.negb_true_iff in H.
  apply (rwP eqP).
  rewrite -uniq_size_fset /= in_fset1 H //.
Qed.

Lemma app_as_cat :
  forall (A : Type) (l1 l2 : list A),
    app l1 l2 = seq.cat l1 l2.
Proof. induction l1; auto. Qed.

Definition any (A : Type) (P : A -> bool) (l : list A) : bool := fold_right orb false (map P l).

Lemma anyP :
  forall {A : ordType} {P : A -> bool} {l : list A},
    reflect (exists x : A, (x ∈ l) && P x) (any P l).
Proof.
  intros.
  induction l.
  - constructor.
    intros []. auto.
  - cbn. fold (any P l).
    inverts IHl.
    + rewrite orbT. constructor.
      destruct H0 as [].
      exists x. rewrite in_cons Bool.andb_orb_distrib_l H0 orbT //.
    + destruct (P a) eqn:?;
      constructor; eauto.
      * exists a. rewrite mem_head Heqb //.
      * intros [].
        apply H0. exists x.
        rewrite in_cons in H1.
        apply (rwP andP) in H1 as [].
        rewrite H2.
        apply (rwP orP) in H1 as [].
        -- apply (rwP eqP) in H1. subst.
           rewrite H2 // in Heqb.
        -- rewrite H1 //.
Qed.

Lemma fset2_eq :
  forall (A : ordType) (x y : A),
    [fset x; y] = fset [x; y].
Proof.
  intros.
  apply eq_fset.
  intro.
  rewrite in_fset2.
  apply Bool.eq_true_iff_eq.
  split; intros.
  - apply (rwP orP) in H.
    inverts H;
    apply (rwP eqP) in H0;
    subst;
    apply In_mem_fset;
    (left + (right; left)); auto; fail.
  - apply (rwP orP).
    apply In_mem_fset in H.
    inverts H; auto.
    inverts H0; auto.
Qed.

Lemma fset2_reorder :
  forall (A : ordType) (x y : A),
    x <> y ->
    fset [x; y] = fset [y; x].
Proof.
  intros.
  apply eq_fset. intro.
  rewrite -!fset2_eq !in_fset2 Bool.orb_comm //.
Qed.

Lemma fsval_fset2 :
  forall (A : ordType) (x y : A),
    x <> y ->
    FSet.fsval (fset [x; y]) = [x; y] \/ FSet.fsval (fset [x; y]) = [y; x].
Proof.
  intros.
  assert (2 = size (fset [x; y])).
  { apply (rwP eqP).
    replace 2 with (size [x; y]) by auto.
    rewrite -uniq_size_fset /= Bool.andb_true_r.
    apply Bool.eq_true_not_negb. intro. apply H.
    rewrite mem_seq1 in H0.
    rewrite (rwP eqP) //. }
  destruct (FSet.fsval (fset [x; y])) eqn:?;
  inverts H0.
  destruct l.
  - inverts H2.
  - destruct l.
    + rewrite -fset2_eq in Heql.
      assert (s ∈ FSet.fsval [fset x; y]). { rewrite Heql mem_head //. }
      assert (s0 ∈ FSet.fsval [fset x; y]). { rewrite Heql. apply mem_last. }
      assert (x ∈ FSet.fsval [fset x; y]). { apply In_mem_fset. left. auto. }
      assert (y ∈ FSet.fsval [fset x; y]).
      { apply In_mem_fset.
        right.
        apply In_mem.
        apply In_mem_fset.
        left. auto. }
      apply (rwP (fset2P _)) in H0, H1.
      inverts H0; inverts H1; auto;
      ((assert (x ∈ [y; y]) by rewrite -Heql //) ||
       (assert (y ∈ [x; x]) by rewrite -Heql //));
      apply In_mem in H0;
      inverts H0; auto;
      inverts H1; auto;
      inverts H0; auto.
    + inverts H2.
Qed.

Lemma mapm_setm :
  forall (A : ordType) (B C : Type) (f : B -> C) (m : {fmap A -> B}) (k : A) (v : B),
    mapm f (setm m k v) = setm (mapm f m) k (f v).
Proof.
  intros.
  apply eq_fmap. intro.
  rewrite !mapmE !setmE.
  destruct (x =P k); subst; auto.
  rewrite mapmE //.
Qed.

Lemma all_fset1 :
  forall (A : ordType) (P : A -> bool) (x : A),
    all P (fset1 x) = P x.
Proof.
  intros.
  rewrite /= Bool.andb_true_r //.
Qed.

Lemma all_fset2 :
  forall (A : ordType) (P : A -> bool) (x y : A),
    all P (fset [x; y]) = P x && P y.
Proof.
  intros.
  rewrite all_fset /= Bool.andb_true_r //.
Qed.

Lemma all_fsubset :
  forall (A : ordType) (P : A -> bool) (s s__sub : {fset A}),
    fsubset s__sub s ->
    all P s ->
    all P s__sub.
Proof.
  intros. generalize dependent s__sub.
  apply (fset_ind (P := fun s__sub : {fset A} => fsubset s__sub s -> all P s__sub)); auto. intros.
  rewrite all_fsetU.
  rewrite -(rwP andP).
  rewrite fsubU1set in H2.
  apply (rwP andP) in H2 as [].
  split; auto.
  rewrite all_fset1.
  apply (rwP allP) in H0.
  auto.
Qed.

Definition rem_fsetm (A : ordType) (B : Type) (m : {fmap A -> B}) (s : {fset A}) : {fmap A -> B} :=
  filterm (fun x _ => x ∉ s) m.

Infix "∖" := rem_fsetm (at level 40).

Lemma rem_fsetm_correct :
  forall (A : ordType) (B : Type) (m : {fmap A -> B}) (s : {fset A}) (x : A),
    (x ∈ s -> getm (m ∖ s) x = None) /\ (x ∉ s -> getm (m ∖ s) x = getm m x).
Proof.
  intros.
  split; intros;
  rewrite /rem_fsetm filtermE;
  destruct (getm m x) eqn:?;
  rewrite // H //.
Qed.

Lemma rem_fsetmE :
  forall (A : ordType) (B : Type) (m : {fmap A -> B}) (s : {fset A}) (k : A),
    (m ∖ s) k = if k ∈ s then None else m k.
Proof.
  intros.
  rewrite /rem_fsetm filtermE.
  destruct (m k) eqn:?.
  - apply if_neg.
  - rewrite if_same //.
Qed.

Lemma remm_disjoint_fset :
  forall (A : ordType) (B : Type) (m : {fmap A -> B}) (s : {fset A}),
    fdisjoint (domm m) s ->
    m ∖ s = m.
Proof.
  intros.
  apply eq_fmap. intro.
  rewrite /rem_fsetm filtermE.
  destruct (getm m x) eqn:?, (x ∈ s) eqn:?; rewrite /= //.
  assert (x ∉ domm m).
  { apply Bool.eq_true_not_negb. intro. subst.
    assert (x ∈ domm m ∩ s). { rewrite in_fsetI Heqb0 H0 //. }
    apply fdisjoint_fsetI0 in H.
    rewrite H in H1. inverts H1. }
  assert (exists b, m x = Some b) by eauto. apply (rwP dommP) in H1.
  rewrite H1 in H0. inverts H0.
Qed.

Lemma remm_disjoint_fset' :
  forall (A : ordType) (B : Type) (m : {fmap A -> B}) (s : {fset A}),
    m ∖ s = m ->
    fdisjoint (domm m) s.
Proof.
  intros.
  rewrite <- H.
  apply (rwP fdisjointP).
  intros.
  apply (rwP dommP) in H0 as [].
  rewrite rem_fsetmE in H0.
  apply Bool.negb_true_iff.
  destruct (x ∈ s) eqn:?; auto.
  inverts H0.
Qed.

Lemma rem_fsetm_as_fsetD :
  forall (A : ordType) (B : Type) (m : {fmap A -> B}) (s : {fset A}),
    domm (m ∖ s) = domm m :\: s.
Proof.
  intros.
  apply eq_fset. intros_all.
  rewrite /rem_fsetm in_fsetD mem_domm filtermE.
  destruct (m x) eqn:?.
  - simpl.
    destruct (x ∈ s) eqn:?; auto.
    symmetry.
    apply (rwP dommP). eauto.
  - simpl.
    apply (rwP dommPn) in Heqo. apply Bool.negb_true_iff in Heqo.
    rewrite Heqo andbF //.
Qed.

Definition fset_flat_map (A B : ordType) (f : A -> {fset B}) (s : {fset A}) : {fset B} :=
  ⋃_(x ∈ f @: s) x.

Lemma fset_flat_mapP :
  forall {A B : ordType} {f : A -> {fset B}} {s : {fset A}} {x : B},
    reflect (exists2 y, y ∈ s & x ∈ f y) (x ∈ fset_flat_map f s).
Proof.
  intros.
  apply (iffP idP); intros.
  - rewrite /fset_flat_map in_bigcup in H. apply (rwP hasP) in H as [].
    apply (rwP imfsetP) in H as []. subst. eauto.
  - rewrite /fset_flat_map in_bigcup. apply (rwP hasP).
    destruct H. exists (f x0); eauto.
    apply (rwP imfsetP). eauto.
Qed.

Definition fproduct (A B : ordType) (xs : {fset A}) (ys : {fset B}) : {fset (A * B)} :=
  fset_flat_map (fun x : A => fset_flat_map (fun y : B => fset1 (x, y)) ys) xs.

Infix "×" := fproduct (at level 40).

Lemma fproductP :
  forall (A B : ordType) (x : A) (y : B) (xs : {fset A}) (ys : {fset B}),
    reflect (x ∈ xs /\ y ∈ ys) ((x, y) ∈ xs × ys).
Proof.
  intros.
  apply (iffP idP); intros.
  - apply (rwP fset_flat_mapP) in H as []. apply (rwP fset_flat_mapP) in H0 as [].
    rewrite in_fset1 in H1. apply (rwP eqP) in H1. inversion H1. eauto.
  - destruct H.
    apply (rwP fset_flat_mapP). exists x; eauto.
    apply (rwP fset_flat_mapP). exists y; eauto.
    rewrite in_fset1 //.
Qed.

Lemma in_codomm_remm :
  forall (A B : ordType) (m : {fmap A -> B}) (k k' : A) (v : B),
    getm m k = Some v ->
    k <> k' ->
    v ∈ codomm (remm m k').
Proof.
  intros.
  apply (rwP codommP). exists k. rewrite remmE.
  replace (k == k') with false; auto.
  symmetry. apply Bool.not_true_is_false. intro. apply (rwP eqP) in H1. auto.
Qed.

Lemma codomm_setmE :
  forall (A B : ordType) (m : {fmap A -> B}) (k : A) (v : B),
    codomm (setm m k v) = v |: codomm (remm m k).
Proof.
  intros.
  apply eq_fset. intro.
  rewrite in_fsetU in_fset1.
  destruct (x ∈ codomm (setm m k v)) eqn:?.
  - apply (rwP codommP) in Heqb as []. rewrite setmE in H.
    destruct (x0 =P k); subst.
    + inverts H. rewrite eq_refl //.
    + assert (exists x0, m x0 = Some x) by eauto. apply (rwP codommP) in H0.
      erewrite in_codomm_remm; eauto. rewrite orbT //.
  - apply Bool.negb_true_iff in Heqb.
    rewrite <- (rwP (@codommPn _ _ (setm m k v) x)) in Heqb.
    assert (setm m k v k != Some x) by auto.
    replace (x == v) with false; cycle 1.
    { symmetry. apply Bool.not_true_is_false. intro. apply (rwP eqP) in H0. subst.
      rewrite setmE eq_refl in H. apply Bool.negb_true_iff in H. rewrite eq_refl // in H. }
    symmetry.
    apply Bool.negb_true_iff.
    rewrite <- (rwP (@codommPn _ _ (remm m k) x)). intros.
    rewrite remmE.
    destruct (k' =P k); subst; auto.
    assert (setm m k v k' != Some x) by auto.
    rewrite setmE in H0.
    replace (k' == k) with false in H0; auto.
    symmetry. apply Bool.not_true_is_false. intro. apply (rwP eqP) in H0. subst.
    apply n, (rwP eqP). auto.
Qed.

Lemma remm_setm_distr :
  forall (A B : ordType) (m : {fmap A -> B}) (k k' : A) (v : B),
    k <> k' ->
    remm (setm m k v) k' = setm (remm m k') k v.
Proof.
  intros.
  apply eq_fmap. intro.
  rewrite remmE !setmE remmE.
  destruct (x =P k'), (x =P k); auto.
  subst. exfalso. auto.
Qed.

Lemma remm_emptym :
  forall (A : ordType) (B : Type) (k : A),
    remm (@emptym _ B) k = emptym.
Proof.
  intros.
  apply eq_fmap. intro.
  rewrite remmE.
  destruct (x =P k); auto.
Qed.

Lemma fsetI0_fdisjoint :
  forall (T : ordType) (s1 s2 : {fset T}),
    s1 ∩ s2 = ∅ ->
    fdisjoint s1 s2.
Proof.
  intros.
  apply (rwP fdisjointP). intros.
  apply Bool.negb_true_iff, Bool.not_true_iff_false. intros_all.
  assert (x ∈ s1 ∩ s2). { rewrite -(rwP (fsetIP _ s1 s2)) //. }
  rewrite H in_fset0 // in H2.
Qed.

Lemma rem_fsetmI0 :
  forall (A : ordType) (B : Type) (m : {fmap A -> B}),
    m ∖ ∅ = m.
Proof.
  intros.
  apply eq_fmap. intros_all.
  rewrite rem_fsetmE //.
Qed.

Definition rem_valm {A B : ordType} (m : {fmap A -> B}) (v : B) : {fmap A -> B} :=
  filterm (fun _ v' => v != v') m.

Lemma rem_valmE :
  forall (A B : ordType) (m : {fmap A -> B}) (k : A) (v : B),
    getm (rem_valm m v) k =
      match m k with
      | Some v' => if v == v' then None else Some v'
      | None => None
      end.
Proof.
  intros.
  rewrite /rem_valm filtermE.
  destruct (m k) eqn:?; auto.
  simpl. destruct (v =P s); auto.
Qed.

Lemma eq_fmap' :
  forall (A B : ordType) (m1 m2 : {fmap A -> B}),
    (forall (a : A) (b : B), m1 a = Some b <-> m2 a = Some b) ->
    m1 = m2.
Proof.
  intros.
  apply eq_fmap. intros_all.
  destruct (m1 x) eqn:?.
  - apply H in Heqo. auto.
  - cut (forall y : B, m2 x <> Some y).
    { intros_all.
      destruct (m2 x) eqn:?; auto.
      exfalso. apply (H0 s). auto. }
    intros_all.
    apply H in H0. rewrite H0 // in Heqo.
Qed.

Lemma domm_codomm_invm :
  forall (A B : ordType) (m : {fmap A -> B}),
    injectivem m ->
    domm m = codomm (invm m).
Proof.
  intros.
  apply (rwP injectivemP) in H.
  apply eq_fset. intros_all.
  destruct (x ∈ domm m) eqn:?.
  - apply (rwP dommP) in Heqb as [].
    symmetry. apply (rwP codommP).
    exists x0.
    apply getm_inv.
    rewrite invmK //.
  - apply Bool.negb_true_iff, (rwP dommPn) in Heqb.
    symmetry. apply Bool.negb_true_iff, (rwP codommPn). intros_all.
    apply Bool.negb_true_iff, Bool.not_true_iff_false. intros_all.
    apply (rwP eqP), getm_inv in H0.
    rewrite Heqb // in H0.
Qed.

Lemma codomm_domm_invm :
  forall (A B : ordType) (m : {fmap A -> B}),
    injectivem m ->
    codomm m = domm (invm m).
Proof.
  intros.
  apply (rwP injectivemP) in H.
  apply eq_fset. intros_all.
  destruct (x ∈ codomm m) eqn:?.
  - apply (rwP dommP) in Heqb as [].
    symmetry. apply (rwP codommP).
    exists x0.
    apply getm_inv. auto.
  - apply Bool.negb_true_iff, (rwP dommPn) in Heqb.
    symmetry. apply Bool.negb_true_iff, (rwP dommPn). auto.
Qed.

Lemma invm_None :
  forall (A B : ordType) (m : {fmap A -> B}) (x : B),
    injectivem m ->
    invm m x = None <-> x ∉ codomm m.
Proof.
  intros.
  split; intros.
  - rewrite codomm_domm_invm; auto.
    apply (rwP dommPn). auto.
  - rewrite <- (rwP (@codommPn _ _ m x)) in H0.
    cut (forall y, invm m x <> Some y).
    { intros. destruct (invm m x) eqn:?; auto. exfalso. apply (H1 s). auto. }
    intros_all.
    pose proof H0 y. apply Bool.negb_true_iff, Bool.not_true_iff_false in H2. apply H2.
    rewrite (getm_inv (k := x)); auto. rewrite eq_refl //.
Qed.

Lemma fsetU_repeat : forall (A : ordType) (s : {fset A}), s ∪ s = s.
Proof.
  intros.
  apply eq_fset. intros_all.
  rewrite in_fsetU Bool.orb_diag //.
Qed.

Lemma fsetU_noop :
  forall (A : ordType) (s s' : {fset A}),
    s' ⊆ s ->
    s ∪ s' = s.
Proof.
  intros.
  apply eq_fset. intros_all.
  rewrite in_fsetU.
  destruct (x ∈ s) eqn:?; auto.
  apply (rwP fsubsetP) in H.
  apply Bool.not_true_iff_false. intros_all.
  apply H in H0. rewrite H0 // in Heqb.
Qed.

Lemma fsubset_fsetU :
  forall (A : ordType) (s1 s2 s3 : {fset A}),
    s1 ⊆ s2 ->
    (s1 ∪ s3) ⊆ (s2 ∪ s3).
Proof.
  intros.
  apply (rwP fsubsetP) in H.
  apply (rwP fsubsetP). intros_all.
  rewrite in_fsetU.
  rewrite in_fsetU in H0. apply (rwP orP) in H0 as [].
  - apply H in H0. rewrite H0 //.
  - rewrite H0 orbT //.
Qed.

Lemma remm_mapm :
  forall (A : ordType) (B : Type) (f : B -> B) (m : {fmap A → B}) (x : A),
    remm (mapm f m) x = mapm f (remm m x).
Proof.
  intros.
  apply eq_fmap. intros_all.
  rewrite remmE !mapmE remmE.
  destruct (x0 =P x); subst; auto.
Qed.

Lemma codomm_mapm :
  forall (A B : ordType) (f : B -> B) (m : {fmap A → B}),
    codomm (mapm f m) = f @: codomm m.
Proof.
  intros.
  apply eq_fset. intros_all.
  apply Bool.eq_iff_eq_true. split; intros.
  - apply (rwP codommP) in H as [].
    rewrite mapmE in H.
    destruct (getm m x0) eqn:?; inverts H.
    apply (rwP imfsetP). exists s; auto.
    apply (rwP codommP). eauto.
  - apply (rwP imfsetP) in H as [].
    apply (rwP codommP) in H as [].
    subst.
    apply (rwP codommP).
    exists x1. rewrite mapmE H //.
Qed.

Lemma remm_union :
  forall (A B : ordType) (m n : {fmap A → B}) (k : A),
    remm (unionm m n) k = unionm (remm m k) (remm n k).
Proof.
  introv.
  apply eq_fmap. intros x.
  rewrite remmE !unionmE !remmE.
  destruct (x =P k); subst; auto.
Qed.

Lemma injectivem_union :
  forall (A B : ordType) (m n : {fmap A → B}),
    fdisjoint (domm m) (domm n) ->
    injectivem (unionm m n) ->
    injectivem m /\ injectivem n.
Proof.
  introv Hdisj Hmn.
  rewrite fdisjointC in Hdisj. rewrite <- (rwP fdisjointP) in Hdisj.
  apply (rwP injectivemP) in Hmn.
  split; rewrite <- (rwP injectivemP); intros x Hx y Hxy.
  apply Hmn; try solve [rewrite domm_union in_fsetU Hx // orbC //];
  rewrite !unionmE -Hxy;
  apply (rwP dommP) in Hx as [v Hx]; rewrite Hx in Hxy.
  { rewrite Hx //. }
  apply Hmn.
  { rewrite domm_union in_fsetU Hx orbC //. }
  rewrite !unionmE.
  assert (y ∈ domm n) as Hy.
  { apply (rwP dommP). apply (rwP dommP) in Hx as [v Hx]. rewrite Hx in Hxy. eauto. }
  apply Hdisj, (rwP dommPn) in Hx, Hy. rewrite Hx Hy //.
Qed.

Lemma injectivem_union_disjoint_codomm :
  forall (A B : ordType) (m n : {fmap A → B}),
    fdisjoint (domm m) (domm n) ->
    injectivem (unionm m n) ->
    fdisjoint (codomm m) (codomm n).
Proof.
  introv Hdisj Hmn.
  rewrite fdisjointC in Hdisj. rewrite <- (rwP fdisjointP) in Hdisj.
  apply (rwP injectivemP) in Hmn.
  apply (rwP fdisjointP). intros x Hm'x.
  apply (rwP codommP) in Hm'x as [v Hmv].
  apply (rwP (@codommPn _ _ n _)). intros y.
  apply Bool.negb_true_iff, Bool.not_true_iff_false. intros Hny.
  apply (rwP eqP) in Hny.
  assert (v = y); subst.
  { apply Hmn.
    { rewrite domm_union in_fsetU. apply (rwP orP). left. apply (rwP dommP). eauto. }
    rewrite !unionmE Hmv /=.
    assert (y ∉ domm m) as Hmny. { apply Hdisj, (rwP dommP). eauto. }
    apply (rwP dommPn) in Hmny. rewrite Hmny //. }
  assert (y ∈ domm n) as H'ny. { apply (rwP dommP). eauto. }
  assert (y ∈ domm m) as H'my. { apply (rwP dommP). eauto. }
  apply Hdisj in H'ny. rewrite H'my // in H'ny.
Qed.

Lemma fsetU_after_fsetD :
  forall (A : ordType) (s : {fset A}) (x : A),
     (s :\ x) ∪ fset1 x = s ∪ fset1 x.
Proof.
  intros.
  apply eq_fset. intros k.
  rewrite !in_fsetU in_fsetD in_fset1.
  destruct (k =P x), (k ∈ s) eqn:Hks; subst; auto.
Qed.

Lemma fsetD_after_fsetU :
  forall (A : ordType) (s : {fset A}) (x : A),
    (s ∪ fset1 x) :\ x = s :\ x.
Proof.
  intros.
  apply eq_fset. intros k.
  rewrite !in_fsetD in_fsetU in_fset1.
  destruct (k =P x), (k ∈ s) eqn:Hks; subst; auto.
Qed.

Lemma unionm_set_switch :
  forall (A : ordType) (B : Type) (m1 m2 : {fmap A → B}) (k : A) (v : B),
    k ∉ domm m1 ->
    unionm (setm m1 k v) m2 = unionm m1 (setm m2 k v).
Proof.
  introv Hknm1.
  apply eq_fmap. intros x.
  rewrite !unionmE !setmE.
  destruct (x =P k); subst; auto.
  apply (rwP dommPn) in Hknm1.
  rewrite Hknm1 //.
Qed.


Set Universe Polymorphism.
Set Polymorphic Inductive Cumulativity.
Set Printing Universes.

Inductive List (A: Type) := nil | cons : A -> List A -> List A.

Section ListLift.
  Universe i j.

  Constraint i < j.

  Definition LiftL {A} : List@{i} A -> List@{j} A := fun x => x.

End ListLift.

Lemma LiftL_Lem A (l : List A) : l = LiftL l.
Proof. reflexivity. Qed.

Section ListLower.
  Universe i j.

  Constraint i < j.

  Definition LowerL {A : Type@{i}} : List@{j} A -> List@{i} A := fun x => x.

End ListLower.

Lemma LowerL_Lem@{i j|j<i+} (A : Type@{j}) (l : List@{i} A) : l = LowerL@{j i} l.
Proof. reflexivity. Qed.
(*
I disable these tests because cqochk can't process them when compiled with
   ocaml-4.02.3+32bit and camlp5-4.16 which is the case for Travis!

   I have added this file (including the commented parts below) in
   test-suite/success/cumulativity.v which doesn't run coqchk on them.
*)
(* Inductive Tp := tp : Type -> Tp. *)

(* Section TpLift. *)
(*   Universe i j. *)

(*   Constraint i < j. *)

(*   Definition LiftTp : Tp@{i} -> Tp@{j} := fun x => x. *)

(* End TpLift. *)

(* Lemma LiftC_Lem (t : Tp) : LiftTp t = t. *)
(* Proof. reflexivity. Qed. *)

(* Section TpLower. *)
(*   Universe i j. *)

(*   Constraint i < j. *)

(*   Fail Definition LowerTp : Tp@{j} -> Tp@{i} := fun x => x. *)

(* End TpLower. *)

(* Section subtyping_test. *)
(*   Universe i j. *)
(*   Constraint i < j. *)

(*   Inductive TP2 := tp2 : Type@{i} -> Type@{j} -> TP2. *)

(* End subtyping_test. *)


Require Import Crypto.Util.Tuple.
Require Import Crypto.Compilers.Syntax.

Local Open Scope ctype_scope.
Section language.
  Context {base_type_code : Type}.

  Local Notation flat_type := (flat_type base_type_code).

  Section interp.
    Section flat_type.
      Context {interp_base_type : base_type_code -> Type}.
      Local Notation interp_flat_type := (interp_flat_type interp_base_type).

      Fixpoint flat_interp_tuple' {T n} : interp_flat_type (tuple' T n) -> Tuple.tuple' (interp_flat_type T) n
        := match n return interp_flat_type (tuple' T n) -> Tuple.tuple' (interp_flat_type T) n with
           | O => fun x => x
           | S n' => fun '((x, y) : interp_flat_type (tuple' T n' * T))
                     => (@flat_interp_tuple' _ n' x, y)
           end.
      Definition flat_interp_tuple {T n} : interp_flat_type (tuple T n) -> Tuple.tuple (interp_flat_type T) n
        := match n return interp_flat_type (tuple T n) -> Tuple.tuple (interp_flat_type T) n with
           | O => fun x => x
           | S n' => @flat_interp_tuple' T n'
           end.
      Fixpoint flat_interp_untuple' {T n} : Tuple.tuple' (interp_flat_type T) n -> interp_flat_type (tuple' T n)
        := match n return Tuple.tuple' (interp_flat_type T) n -> interp_flat_type (tuple' T n) with
           | O => fun x => x
           | S n' => fun '((x, y) : Tuple.tuple' _ n' * _)
                     => (@flat_interp_untuple' _ n' x, y)
           end.
      Definition flat_interp_untuple {T n} : Tuple.tuple (interp_flat_type T) n -> interp_flat_type (tuple T n)
        := match n return Tuple.tuple (interp_flat_type T) n -> interp_flat_type (tuple T n) with
           | O => fun x => x
           | S n' => @flat_interp_untuple' T n'
           end.
      Lemma flat_interp_untuple'_tuple' {T n v}
        : @flat_interp_untuple' T n (flat_interp_tuple' v) = v.
      Proof using Type. induction n; [ reflexivity | simpl; destruct v; rewrite IHn; reflexivity ]. Qed.
      Lemma flat_interp_untuple_tuple {T n v}
        : flat_interp_untuple (@flat_interp_tuple T n v) = v.
      Proof using Type. destruct n; [ reflexivity | apply flat_interp_untuple'_tuple' ]. Qed.
      Lemma flat_interp_tuple'_untuple' {T n v}
        : @flat_interp_tuple' T n (flat_interp_untuple' v) = v.
      Proof using Type. induction n; [ reflexivity | simpl; destruct v; rewrite IHn; reflexivity ]. Qed.
      Lemma flat_interp_tuple_untuple {T n v}
        : @flat_interp_tuple T n (flat_interp_untuple v) = v.
      Proof using Type. destruct n; [ reflexivity | apply flat_interp_tuple'_untuple' ]. Qed.
    End flat_type.
  End interp.

  Section interp2.
    Section flat_type.
      Context {interp_base_type1 interp_base_type2 : base_type_code -> Type}.
      Local Notation interp_flat_type1 := (interp_flat_type interp_base_type1).
      Local Notation interp_flat_type2 := (interp_flat_type interp_base_type2).

      Definition tuple_map {A B n} (f : interp_flat_type1 A -> interp_flat_type2 B) (v : interp_flat_type1 (tuple A n))
        : interp_flat_type2 (tuple B n)
        := flat_interp_untuple (Tuple.map f (flat_interp_tuple v)).
    End flat_type.
  End interp2.
End language.
Global Arguments flat_interp_tuple' {_ _ _ _} _.
Global Arguments flat_interp_tuple {_ _ _ _} _.
Global Arguments flat_interp_untuple' {_ _ _ _} _.
Global Arguments flat_interp_untuple {_ _ _ _} _.
Global Arguments tuple_map {_ _ _ _ _ n} _ _.

Ltac unfold_flat_interp_tuple _ :=
  let handle n :=
      ltac:(let n' := (eval cbv in n) in
            progress change n with n') in
  repeat match goal with
         | [ |- context[@flat_interp_tuple _ _ _ ?n] ]
           => handle n
         | [ |- context[@flat_interp_tuple' _ _ _ ?n] ]
           => handle n
         | [ |- context[@flat_interp_untuple _ _ _ ?n] ]
           => handle n
         | [ |- context[@flat_interp_untuple' _ _ _ ?n] ]
           => handle n
         | [ |- context[@tuple _ _ ?n] ]
           => handle n
         | [ |- context[@tuple' _ _ ?n] ]
           => handle n
         end;
  cbv [flat_interp_tuple flat_interp_tuple' flat_interp_untuple flat_interp_untuple' tuple tuple'].


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

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.
Derive Show for lst.

              Derive Arbitrary for lst.

              Instance Dec_Eq_lst : Dec_Eq lst.

              Proof. dec_eq. Qed.

Lemma lfind_hyp_test : (@eq lst (rev (rev (Nil))) (Nil)).
Admitted.
QuickChick lfind_hyp_test.


(** * 6.887 Formal Reasoning About Programs, Spring 2017 - Pset 5 *)

Require Import Frap Datatypes.
Export Datatypes.

(* Authors:
 * Joonwon Choi (joonwonc@csail.mit.edu),
 * Adam Chlipala (adamc@csail.mit.edu)
 *)

Set Implicit Arguments.

(** * Correctness of a Producer-Consumer implementation *)

(* Here we prove the correctness of a Producer-Consumer implementation.
 * For general specification, refer to this article first:
 *   https://en.wikipedia.org/wiki/Producer%E2%80%93consumer_problem
 *
 * Producer-Consumer is usually implemented using concurrency-control objects
 * like locks or semaphores, and we use the former here.
 * In addition to the concurrency control, we have to think about interleavings
 * between Producer and Consumer, since they communicate via a buffer.
 *
 * Therefore, in order to solve the problem, you should either 1) carefully
 * abstract the system enough to check with the FRAP model checker, or 2)
 * directly prove the given invariant (possibly with parameterized PRD_COUNT).
 *)

(* Here's another example of a reusable program for building multithreaded
 * systems out of systems for single threads.  We will build in general handling
 * of a standard locking protocol, in contrast to the freeform notion of shared
 * state in the [parallel] combinator we saw in class. *)

(* First, a general record type for adding a lock bit to a type of shared
 * state: *)
Record sharedWithLock shared := { Lock : bool; SharedOrig : shared }.

(* We also force single-thread systems to use instantiations of this type for
 * their private state, to signal when they want to lock or unlock. *)
Inductive stateWithLock private :=
| Aprivate : private -> stateWithLock private
(* This is a state for a thread whose next step is *not* lock-related. *)

| Alock : stateWithLock private
| Aunlock : stateWithLock private
(* These states respectively indicate that the next thing the thread wants to do
 * is claim or relinquish the lock.  For simplicity, we make the arbitrary
 * choice that threads waiting to lock or unlock store no additional local
 * state, but the approach would generalize to including that state. *).

Arguments Alock {_}.
Arguments Aunlock {_}.
(* These lines ask Coq to infer the [private] type associated with a use of one
 * of the second two constructors. *)

(* Initial states of the two-thread system combine initial states of the
 * constituent systems, with the lock initialized to [false]. *)
Inductive locking1 shared private1 private2
          (init1 : threaded_state shared (stateWithLock private1) -> Prop)
          (init2 : threaded_state shared (stateWithLock private2) -> Prop)
  : threaded_state (sharedWithLock shared)
                   (stateWithLock private1 * stateWithLock private2) -> Prop :=
| Ainit : forall sh pr1 pr2,
    init1 {| Shared := sh; Private := pr1 |} ->
    init2 {| Shared := sh; Private := pr2 |} ->
    locking1 init1 init2 {| Shared := {| Lock := false; SharedOrig := sh |};
                            Private := (pr1, pr2) |}.

(* Here's the combined transition relation.  The rules come in symmetric pairs,
 * based on which of the two threads steps. *)
Inductive locking2 shared private1 private2
          (step1 : threaded_state shared (stateWithLock private1) ->
                   threaded_state shared (stateWithLock private1) -> Prop)
          (step2 : threaded_state shared (stateWithLock private2) ->
                   threaded_state shared (stateWithLock private2) -> Prop)
  : threaded_state (sharedWithLock shared) (stateWithLock private1 * stateWithLock private2) ->
    threaded_state (sharedWithLock shared) (stateWithLock private1 * stateWithLock private2) ->
    Prop :=

(* First, a thread that is not asking to lock or unlock may simply take a step
 * as normal. *)
| AstepN1 : forall sh pr1 pr2 sh' l pr1',
    pr1 <> Alock -> pr1 <> Aunlock ->
    step1 {| Shared := sh; Private := pr1 |} {| Shared := sh'; Private := pr1' |} ->
    locking2 step1 step2
             {| Shared := {| Lock := l; SharedOrig := sh |}; Private := (pr1, pr2) |}
             {| Shared := {| Lock := l; SharedOrig := sh' |}; Private := (pr1', pr2) |}
| AstepN2 : forall sh pr1 pr2 sh' l pr2',
    pr2 <> Alock -> pr2 <> Aunlock ->
    step2 {| Shared := sh; Private := pr2 |} {| Shared := sh'; Private := pr2' |} ->
    locking2 step1 step2
             {| Shared := {| Lock := l; SharedOrig := sh |}; Private := (pr1, pr2) |}
             {| Shared := {| Lock := l; SharedOrig := sh' |}; Private := (pr1, pr2') |}

(* A thread asking to lock may only step when the lock is not held, and then the
 * step toggles the lock. *)
| AstepLock1 : forall sh pr2 pr1',
    step1 {| Shared := sh; Private := Alock |} {| Shared := sh; Private := pr1' |} ->
    locking2 step1 step2
             {| Shared := {| Lock := false; SharedOrig := sh |}; Private := (Alock, pr2) |}
             {| Shared := {| Lock := true; SharedOrig := sh |}; Private := (pr1', pr2) |}
| AstepLock2 : forall sh pr1 pr2',
    step2 {| Shared := sh; Private := Alock |} {| Shared := sh; Private := pr2' |} ->
    locking2 step1 step2
             {| Shared := {| Lock := false; SharedOrig := sh |}; Private := (pr1, Alock) |}
             {| Shared := {| Lock := true; SharedOrig := sh |}; Private := (pr1, pr2') |}

(* A thread asking to unlock may only step when the lock is held, and then the
 * step toggles the lock. *)
| AstepUnlock1 : forall sh pr2 pr1',
    step1 {| Shared := sh; Private := Aunlock |} {| Shared := sh; Private := pr1' |} ->
    locking2 step1 step2
             {| Shared := {| Lock := true; SharedOrig := sh |}; Private := (Aunlock, pr2) |}
             {| Shared := {| Lock := false; SharedOrig := sh |}; Private := (pr1', pr2) |}
| AstepUnlock2 : forall sh pr1 pr2',
    step2 {| Shared := sh; Private := Aunlock |} {| Shared := sh; Private := pr2' |} ->
    locking2 step1 step2
             {| Shared := {| Lock := true; SharedOrig := sh |}; Private := (pr1, Aunlock) |}
             {| Shared := {| Lock := false; SharedOrig := sh |}; Private := (pr1, pr2') |}.

(* Here's the final definition of a two-thread system with locking. *)
Definition locking shared private1 private2
           (sys1 : trsys (threaded_state shared (stateWithLock private1)))
           (sys2 : trsys (threaded_state shared (stateWithLock private2))) :=
  {| Initial := locking1 sys1.(Initial) sys2.(Initial);
     Step := locking2 sys1.(Step) sys2.(Step)
  |}.

(* PRD_COUNT is the number of produced items by Producer.
 * This is large enough that direct use of "model_check" for the system
 * takes really long. Thus, yes, during grading for this problem set, we will
 * just stop the checker if it takes a long time.
 *
 * Note that for PRD_COUNT = 15, we have hundreds of possible states.
 *)
Definition PRD_COUNT := 15.

(* Below is pseudocode of our Producer-Consumer implementation.  Producer always
 * produces "1" and pushes it to the buffer [buf].  Consumer pops the value from
 * the buffer and adds it to [acc].
 *)
(* <<
   queue buf = empty;
   int cnt = PRD_COUNT;
   int acc = 0;

   void produce() {
     int local;
     while (cnt > 0) {
       lock();
       cnt = cnt - 1;
       buf.push(1);
       unlock();
     }
   }

   void consume() {
     int local, val;
     while (true) {
       lock();
       val = buf.pop();
       acc = acc + val;
       unlock();
     }
   }
   >>
 *)

Inductive pdcs_thread :=
(* Both Producer and Consumer start here. *)
| Start : pdcs_thread
(* Producer commands *)
| CheckCount : pdcs_thread
| DecCount : pdcs_thread
| Push : pdcs_thread
(* Consumer commands *)
| Pop : pdcs_thread
| Acc : nat -> pdcs_thread.

Record pdcs_global_state :=
  { buf : list nat;
    cnt : nat;
    acc : nat }.

Definition pdcs_state :=
  threaded_state pdcs_global_state (stateWithLock pdcs_thread).

Inductive pdcs_init : pdcs_state -> Prop :=
| PdcsInit :
    pdcs_init {| Shared := {| buf := nil; cnt := PRD_COUNT; acc := 0 |};
                 Private := Aprivate Start |}.

Inductive pdcs_step :
  bool (* "true" for the producer *) -> pdcs_state -> pdcs_state -> Prop :=
| PdStart :
    forall sh, pdcs_step true
                         {| Shared := sh; Private := Aprivate Start |}
                         {| Shared := sh; Private := Aprivate CheckCount |}
| PdCheckCount :
    forall b c a,
      pdcs_step true
                {| Shared := {| buf := b; cnt := S c; acc := a |};
                   Private := Aprivate CheckCount |}
                {| Shared := {| buf := b; cnt := S c; acc := a |};
                   Private := Alock |}
| PdLock :
    forall sh, pdcs_step true
                         {| Shared := sh; Private := Alock |}
                         {| Shared := sh; Private := Aprivate DecCount |}
| PdDecCount :
    forall b c a,
      pdcs_step true
                {| Shared := {| buf := b; cnt := S c; acc := a |};
                   Private := Aprivate DecCount |}
                {| Shared := {| buf := b; cnt := c; acc := a |};
                   Private := Aprivate Push |}
| PdPush :
    forall b c a,
      pdcs_step true
                {| Shared := {| buf := b; cnt := c; acc := a |};
                   Private := Aprivate Push |}
                {| Shared := {| buf := 1 :: b; cnt := c; acc := a |};
                   Private := Aunlock |}
| PdUnlock :
    forall sh, pdcs_step true
                         {| Shared := sh; Private := Aunlock |}
                         {| Shared := sh; Private := Aprivate CheckCount |}

| CsStart :
    forall sh, pdcs_step false
                         {| Shared := sh; Private := Aprivate Start |}
                         {| Shared := sh; Private := Alock |}
| CsLock :
    forall sh, pdcs_step false
                         {| Shared := sh; Private := Alock |}
                         {| Shared := sh; Private := Aprivate Pop |}
| CsPop :
    forall bh bt c a,
      pdcs_step false
                {| Shared := {| buf := bh :: bt; cnt := c; acc := a |};
                   Private := Aprivate Pop |}
                {| Shared := {| buf := bt; cnt := c; acc := a |};
                   Private := Aprivate (Acc bh) |}
| CsAcc :
    forall b c a v,
      pdcs_step false
                {| Shared := {| buf := b; cnt := c; acc := a |};
                   Private := Aprivate (Acc v) |}
                {| Shared := {| buf := b; cnt := c; acc := a + v |};
                   Private := Aunlock |}
| CsUnlock :
    forall sh, pdcs_step false
                         {| Shared := sh; Private := Aunlock |}
                         {| Shared := sh; Private := Alock |}.

Definition pdcs_sys is_producer :=
  {| Initial := pdcs_init;
     Step := pdcs_step is_producer |}.

Definition pdcs2_sys := locking (pdcs_sys true) (pdcs_sys false).

(* The correctness of the system is given as below: when Producer completely
 * produces all values and Consumer consumes all of them, then the accumulated
 * value equals PRD_COUNT.
 *)
Definition pdcs2_correct
           (s : threaded_state (sharedWithLock pdcs_global_state)
                               (stateWithLock pdcs_thread * stateWithLock pdcs_thread)) :=
  s.(Shared).(SharedOrig).(cnt) = 0 ->
  s.(Shared).(SharedOrig).(buf) = nil ->
  s.(Shared).(Lock) = false ->
  s.(Shared).(SharedOrig).(acc) = PRD_COUNT.

Module Type S.
  Axiom pdcs2_ok : invariantFor pdcs2_sys pdcs2_correct.
End S.