Require Import FreeProving.Free.
Require Import FreeProving.Seq.
Require Import FreeProving.Primitives.

Import Free_Notation.

Set Implicit Arguments.

Section GenericDefinitions.

  Variable C : Container.

  Definition const a b (fx : Free C a) : Free C (Fun C b a) :=
    pure (fun _ => fx).

  Arguments const [_] [_].

  Definition id a (fx : Free C a) :=
    fx.

  Definition compose a b c (ff : Free C b -> Free C c) (fg : Free C a -> Free C b) : Free C a -> Free C c :=
    fun fx => ff (fg fx).

  Inductive Pair a b :=
  | Pair_ : Free C a -> Free C b -> Pair a b.

  Definition fst a b (fp : Free C (Pair a b)) :=
    fp >>= fun p => match p with
                 | Pair_ fx _ => fx
                 end.

  Definition snd a b (fp : Free C (Pair a b)) :=
    fp >>= fun p => match p with
                 | Pair_ _ fy => fy
                 end.

  Definition State s a := Free C s -> Free C (Pair a s).

  Definition runS s a (fs : Free C (State s a)) := fs.

  Definition get s : Free C (State s s) :=
    pure (fun fs => pure (Pair_ fs fs)).

  Definition put s (fs : Free C s) : Free C (State s Unit) :=
    const (pure (Pair_ (pure Unit_) fs)).

End GenericDefinitions.

Arguments const [_] [_] [_].
Arguments State [_].
Arguments put [_] [_].
Arguments get [_] [_].

Section Monad.

  Variable C : Container.

  Section MonadDefintion.

    Class Monad (m : Type -> Type) :=
      {
        ret a : Free C a -> Free C (m a);
        bind a b : Free C (m a) -> Free C (Fun C a (m b)) -> Free C (m b)
      }.

    Global Arguments bind [_] [_] [_] [_].

    Definition then_ a b m `{Monad m} (ma : Free C (m a)) (mb : Free C (m b)) : Free C (m b) :=
      bind ma (pure (fun _ => mb)).

    Global Arguments then_ [_] [_] [_] [_].

    Definition skip m `(Monad m) :=
      ret (pure Unit_).

    Global Arguments skip [_].

  End MonadDefintion.

  Section StateInstances.

    Instance monad_State_strict s : Monad (State s) :=
      {
        ret a fx := pure (fun fs => pure (Pair_ fx fs));
        bind a b fm fk := pure (fun fs => runS fm $ fs >>= fun p =>
                                                          match p with
                                                          | Pair_ fx fs' => runS (fk $ fx) $ fs'
                                                          end)
      }.

    Instance monad_State_lazy s : Monad (State s) :=
      {
        ret a fx := pure (fun fs => pure (Pair_ fx fs));
        bind a b fm fk := pure (fun fs => let fp := runS fm $ fs
                                       in runS (fk $ fst fp) $ snd fp)
      }.

  End StateInstances.

  Definition constSkip s : Free C (Fun C Bool (State s Unit)) :=
    const (skip (monad_State_lazy s)).

  Section MonadLawsStrict.

    Variable s : Type.

    Definition bind_strict := bind (Monad := monad_State_strict s).
    Definition ret_strict   := ret (Monad := monad_State_strict s).

    Lemma MSPutPutLaw : forall (fs fs' : Free C s),
      bind_strict (put fs') (pure (fun _ => put fs)) = put fs.
    Proof.
      intros fs fs'.
      reflexivity.
    Qed.

    Lemma MSPutGetLaw : forall (fs fs' : Free C s),
        bind_strict (put fs) (pure (fun _ => get))
        = bind_strict (put fs) (pure (fun _ => ret_strict fs)).
    Proof.
      intros fs fs'.
      reflexivity.
    Qed.

    Lemma MSGetPutLaw :
        bind_strict (@get _ s) (pure (fun fs => put fs)) = skip (monad_State_strict s).
    Proof.
      reflexivity.
    Qed.

    Lemma MSGetGetLaw :
      forall a (fk : Free C (Fun C s (Free C s -> Free C (State s a)))),
        bind_strict get (pure (fun fs => bind_strict get (fk $ fs)))
        = bind_strict get (pure (fun fs => fk $ fs $ fs)).
    Proof.
      intros k.
      reflexivity.
    Qed.

  End MonadLawsStrict.

  Section MonadLaws.

    Definition MonadLaw1 m `(Monad m) :=
      forall a b (fx : Free C a) (ff : Free C (Fun C a (m b))),
        bind (ret fx) ff = ff $ fx.

    Definition MonadLaw2 m `(Monad m) :=
      forall a (fx : Free C (m a)),
        bind fx (pure (fun x => ret x)) = fx.

    Definition MonadLaw3 m `(Monad m) :=
      forall a b c (fx : Free C (m a))
        (ff : Free C (Fun C a (m b)))
        (fg : Free C (Fun C b (m c))),
        bind (bind fx ff) fg = bind fx (pure (fun x => bind (ff $ x) fg)).

  End MonadLaws.

End Monad.

Section Instances.

  Lemma MonadLaw1_State_lazy_fail__Partial :
    forall s, not (MonadLaw1 (monad_State_lazy C__Partial s)).
  Proof.
    intros s Heq.
    specialize (Heq _ Unit (pure False_) undefined).
    inversion Heq.
  Qed.

  Lemma MonadLaw1_State_strict_fail__Partial :
    forall s, not (MonadLaw1 (monad_State_strict C__Partial s)).
  Proof.
    intros s Heq.
    specialize (Heq _ Unit (pure False_) (const undefined)).
    inversion Heq.
  Qed.

  Lemma MonadLaw2_State_lazy_fail__Partial :
    forall s, not (MonadLaw2 (monad_State_lazy C__Partial s)).
  Proof.
    intros s Heq.
    specialize (Heq Bool undefined).
    inversion Heq.
  Qed.

  Lemma MonadLaw2_State_strict_fail__Partial :
    forall s, not (MonadLaw2 (monad_State_strict C__Partial s)).
  Proof.
    intros s Heq.
    specialize (Heq Bool undefined).
    inversion Heq.
  Qed.

  Lemma MonadLaw1_State_lazy__None :
    forall s, MonadLaw1 (monad_State_lazy C__None s).
  Proof.
    intros s a b fx ff.
    destruct ff as [ f | [ [] pf ] ]. simpl.
    destruct (f fx) as [ ffx | [ [] pf ] ]. simpl.
    reflexivity.
  Qed.

  Lemma MonadLaw1_State_strict__None :
    forall s, MonadLaw1 (monad_State_strict C__None s).
  Proof.
    intros s a b fx ff.
    destruct ff as [ f | [ [] pf ] ]. simpl.
    destruct (f fx) as [ ffx | [ [] pf ] ]. simpl.
    reflexivity.
  Qed.

  Section constSkip.

    Lemma MonadLaw1_State_lazy_fail__Trace :
      forall s, not (MonadLaw1 (monad_State_lazy C__Trace s)).
    Proof.
      intros s Heq.
      specialize (Heq _ _ (pure False_)
                      (trace "debug" (constSkip C__Trace s))).
      inversion Heq.
    Qed.

    Lemma MonadLaw1_State_lazy_fail__ND :
      forall s, not (MonadLaw1 (monad_State_lazy C__ND s)).
    Proof.
      intros s Heq.
      specialize (Heq _ _ (pure False_)
                      (choice (constSkip C__ND s) (constSkip C__ND s))).
      inversion Heq.
    Qed.

  End constSkip.

  Section generic.

    Variable C : Container.

    Lemma MonadLaw1_State_lazy_fail :
      forall (shape : Shape) s, not (MonadLaw1 (monad_State_lazy C s)).
    Proof.
      intros shape s Heq.
      specialize (Heq _ _ (pure False_)
                      (impure (ext shape (fun _ => constSkip C s)))).
      inversion Heq.
    Qed.

  End generic.

End Instances.


Require Export Coq.Unicode.Utf8_core.
Require Import Coq.Lists.List.
Open Scope list_scope.
Import ListNotations.
(** Utility *)
Notation "A ⇀ B" := (A → option B) (at level 75, right associativity).

Definition maps_to {A B : Set} (f : A ⇀ B) (x : A) (y : B) : Set :=
  f x = Some(y).

Axiom UIP : ∀ {A : Type} {x y : A} (p1 p2 : x = y), p1 = p2.

Lemma maps_to_up : ∀ {A B : Set} {f : A ⇀ B} {x : A} {y : B} (p1 p2 : maps_to f x y), p1 = p2.
Proof.
  intros.
  apply UIP.
Qed.

Class EqDec (A : Type) := {
  eq_dec : ∀ (x y : A), {x = y} + {x <> y}
}.

Definition remove {X : Set} {Y : Set} `{eq : EqDec X} (f : X ⇀ Y) (a : X) : X ⇀ Y :=
  fun x => match eq_dec x a with
    | left _ => None
    | right _ => f x
    end.

Definition update {X : Set} {Y : Set} `{eq : EqDec X} (f : X ⇀ Y) (a : X) (b : Y) : X ⇀ Y :=
  fun x => match eq_dec x a with
    | left _ => Some(b)
    | right _ => f x
    end.

Inductive list_contains {A : Type} : list A → A → Prop :=
  | list_contains_car : ∀ (x : A), list_contains [ x ] x
  | list_contains_cdr : ∀ (x y : A) (l : list A),
    list_contains l y → list_contains (x :: l) y
.


From stdpp Require Import prelude.
From Coq Require Import Reals Lra.
From VLSM.Lib Require Import Preamble ListExtras StdppListSet StdppListFinSet.

(** * Measure-related definitions and lemmas *)

Definition pos_R := {r : R | (r > 0)%R}.

Class Measurable (V : Type) : Type := weight : V -> pos_R.

#[global] Hint Mode Measurable ! : typeclass_instances.

Section sec_measurable_props.

Context
  `{Measurable V}
  `{FinSet V Cv}
  .

Definition sum_weights (l : Cv) : R :=
  set_fold (fun v r => (proj1_sig (weight v) + r)%R) 0%R l.

Definition sum_weights_list (vs : list V) :=
  fold_right (fun v r => (proj1_sig (weight v) + r)%R) 0%R vs.

Lemma sum_weights_list_rew (l : Cv) :
  sum_weights l = sum_weights_list (elements l).
Proof. done. Qed.

Lemma sum_weights_empty :
  forall (l : Cv), l ≡ ∅ -> sum_weights l = 0%R.
Proof.
  intros l Hl.
  unfold sum_weights, set_fold; cbn.
  by apply elements_empty_iff in Hl as ->.
Qed.

Lemma sum_weights_positive_list (l : list V) :
  (0 <= sum_weights_list l)%R.
Proof.
  induction l; try apply Rle_refl.
  simpl. apply Rplus_le_le_0_compat; [| done].
  destruct (weight a); cbn.
  by apply Rlt_le.
Qed.

Lemma sum_weights_positive (l : Cv) :
  (0 <= sum_weights l)%R.
Proof.
  rewrite sum_weights_list_rew.
  by apply sum_weights_positive_list.
Qed.

Definition weight_proj1_sig (w : pos_R) : R := proj1_sig w.

Coercion weight_proj1_sig : pos_R >-> R.

Lemma sum_weights_in_list
  : forall (v : V) (vs : list V),
  NoDup vs ->
  v ∈ vs ->
  sum_weights_list vs
  = (proj1_sig (weight v) +
  sum_weights_list (StdppListSet.set_remove v vs))%R.
Proof.
  induction vs; cbn; intros Hnodup Hv **; inversion Hv as [| ? ? ? Hv']; subst; clear Hv.
  - inversion Hnodup; subst; clear Hnodup.
    apply Rplus_eq_compat_l.
    by rewrite decide_True.
  - inversion Hnodup as [| ? ? Ha Hnodup']; subst; clear Hnodup.
    pose proof (in_not_in _ _ _ _ Hv' Ha).
    rewrite decide_False; cbn; [| done].
    rewrite <- Rplus_assoc, (Rplus_comm (proj1_sig (weight v))), Rplus_assoc.
    by apply Rplus_eq_compat_l, IHvs.
Qed.

Lemma sum_weights_subseteq_list
  : forall (vs vs' : list V),
  NoDup vs ->
  NoDup vs' ->
  vs ⊆ vs' ->
  (sum_weights_list vs <= sum_weights_list vs')%R.
Proof.
  induction vs; intros vs' Hnodup_vs Hnodup_vs' Hincl;
    [by apply sum_weights_positive_list |].
  pose proof (Hvs' := sum_weights_in_list a vs' Hnodup_vs').
  spec Hvs'; [by apply Hincl; left |].
  rewrite Hvs'; cbn.
  apply Rplus_le_compat_l.
  inversion Hnodup_vs; subst; clear Hnodup_vs.
  apply IHvs; [done | by apply set_remove_nodup |].
  intros v Hv.
  apply StdppListSet.set_remove_iff; [done |].
  split.
  + by apply Hincl; right.
  + by intros ->.
Qed.

Lemma sum_weights_subseteq
  : forall (vs vs' : Cv),
  vs ⊆ vs' ->
  (sum_weights vs <= sum_weights vs')%R.
Proof.
  intros vs vs' Hincl.
  rewrite !sum_weights_list_rew.
  apply sum_weights_subseteq_list.
  - by apply NoDup_elements.
  - by apply NoDup_elements.
  - by intro v; rewrite !elem_of_elements; apply Hincl.
Qed.

Lemma sum_weights_proper : Proper (equiv ==> eq) sum_weights.
Proof.
  intros x y Hequiv.
  by apply Rle_antisym; apply sum_weights_subseteq; intro a; apply Hequiv.
Qed.

Lemma sum_weights_in :
  forall v (vs : Cv),
    v ∈ vs -> sum_weights vs = (proj1_sig (weight v) + sum_weights (set_remove v vs))%R.
Proof.
  intros v vs Hv.
  rewrite sum_weights_list_rew, sum_weights_in_list with (v := v); cycle 1.
  - by apply NoDup_elements.
  - by apply elem_of_elements.
  - apply Rplus_eq_compat_l, Rle_antisym; apply sum_weights_subseteq_list.
    + by apply set_remove_nodup, NoDup_elements.
    + by apply NoDup_elements.
    + intros x Hx.
      rewrite elem_of_elements.
      apply set_remove_iff.
      apply StdppListSet.set_remove_iff in Hx; [| by apply NoDup_elements].
      by rewrite elem_of_elements in Hx.
    + by apply NoDup_elements.
    + by apply set_remove_nodup, NoDup_elements.
    + intros x Hx.
      rewrite elem_of_elements in Hx.
      apply StdppListSet.set_remove_iff; [by apply NoDup_elements |].
      apply set_remove_iff in Hx.
      by rewrite elem_of_elements.
Qed.

Lemma sum_weights_app_list
  : forall (vs vs' : list V),
  sum_weights_list (vs ++ vs') = (sum_weights_list vs + sum_weights_list vs')%R.
Proof. by induction vs; intros; simpl; [| rewrite IHvs]; lra. Qed.

#[export] Instance sum_weights_list_permutation_proper :
  Proper ((≡ₚ) ==> (=)) sum_weights_list.
Proof.
  intros l1 l2 Hl.
  unfold sum_weights_list; apply foldr_permutation_proper; [.. | done].
  - by typeclasses eauto.
  - by congruence.
  - by intros; lra.
Qed.

Lemma sum_weights_disj_union :
  forall (vs vs' : Cv),
    vs ## vs' ->
    sum_weights (vs ∪ vs') = (sum_weights vs + sum_weights vs')%R.
Proof.
  intros vs vs' Hdisj.
  apply elements_disj_union, sum_weights_list_permutation_proper in Hdisj.
  setoid_rewrite Hdisj.
  apply sum_weights_app_list.
Qed.

Lemma sum_weights_union_empty (vs : Cv) :
  sum_weights (vs ∪ ∅) = sum_weights vs.
Proof.
  rewrite sum_weights_disj_union by apply disjoint_empty_r.
  by rewrite (sum_weights_empty ∅); [lra |].
Qed.

End sec_measurable_props.


Require Export SQIR.UnitaryOps QuantumLib.VectorStates.
Require Import QuantumLib.Summation.
Require Import QuantumLib.DiscreteProb.

Local Coercion Nat.b2n : bool >-> nat.

(* General definitions useful for specifying & verifying quantum algorithms. *)

(* ======================================== *)
(**    Boolean oracle (f : nat -> bool)    **)
(* ======================================== *)

(* Definition of boolean oracle U : ∣ x ⟩∣ y ⟩ ↦ ∣ x ⟩∣ y ⊕ f(x) ⟩ *)
Definition boolean_oracle {n} (U : base_ucom (S n)) (f : nat -> bool) :=
  forall x (y : bool), (x < 2 ^ n)%nat ->
    @Mmult _ _ 1 (uc_eval U) (basis_vector (2 ^ n) x ⊗ ∣ y ⟩) =
      basis_vector (2 ^ n) x ⊗ ∣ xorb y (f x) ⟩.

Definition pad_vector {n} dim (v : Vector (2 ^ n)) : Vector (2 ^ dim) :=
  v ⊗ kron_n (dim - n) ∣0⟩.

Lemma wf_pad_vector :
  forall n dim (v : Vector (2 ^ n)),
  (n <= dim)%nat -> WF_Matrix v -> WF_Matrix (pad_vector dim v).
Proof.
  intros n dim v Hn Hw. unfold pad_vector.
  apply WF_kron; auto with wf_db.
  rewrite Nat.pow_1_l. reflexivity.
Qed.

(* Alternate form of boolean_oracle that uses ancilla qubits.
   The qubits are ordered as follows:
     input x (n qubits) ; output y (1 qubit) ; ancillae (dim-n-1 qubits) *)
Definition padded_boolean_oracle {dim} n
  (U : base_ucom dim) (f : nat -> bool) :=
  forall x (y : bool),
  (x < 2 ^ n)%nat ->
  @Mmult
      _ _ 1
      (uc_eval U)
      (@pad_vector (S n) dim (basis_vector (2 ^ n) x ⊗ ∣ y ⟩ )) =
    @pad_vector (S n) dim (basis_vector (2 ^ n) x ⊗ ∣ xorb y (f x) ⟩ ).

(* ======================================= *)
(**    Integer oracle (f : nat -> nat)    **)
(* ======================================= *)

(* Special case U : ∣ x ⟩∣ 0 ⟩ ↦ ∣ x ⟩∣ f(x) ⟩ *)
Definition integer_oracle {n} (U : base_ucom (2 * n)) (f : nat -> nat) :=
  forall (x :nat), (x < 2 ^ n)%nat ->
    @Mmult _ _ 1 (uc_eval U) (basis_vector (2 ^ n) x ⊗ basis_vector (2 ^ n) 0) =
      basis_vector (2 ^ n) x ⊗ ((basis_vector (2 ^ n) (f x))).

(* ========================================== *)
(**    Count the solutions to a predicate    **)
(* ========================================== *)

(* Count the number of inputs in [a,a+b) where f returns true; note that
   we never "run" this function, it's just used in specifications. *)
Fixpoint count (f : nat -> bool) a b : nat :=
  match b with
  | O => O
  | S b' => (f (a + b') + count f a b')%nat
  end.

Definition count0 f := count f 0.
Definition count1 f := count f 1.

Lemma count_extend : forall f a b,
  count f a (S b)  = if (f (a + b)%nat) then S (count f a b) else count f a b.
Proof. intros. simpl. destruct (f (a + b)%nat); reflexivity. Qed.

Lemma count_upper_bound : forall a b (f : nat -> bool), (count f a b <= b)%nat.
Proof.
  intros.
  induction b; simpl.
  lia.
  destruct (f (a + b)%nat); simpl; lia.
Qed.

Lemma count_all_false : forall a b, count (fun _ => false) a b = O.
Proof. induction b; intros; simpl; try apply IHn; easy. Qed.

Lemma count_all_true : forall a b, count (fun _ => true) a b = b.
Proof. induction b; intros; simpl; lia. Qed.

Lemma count_zero: forall  a b (f : nat -> bool),
  count f a b = O -> forall i, (a <= i < a + b)%nat -> f i = false.
Proof.
  intros a b f H i Hi.
  induction b as [|b].
  lia.
  simpl in H.
  apply Nat.eq_add_0 in H as [? ?].
  bdestruct (i =? a + b)%nat; subst.
  destruct (f (a + b)%nat); simpl in *; easy.
  apply IHb; lia.
Qed.

Lemma count_nonzero: forall  a b (f : nat -> bool),
  count f a b <> O <-> exists i, (a <= i < a + b)%nat /\ f i = true.
Proof.
  intros a b f.
  split; intro H.
  - induction b as [|b].
    simpl in H.
    lia.
    simpl in H.
    bdestruct (count f a b =? 0).
    rewrite H0 in H.
    exists (a + b)%nat.
    split; try lia.
    destruct (f (a + b)%nat); simpl in *; auto.
    apply IHb in H0.
    destruct H0 as [x [? ?]].
    exists x.
    split. lia. auto.
  - destruct H as [x [Hx1 Hx2]].
    induction b. lia.
    bdestruct (x =? a + b)%nat. subst. simpl. rewrite Hx2. simpl. lia.
    simpl. destruct (f (a + b))%nat; lia.
Qed.

Lemma count_eq : forall a b f g,
    (forall x, (a <= x < a + b)%nat -> f x = g x) ->
    count f a b = count g a b.
Proof.
  induction b; intros. reflexivity.
  assert (f (a + b) = g (a + b))%nat by (apply H; lia).
  simpl. rewrite H0. rewrite IHb with (g := g). reflexivity.
  intros. apply H. lia.
Qed.

Lemma count_update_oob : forall f x v a b,
  (x < a)%nat \/ (a + b <= x)%nat ->
  count f a b = count (update f x v) a b.
Proof.
  intros. apply count_eq. intros.
  rewrite update_index_neq. easy. lia.
Qed.

Lemma count_update : forall f x v a b,
  (a <= x < a + b)%nat ->
  f x = true ->
  count (update f x v) a b = if v then count f a b else ((count f a b) - 1)%nat.
Proof.
  induction b; intros. lia.
  destruct v. rewrite update_same; easy.
  bdestruct (x =? a + b)%nat. subst. simpl. rewrite update_index_eq. rewrite H0.
  rewrite <- count_update_oob; simpl; lia.
  simpl. rewrite update_index_neq by easy.
  destruct (f (a + b))%nat. rewrite IHb by (try easy; try lia).
  assert (count f a b <> 0)%nat.
  apply count_nonzero. exists x. split. lia. assumption.
  lia.
  rewrite IHb. easy. lia. easy.
Qed.

Lemma count_update_false : forall a b x f,
  (a <= x < a + b)%nat ->
  f x = true ->
  S (count (update f x false) a b) = count f a b.
Proof.
  intros.
  assert (count f a b <> 0)%nat.
  apply count_nonzero. exists x. split. lia. assumption.
  rewrite count_update by assumption.
  lia.
Qed.

Lemma count0_Nsum : forall n f, count0 f n = big_sum (fun i => if f i then S O else O) n.
Proof.
  unfold count0.
  intros. induction n. reflexivity.
  simpl. rewrite IHn. destruct (f n); simpl; lia.
Qed.

Lemma count1_Nsum : forall n f,
  f O = false ->
  f n = false ->
  count1 f n = big_sum (fun i => if f i then S O else O) n.
Proof.
  unfold count1.
  intros n f HO Hn.
  assert (H : count f 1 n = big_sum (fun i => if f i then S O else O) (S n)).
  { clear Hn.
    induction n. simpl. rewrite HO. reflexivity.
    simpl. rewrite IHn. destruct (f (S n)); simpl; lia. }
  destruct n. reflexivity.
  rewrite H. simpl. rewrite Hn. simpl. lia.
Qed.

Lemma count_complement : forall a b f g,
  (count (fun i => f i && g i) a b + count (fun i => f i && ¬ (g i)) a b = count f a b)%nat.
Proof.
  intros. induction b. easy.
  simpl. destruct (f (a + b))%nat; destruct (g (a + b))%nat; simpl; lia.
Qed.

Lemma count_implies : forall a b f g,
  (forall x, a <= x < a + b -> f x = true -> g x = true)%nat ->
  (count f a b <= count g a b)%nat.
Proof.
  intros. induction b. easy.
  assert (count f a b <= count g a b)%nat.
  { apply IHb. intros. apply H. lia. easy. }
  simpl. destruct (f (a + b))%nat eqn:Hf. apply H in Hf.
  2: lia.
  rewrite Hf. lia.
  destruct (g (a + b))%nat; simpl; lia.
Qed.

Lemma count_orb : forall a b f g,
  count (fun i => f i || g i) a b =
    (count f a b + count (fun i => (¬ (f i)) && g i)  a b)%nat.
Proof.
  intros.
  rewrite <- count_complement with (g:=f).
  assert (forall n1 n2 n3 n4, n1 = n3 -> n2 = n4 -> n1 + n2 = n3 + n4)%nat by lia.
  apply H; apply count_eq; intros; destruct (f x); destruct (g x); reflexivity.
Qed.

Definition negf (f : nat -> bool) i := negb (f i).

Lemma negf_involutive : forall f, negf (negf f) = f.
Proof.
  intros.
  unfold negf.
  apply functional_extensionality.
  intro.
  apply negb_involutive.
Qed.

Local Opaque Nat.sub.
Lemma count_negf : forall a b (f : nat -> bool),
  count (negf f) a b = (b - count f a b)%nat.
Proof.
  intros.
  induction b; simpl.
  reflexivity.
  rewrite IHb.
  unfold negf.
  specialize (count_upper_bound a b f) as H.
  destruct (f (a + b))%nat; simpl; lia.
Qed.

Lemma vsum_count0 : forall n (f : nat -> bool),
  big_sum (fun i : nat => if f i then I 1 else Zero) n =
    INR (count0 f n) .* I 1.
Proof.
  unfold count0.
  intros.
  induction n.
  lma.
  rewrite <- big_sum_extend_r, IHn.
  simpl count.
  rewrite plus_INR.
  destruct (f n); simpl; lma.
Qed.

Lemma nth_repeat : forall (n i : nat) (r : R),
  (i < n)%nat -> nth i (repeat r n) 0 = r.
Proof.
  intros n i r Hi.
  rewrite nth_indep with (d':=r).
  clear Hi.
  gen i.
  induction n; intro i; simpl; destruct i; try reflexivity.
  apply IHn.
  rewrite repeat_length.
  assumption.
Qed.

Lemma pr_outcome_sum_count : forall l u f,
  (l < u)%nat ->
  pr_outcome_sum (uniform l u) f
  = (INR (count1 (fun x => f (l + x - 1)%nat) (u - l)) / INR (u - l))%R.
Proof.
  intros l u f H.
  unfold uniform.
  rewrite pr_outcome_sum_append.
  rewrite pr_outcome_sum_repeat_false.
  rewrite Rplus_0_l.
  remember (u - l)%nat as n.
  assert (Hn:(n > 0)%nat) by lia.
  clear - Hn.
  unfold pr_outcome_sum.
  rewrite 2 repeat_length.
  rewrite big_sum_eq_bounded with (g:=fun i => ((1 / INR n)%R ⋅ (if f (l + i)%nat then 1 else 0))%R).
  rewrite <- big_sum_scale_l.
  replace (INR (count1 (fun x : nat => f (l + x - 1)%nat) n) / INR n)%R with (1 / INR n * INR (count1 (fun x : nat => f (l + x - 1)%nat) n))%R by lra.
  apply f_equal2; try reflexivity.
  clear Hn.
  induction n.
  reflexivity.
  rewrite <- big_sum_extend_r.
  simpl.
  rewrite IHn.
  unfold count1. simpl.
  replace (l + S n - 1)%nat with (l + n)%nat by lia.
  destruct (f (l + n)%nat).
  rewrite S_O_plus_INR.
  simpl. lra.
  simpl. lra.
  intros i Hi.
  destruct (f (l + i)%nat).
  rewrite nth_repeat by assumption.
  unfold Vscale. simpl. lra.
  unfold Vscale. simpl. lra.
Qed.

(* ======================================== *)
(**         Other misc. utilities          **)
(* ======================================== *)

(* Copied from euler/Asympt.v *)
Lemma seq_extend :
  forall n x, List.seq x (S n) = List.seq x n ++ [(x + n)%nat].
Proof.
  induction n; intros. simpl. rewrite Nat.add_0_r. easy.
  replace (List.seq x (S (S n))) with (x :: List.seq (S x) (S n)) by easy.
  rewrite IHn. simpl. replace (x + S n)%nat with (S (x + n))%nat by lia.
  easy.
Qed.

Lemma count_filter_seq : forall a b f,
  count f a b = length (filter f (List.seq a b)).
Proof.
  induction b; intros.
  reflexivity.
  rewrite seq_extend. rewrite filter_app. rewrite app_length.
  rewrite <- IHb. simpl.
  destruct (f (a + b))%nat. simpl. lia.
  simpl. lia.
Qed.

Lemma Csum_1 : forall f n, (forall x, f x = 1%C) ->
  @big_sum Complex.C C_is_monoid f n = INR n.
Proof.
  intros.
  induction n.
  - reflexivity.
  - simpl.
    rewrite IHn, H.
    destruct n; lca.
Qed.

Lemma times_n_C : forall (c : Complex.C) n, times_n c n = (INR n * c)%C.
Proof.
  intros c n.
  induction n; simpl.
  lca.
  rewrite IHn.
  destruct n; lca.
Qed.

Lemma Csum_mult_l : forall (c : Complex.C) f n, (c * Σ f n)%C = Σ (fun x => c * f x) n.
Proof.
  intros c f n.
  induction n.
  + simpl; lca.
  + simpl.
    rewrite Cmult_plus_distr_l.
    rewrite IHn.
    reflexivity.
Qed.

Lemma Nsum_scale : forall n f d,
  (big_sum (fun i => d * f i) n = d * big_sum f n)%nat.
Proof.
  intros. induction n. simpl. lia.
  simpl. rewrite IHn. lia.
Qed.

Lemma Nsum_add : forall n f g,
  (big_sum (fun i => f i + g i) n = big_sum f n + big_sum g n)%nat.
Proof.
  intros. induction n. easy.
  simpl. rewrite IHn. lia.
Qed.


Require Export P04.

(** **** Exercise: 4 stars (balance_relate)  *)
(** You will need proof automation for this one.  Study the methods used
  in [ins_not_E] and [balance_SearchTree], and try them here.
  Add one clause at a time to your [match goal]. *)
Lemma Abs_helper:
  forall m' t m, Abs t m' ->    m' = m ->     Abs t m.
Proof.
   intros. subst. auto.
Qed.

Ltac contents_equivalent_prover :=
 extensionality x; unfold t_update, combine, t_empty;
 repeat match goal with
  | |- context [if ?A then _ else _] => bdestruct A
 end;
 auto;
 omega.

Theorem balance_relate:
  forall c l k vk r m,
    SearchTree (T c l k vk r) ->
    Abs (T c l k vk r) m ->
    Abs (balance c l k vk r) m.
Proof.
intros.
inv H.
unfold balance.
repeat match goal with
 | H: Abs E _ |- _ => inv H
end.
(** Add these clauses, one at a time, to your [repeat match goal] tactic,
   and try it out:
   -1. Whenever a clause [H: Abs E _] is above the line, invert it by [inv H].
             Take note: with just this one clause, how many subgoals remain?
   -2. Whenever [Abs (T _ _ _ _ _) _] is above the line, invert it.
             Take note: with just these two clause, how many subgoals remain?
   -3. Whenever [SearchTree' _ E _] is above the line, invert it.
             Take note after this step and each step: how many subgoals remain?
   -4. Same for [SearchTree' _ (T _ _ _ _ _) _].
   -5. When [Abs match c with Red => _ | Black => _ end _] is below the line,
          [destruct c].
   -6. When [Abs match s with E => _ | T ... => _ end _] is below the line,
          [destruct s].
   -7. Whenever [Abs (T _ _ _ _ _) _] is below the line,
                  prove it by [apply Abs_T].   This won't always work;
         Sometimes the "cts" in the proof goal does not exactly match the form
         of the "cts" required by the [Abs_T] constructor.  But it's all right if
         a clause fails; in that case, the [match goal] will just try the next clause.
          Take note, as usual: how many clauses remain?
   -8.  Whenever [Abs E _] is below the line, solve it by [apply Abs_E].
   -9.  Whenever the current proof goal matches a hypothesis above the line,
          just use it.  That is, just add this clause:
       | |- _ => assumption
   -10.  At this point, if all has gone well, you should have exactly 21 subgoals.
       Each one should be of the form, [  Abs (T ...) (t_update...) ]
       What you want to do is replace (t_update...) with a different "contents"
       that matches the form required by the Abs_T constructor.
       In the first proof goal, do this: [eapply Abs_helper].
       Notice that you have two subgoals.
       The first subgoal you can prove by:
           apply Abs_T. apply Abs_T. apply Abs_E. apply Abs_E.
           apply Abs_T. eassumption. eassumption.
       Step through that, one at a time, to see what it's doing.
       Now, undo those 7 commands, and do this instead:
            repeat econstructor; eassumption.
       That solves the subgoal in exactly the same way.
       Now, wrap this all up, by adding this clause to your [match goal]:
       | |- _ =>  eapply Abs_helper; [repeat econstructor; eassumption | ]
   -11.  You should still have exactly 21 subgoals, each one of the form,
             [ t_update... = t_update... ].  Notice above the line you have some
           assumptions of the form,  [ H: SearchTree' lo _ hi ].  For this equality
         proof, we'll need to know that [lo <= hi].  So, add a clause at the end
        of your [match goal] to apply SearchTree'_le in any such assumption,
        when below the line the proof goal is an equality [ _ = _ ].
   -12.  Still exactly 21 subgoals.  In the first subgoal, try:
          [contents_equivalent_prover].   That should solve the goal.
          Look above, at [Ltac contents_equivalent_prover], to see how it works.
          Now, add a clause to  [match goal] that does this for all the subgoals.

   -Qed! *)
exact FILL_IN_HERE. Qed.


(** An example of using Coq to work through the algebraic homomorphisms
    of a denotation. *)

Require Export Coq.Classes.Equivalence.
Require Export Coq.Classes.SetoidClass.
Require Export Coq.Classes.RelationClasses.
Require Export Coq.Classes.Morphisms.
Require Import Coq.Arith.Arith.
Require Import Coq.Init.Nat.

Open Scope nat_scope.

Generalizable All Variables.

Notation "f ≈ g" := (equiv f g) (at level 79).

(** Specification of a stream *)

Definition StreamS (a : Type) := nat -> a.

Program Instance Function_Setoid `{Setoid b} : Setoid (a -> b) := {
  equiv := fun f g => forall i, f i ≈ g i
}.
Next Obligation.
  constructor; repeat intro.
  - reflexivity.
  - now symmetry.
  - now (transitivity (y i)).
Qed.

(** An algebra of streams *)

Definition cons `(x : a) (s : StreamS a) : StreamS a :=
  fun i => if i =? 0 then x else s (pred i).

Definition uncons `(s : StreamS a) : a * StreamS a :=
  (s 0, fun i => s (succ i)).

Definition zip `(s : StreamS a) `(t : StreamS b) : StreamS (a * b) :=
  fun i => (s i, t i).

Definition replicate `(x : a) : StreamS a := fun _ => x.

(* etc... *)

(** Streams, by their shape also express many other algebras:

    Functor
    Representable Functor
    Applicative
    Monad
    Monoid, if a is a Monoid
    etc.
*)

(** We want to denote some object that represents streams, but what is
    sufficient to capture our use of them? *)

Program Definition denote' {a} (d : _ a) : StreamS a :=
  fun i => _.
Admit Obligations.

(** If the type of the specification alone is not enough of a guide,
    we can try out a data type as an idea. *)

CoInductive Stream (a : Type) := Cons : a -> Stream a -> Stream a.

Arguments Cons {a} _ _.

CoInductive stream_equiv `{Setoid a} : Stream a -> Stream a -> Prop :=
  | Stream_equiv : forall h h' t1 t2,
      stream_equiv t1 t2
        -> h ≈ h'
        -> stream_equiv (Cons h t1) (Cons h' t2).

Definition frob `(s : Stream a) : Stream a :=
  match s with Cons h t => Cons h t end.

Theorem frob_eq : forall `(s : Stream a), s = frob s.
  destruct s; reflexivity.
Qed.

Definition hd `(s : Stream a) : a :=
  match s with Cons x _ => x end.

Definition tl `(s : Stream a) : Stream a :=
  match s with Cons _ xs => xs end.

Theorem stream_equiv_coind `{Setoid a} `(R : Stream a -> Stream a -> Prop) :
  (forall s1 s2, R s1 s2 -> hd s1 ≈ hd s2) ->
  (forall s1 s2, R s1 s2 -> R (tl s1) (tl s2)) ->
  forall s1 s2, R s1 s2 -> stream_equiv s1 s2.
Proof.
  intros Cons_case_hd Cons_case_tl.
  cofix; destruct s1; destruct s2; intro.
  generalize (Cons_case_hd _ _ H0); intros.
  simpl in H1.
  constructor; auto.
  apply stream_equiv_coind.
  apply (Cons_case_tl _ _ H0).
Qed.

Program Instance stream_equiv_Equivalence `{Setoid a} :
  Equivalence (@stream_equiv a _).
Next Obligation.
  repeat intro.
  apply stream_equiv_coind with (R:=fun s1 s2 => s1 = s2); intros; subst; auto.
  reflexivity.
Qed.
Next Obligation.
  repeat intro.
  eapply stream_equiv_coind
    with (R := fun s1 s2 => stream_equiv s2 s1); eauto; clear;
    intros s1 s2 H0.
  destruct H0; simpl; symmetry; eassumption.
  destruct H0; simpl; eassumption.
Qed.
Next Obligation.
  repeat intro.
  eapply stream_equiv_coind
    with (R := fun s1 s2 => exists s3, stream_equiv s1 s3 /\ stream_equiv s3 s2);
    eauto; clear; intros ? ? [s3 [H0 H1] ].
  - destruct H0; inversion H1; subst; simpl; etransitivity; eauto.
  - destruct H0; inversion H1; subst; simpl; eexists; eauto.
Qed.

Instance Stream_Setoid `{Setoid a} : Setoid (Stream a) := {
  equiv := stream_equiv;
  setoid_equiv := stream_equiv_Equivalence
}.

Program Instance Cons_Proper `{Setoid a} : Proper (equiv ==> equiv ==> equiv) Cons.
Next Obligation.
  repeat intro.
  cofix.
  simpl.
  now constructor.
Qed.

(* Program Fixpoint denote `(d : Stream a) : StreamS a *)
Fixpoint denote `(d : Stream a) (i : nat) : a :=
  match i, d with
  | O,    Cons x _  => x
  | S i', Cons _ xs => denote xs i'
  end.

(** Now we may show that this denotation is an algebra homomorphism
    for all algebras of interest. *)

Require Import FunctionalExtensionality.

Theorem denote_cons :
  forall a (x : a) s, denote (Cons x s) = cons x (denote s).
Proof.
  intros.
  extensionality i.
  now induction i.
Qed.

Theorem denote_uncons :
  forall a (x : a) s, (x, denote s) = uncons (denote (Cons x s)).
Proof.
  intros.
  unfold uncons; simpl.
  f_equal.
Qed.

Reserved Infix "⨂" (at level 12, right associativity).

Class Monoid (a : Type) `{Setoid a} := {
  mempty : a;
  mappend : a -> a -> a where "x ⨂ y" := (mappend x y);
  mempty_left : forall x, mempty ⨂ x ≈ x;
  mempty_right : forall x, x ⨂ mempty ≈ x;
  mappend_assoc : forall x y z, x ⨂ (y ⨂ z) ≈ (x ⨂ y) ⨂ z
}.

Infix "⨂" := mappend (at level 12, right associativity).

Program Instance Function_Monoid {a b} `{Monoid b} : Monoid (a -> b) := {
  mempty  := fun _ => mempty;
  mappend := fun x y a => x a ⨂ y a;
}.
Next Obligation. now rewrite mempty_left. Qed.
Next Obligation. now rewrite mempty_right. Qed.
Next Obligation. now rewrite mappend_assoc. Qed.

CoFixpoint empty_stream `{Monoid a} : Stream a := Cons mempty empty_stream.

CoFixpoint append_streams `{Monoid a} (x y : Stream a) : Stream a :=
  match x, y with
  | Cons x' xs, Cons y' ys => Cons (x' ⨂ y') (append_streams xs ys)
  end.

Lemma append_streams_empty_Cons `{Monoid a} (x : a) xs :
  append_streams empty_stream (Cons x xs) ≈ Cons x (append_streams empty_stream xs).
Proof.
  simpl.
  cofix.
  rewrite (frob_eq (append_streams _ _)).
  rewrite (frob_eq (Cons _ (append_streams _ _))).
  simpl.
  constructor.
    reflexivity.
  apply mempty_left.
Qed.

Lemma append_streams_mempty_left `{Monoid a} x:
  append_streams empty_stream x ≈ Cons (hd x) (append_streams empty_stream (tl x)).
Proof.
  simpl.
  destruct x.
  simpl.
  apply append_streams_empty_Cons.
Qed.

Lemma append_streams_Cons_empty `{Monoid a} (x : a) xs :
  append_streams (Cons x xs) empty_stream ≈ Cons x (append_streams xs empty_stream).
Proof.
  simpl.
  cofix.
  rewrite (frob_eq (append_streams _ _)).
  rewrite (frob_eq (Cons _ (append_streams _ _))).
  simpl.
  constructor.
    reflexivity.
  apply mempty_right.
Qed.

Lemma append_streams_mempty_right `{Monoid a} x:
  append_streams x empty_stream ≈ Cons (hd x) (append_streams (tl x) empty_stream).
Proof.
  simpl.
  destruct x.
  simpl.
  apply append_streams_Cons_empty.
Qed.

Program Instance Stream_Monoid `{Monoid a} : Monoid (Stream a) := {
  mempty  := empty_stream;
  mappend := append_streams
}.
Next Obligation.
  remember (append_streams _ _).
  eapply stream_equiv_coind
    with (R := fun s1 s2 => stream_equiv s1 (append_streams empty_stream s2)); eauto.
  - intros; simpl; inversion H1; subst; simpl.
    pose proof (append_streams_mempty_left s2).
    rewrite <- H2 in H4.
    simpl in H4.
    inversion H4; subst.
    etransitivity; eauto.
  - intros; simpl; inversion H1; subst; simpl.
    pose proof (append_streams_mempty_left s2).
    rewrite <- H2 in H4.
    simpl in H4.
    inversion H4; subst.
    etransitivity; eauto.
  - rewrite Heqs; reflexivity.
Qed.
Next Obligation.
  remember (append_streams _ _).
  eapply stream_equiv_coind
    with (R := fun s1 s2 => stream_equiv s1 (append_streams s2 empty_stream)); eauto.
  - intros; simpl; inversion H1; subst; simpl.
    pose proof (append_streams_mempty_right s2).
    rewrite <- H2 in H4.
    simpl in H4.
    inversion H4; subst.
    etransitivity; eauto.
  - intros; simpl; inversion H1; subst; simpl.
    pose proof (append_streams_mempty_right s2).
    rewrite <- H2 in H4.
    simpl in H4.
    inversion H4; subst.
    etransitivity; eauto.
  - rewrite Heqs; reflexivity.
Qed.
Next Obligation.
Admitted.

Theorem monoid_homomorphism_mempty `{Monoid a} :
  exists (H : Monoid (Stream a)), denote (a:=a) mempty ≈ mempty.
Proof.
Abort.


(*
        #####################################################
        ###  PLEASE DO NOT DISTRIBUTE SOLUTIONS PUBLICLY  ###
        #####################################################
*)
Require Import Coq.Strings.Ascii.
Require Import Coq.Lists.List.
From Turing Require Import Lang.
From Turing Require Import Util.
Import LangNotations.
Import ListNotations.
Import Lang.Examples.
Open Scope lang_scope.
Open Scope char_scope.

(* ---------------------------------------------------------------------------*)

(**

Show that any word that is in L4 is either empty or starts with "a".
 *)

Theorem ex1: forall w, L4 w -> w = [] \/ exists w', w = "a" :: w'.
Proof.
  intros.
  induction H.
  induction x.
  - left.
    destruct H as (x, (x0, (H, (H0, H1)))).
    inversion H0; inversion H1.
    rewrite H.
    rewrite <- H3.
    rewrite <- H4.
    reflexivity.
  - right.
    destruct H as (x0, (x1, (H, (H0, H1)))).
    inversion H0; inversion H1.
    exists (w2 ++ w0 ++ w4).
    unfold Char in H4.
    rewrite H, H10, H5, H4.
    clear.
    reflexivity.
Qed.

(**
Show that the following word is accepted by the given language.
 *)

Lemma b_in_b:
  Char "b" ["b"].
Proof.
  unfold Char.
  reflexivity.
Qed.

Lemma in_bb:
  In ["b"; "b"] (Pow (Char "b") 2).
Proof.
  unfold In.
  (* { a } *)
  apply pow_cons with (w1:=["b"]) (w2:=["b"]).
  - apply pow_cons with (w1:=["b"]) (w2:=[]).
      * apply pow_nil.
      * apply b_in_b.
      * reflexivity.
  - apply b_in_b.
  - reflexivity.
Qed.

Theorem ex2: In ["a"; "b"; "b"; "a"] ("a" >> "b" * >> "a").
Proof.
  unfold Star.
  unfold In.
  unfold App.
  exists ["a"; "b"; "b"], ["a"].
  split.
  - simpl. reflexivity.
  - split.
    -- exists ["a"], ["b";"b"]. split.
       { reflexivity. }
       { split. - reflexivity. - exists 2. apply in_bb. }
    -- reflexivity.
Qed.

(**
Show that the following word is rejected by the given language.
 *)

Theorem ex3: ~ In ["b"; "b"] ("a" >> "b" * >> "a").
Proof.
  unfold not.
  intros.
  unfold In, App in H.
  destruct H as (w1, (w2, H)).
  destruct H as (H1, (H2, H3)).
  destruct H2 as (H4, (H5, H6)).
  destruct H6.
  destruct H0.
  unfold Char in H0.
  subst.
  inversion H1.
Qed.

(**
Show that the following language is empty.
 *)
Theorem ex4: "0" * >> {} == {}.
Proof.

  Search(_ >> {}).
  apply app_r_void_rw.
Qed.

(**
Rearrange the following terms. Hint use the distribution and absorption laws.
 *)

Theorem ex5: ("0" U Nil) >> ( "1" * ) == ( "0" >> "1" * ) U ( "1" * ).
Proof.
  unfold Equiv.
  split.
  - intros.
    Search(_ >>_ U {}).
    rewrite <- app_union_distr_l in H.
    Search(Nil >> _).
    rewrite app_l_nil_rw in H.
    apply H.
  - intros.
    Search(_ >> _).
    rewrite <- app_union_distr_l.
    rewrite app_l_nil_rw.
    apply H.
Qed.

(**
Show that the following langue only accepts two words.
 *)
Theorem ex6: ("0" >> "1" U "1" >> "0") == fun w => (w = ["0"; "1"] \/ w = ["1"; "0"]).
Proof.
  unfold Equiv.
  split; intros.
  - unfold Union.
    unfold In.
    destruct H. destruct H as (x, (x0, H)).
    * left.
      destruct H.
      rewrite H.
      inversion H0.
      unfold Char.
      rewrite H1.
      rewrite H2.
      reflexivity.
    * right.
      destruct H as (x, (x0, (H, (H0, H1)))).
      unfold Char in *.
      rewrite H, H0, H1.
      reflexivity.
  - unfold In.
    unfold Union.
    unfold App in *.
    destruct H.
    * left.
      exists ["0"], ["1"].
      split.
       + rewrite H.
         reflexivity.
       + split.
          { unfold Char; reflexivity.
          }
          { unfold Char; reflexivity.
          }
    * unfold In, Union, App. right. exists ["1"], ["0"].
      split.
       + rewrite H.
         reflexivity.
       + split.
         -- unfold Char; reflexivity.
         -- unfold Char; reflexivity.
Qed.

Theorem ex7: "b" >> ("a" U "b" U Nil) * >> Nil == "b" >> ("b" U "a") *.
Proof.
  split; intros.
  - rewrite app_r_nil_rw in H.
    rewrite union_sym_rw in H.
    rewrite star_union_nil_rw in H.
    rewrite union_sym_rw.
    apply H.
  - rewrite app_r_nil_rw.
    rewrite union_sym_rw.
    rewrite star_union_nil_rw.
    rewrite union_sym_rw in H.
    apply H.
Qed.

Theorem ex8: (("b" >> ("a" U {}) ) U (Nil >> {} >> "c")* ) * == ("b" >> "a") *.
Proof.
  split; intros.
  - Search(_ U {}).
    rewrite union_r_void_rw in H.
    Search(_ >> {}).
    rewrite app_r_void_rw in H.
    Search({} >> _).
    rewrite app_l_void_rw in H.
    Search(_ *).
    rewrite star_void_rw in H.
    rewrite union_sym_rw in H.
    rewrite star_union_nil_rw in H.
    apply H.
  - Search(_ U {}).
    rewrite union_r_void_rw.
    Search(_ >> {}).
    rewrite app_r_void_rw.
    rewrite app_l_void_rw.
    Search(_ *).
    rewrite star_void_rw.
    rewrite union_sym_rw.
    rewrite star_union_nil_rw.
    apply H.
Qed.


Set Implicit Arguments.
Set Primitive Projections.

Polymorphic Inductive eqp A (x : A) : A -> Type := eqp_refl : eqp x x.
Monomorphic Inductive eqm A (x : A) : A -> Type := eqm_refl : eqm x x.

Polymorphic Record prodp (A B : Type) : Type := pairp { fstp : A; sndp : B }.
Monomorphic Record prodm (A B : Type) : Type := pairm { fstm : A; sndm : B }.

Check eqm_refl _ : eqm (fun x : prodm Set Set => pairm (fstm x) (sndm x)) (fun x => x). (* success *)
Check eqp_refl _ : eqp (fun x : prodm Set Set => pairm (fstm x) (sndm x)) (fun x => x). (* success *)
Check eqm_refl _ : eqm (fun x : prodp Set Set => pairp (fstp x) (sndp x)) (fun x => x). (* Error:
The term
 "eqm_refl (fun x : prodp Set Set => {| fstp := fstp x; sndp := sndp x |})"
has type
 "eqm (fun x : prodp Set Set => {| fstp := fstp x; sndp := sndp x |})
    (fun x : prodp Set Set => {| fstp := fstp x; sndp := sndp x |})"
while it is expected to have type
 "eqm (fun x : prodp Set Set => {| fstp := fstp x; sndp := sndp x |})
    (fun x : prodp Set Set => x)". *)
Check eqp_refl _ : eqp (fun x : prodp Set Set => pairp (fstp x) (sndp x)) (fun x => x). (* Error:
The term
 "eqp_refl (fun x : prodp Set Set => {| fstp := fstp x; sndp := sndp x |})"
has type
 "eqp (fun x : prodp Set Set => {| fstp := fstp x; sndp := sndp x |})
    (fun x : prodp Set Set => {| fstp := fstp x; sndp := sndp x |})"
while it is expected to have type
 "eqp (fun x : prodp Set Set => {| fstp := fstp x; sndp := sndp x |})
    (fun x : prodp Set Set => x)". *)


(* categories: cones and limits *)

Set Universe Polymorphism.
Require Import Utf8.
Require Import category.

(* A cone to a functor D(J,C) consists of an object c in C and a
   family of arrows in C : cj : c → Dj one for each object j ∈ J, such
   that for each arrow α : i → j in J, the following triangle
   commutes. *)

Record cone {J C} (D : functor J C) :=
  { cn_top : Ob C;
    cn_fam : ∀ j, Hom cn_top (f_obj D j);
    cn_commute : ∀ i j (α : Hom i j), cn_fam j = f_hom D α ◦ cn_fam i }.

Record co_cone {J C} (D : functor J C) :=
  { cc_top : Ob C;
    cc_fam : ∀ j, Hom (f_obj D j) cc_top;
    cc_commute : ∀ i j (α : Hom i j), cc_fam i = cc_fam j ◦ f_hom D α }.

Arguments cn_top [_] [_] [_].
Arguments cn_fam [_] [_] [_].
Arguments cn_commute [_] [_] [_].
Arguments cc_top [_] [_] [_].
Arguments cc_fam [_] [_] [_].
Arguments cc_commute [_] [_] [_].
Arguments cone _ _ D%Fun.
Arguments co_cone _ _ D%Fun.

(* category of cones & co-cones *)

Definition Cone_Hom {J C} {D : functor J C} (cn cn' : cone D) :=
  { ϑ : Hom (cn_top cn) (cn_top cn') & ∀ j, cn_fam cn j = cn_fam cn' j ◦ ϑ }.

Definition CoCone_Hom {J C} {D : functor J C} (cc cc' : co_cone D) :=
  { ϑ : Hom (cc_top cc) (cc_top cc') & ∀ j, cc_fam cc' j = ϑ ◦ cc_fam cc j }.

Definition cnh_hom {J C} {D : functor J C} {cn cn'}
  (cnh : Cone_Hom cn cn') := projT1 cnh.
Definition cnh_commute {J C} {D : functor J C} {cn cn'}
  (cnh : Cone_Hom cn cn') := projT2 cnh.
Definition cch_hom {J C} {D : functor J C} {cc cc'}
  (cch : CoCone_Hom cc cc') := projT1 cch.
Definition cch_commute {J C} {D : functor J C} {cc cc'}
  (cch : CoCone_Hom cc cc') := projT2 cch.

Definition Cone_comp {J C} {D : functor J C} {c c' c'' : cone D}
  (f : Cone_Hom c c') (g : Cone_Hom c' c'') : Cone_Hom c c''.
Proof.
exists (cnh_hom g ◦ cnh_hom f).
intros j.
etransitivity.
-apply (cnh_commute f j).
-etransitivity; [ | apply assoc ].
 f_equal.
 apply (cnh_commute g j).
Defined.

Definition CoCone_comp {J C} {D : functor J C} {c c' c'' : co_cone D}
  (f : CoCone_Hom c c') (g : CoCone_Hom c' c'') : CoCone_Hom c c''.
Proof.
exists (cch_hom g ◦ cch_hom f).
intros j.
etransitivity.
-apply (cch_commute g j).
-etransitivity; [ | symmetry; apply assoc ].
 f_equal.
 apply (cch_commute f j).
Defined.

Definition Cone_id {J C} {D : functor J C} (c : cone D) : Cone_Hom c c :=
   existT (λ ϑ, ∀ j, cn_fam c j = cn_fam c j ◦ ϑ) (idc (cn_top c))
     (λ j, eq_sym (unit_l (cn_fam c j))).

Definition CoCone_id {J C} {D : functor J C} (c : co_cone D) : CoCone_Hom c c :=
   existT (λ ϑ, ∀ j, cc_fam c j = ϑ ◦ cc_fam c j) (idc (cc_top c))
     (λ j, eq_sym (unit_r (cc_fam c j))).

Theorem Cone_unit_l {J C} {D : functor J C} :
  ∀ (c c' : cone D) (f : Cone_Hom c c'),
  Cone_comp (Cone_id c) f = f.
Proof.
intros.
unfold Cone_comp; cbn.
destruct f as (f & Hf); cbn.
apply eq_existT_uncurried.
exists (unit_l _).
apply fun_ext.
intros j.
apply Hom_set.
Defined.

Theorem CoCone_unit_l {J C} {D : functor J C} :
  ∀ (c c' : co_cone D) (f : CoCone_Hom c c'),
  CoCone_comp (CoCone_id c) f = f.
Proof.
intros.
unfold CoCone_comp; cbn.
destruct f as (f & Hf); cbn.
apply eq_existT_uncurried.
exists (unit_l _).
apply fun_ext.
intros j.
apply Hom_set.
Defined.

Theorem Cone_unit_r {J C} {D : functor J C} :
  ∀ (c c' : cone D) (f : Cone_Hom c c'),
  Cone_comp f (Cone_id c') = f.
Proof.
intros.
unfold Cone_comp; cbn.
destruct f as (f & Hf); cbn.
apply eq_existT_uncurried.
exists (unit_r _).
apply fun_ext.
intros j.
apply Hom_set.
Defined.

Theorem CoCone_unit_r {J C} {D : functor J C} :
  ∀ (c c' : co_cone D) (f : CoCone_Hom c c'),
  CoCone_comp f (CoCone_id c') = f.
Proof.
intros.
destruct f as (f & Hf); cbn.
apply eq_existT_uncurried.
exists (unit_r _).
apply fun_ext.
intros j.
apply Hom_set.
Defined.

Theorem Cone_assoc {J C} {D : functor J C} :
  ∀ (c c' c'' c''' : cone D) (f : Cone_Hom c c') (g : Cone_Hom c' c'')
    (h : Cone_Hom c'' c'''),
    Cone_comp f (Cone_comp g h) = Cone_comp (Cone_comp f g) h.
Proof.
intros.
unfold Cone_comp; cbn.
apply eq_existT_uncurried.
exists (assoc _ _ _).
apply fun_ext.
intros j.
apply Hom_set.
Defined.

Theorem CoCone_assoc {J C} {D : functor J C} :
  ∀ (c c' c'' c''' : co_cone D) (f : CoCone_Hom c c') (g : CoCone_Hom c' c'')
    (h : CoCone_Hom c'' c'''),
    CoCone_comp f (CoCone_comp g h) = CoCone_comp (CoCone_comp f g) h.
Proof.
intros.
apply eq_existT_uncurried.
exists (assoc _ _ _).
apply fun_ext.
intros j.
apply Hom_set.
Defined.

Theorem Cone_Hom_set {J C} {D : functor J C} :
  ∀ c c' : cone D, isSet (Cone_Hom c c').
Proof.
intros.
unfold Cone_Hom.
apply h4c.isSet_isSet_sigT; [ | apply Hom_set ].
intros f.
intros p q.
apply fun_ext.
intros x.
apply Hom_set.
Qed.

Theorem CoCone_Hom_set {J C} {D : functor J C} :
  ∀ c c' : co_cone D, isSet (CoCone_Hom c c').
Proof.
intros.
unfold CoCone_Hom.
apply h4c.isSet_isSet_sigT; [ | apply Hom_set ].
intros f.
intros p q.
apply fun_ext.
intros x.
apply Hom_set.
Qed.

Definition ConeCat {J C} (D : functor J C) :=
  {| Ob := cone D;
     Hom := Cone_Hom;
     comp _ _ _ := Cone_comp;
     idc := Cone_id;
     unit_l := Cone_unit_l;
     unit_r := Cone_unit_r;
     assoc := Cone_assoc;
     Hom_set := Cone_Hom_set |}.

Definition CoConeCat {J C} (D : functor J C) :=
  {| Ob := co_cone D;
     Hom := CoCone_Hom;
     comp _ _ _ := CoCone_comp;
     idc := CoCone_id;
     unit_l := CoCone_unit_l;
     unit_r := CoCone_unit_r;
     assoc := CoCone_assoc;
     Hom_set := CoCone_Hom_set |}.

(* A limit for a functor D : J → C is a terminal object in Cone(D)
   and a colimit an initial object in CoCone(D) *)

Definition is_limit {J C} {D : functor J C} (cn : cone D) :=
  @is_terminal (ConeCat D) cn.

Definition is_colimit {J C} {D : functor J C} (cc : co_cone D) :=
  @is_initial (CoConeCat D) cc.

(* Spelling out the definition, the limit of a diagram D has the
   following UMP: given any cone (C, cj) to D, there is a unique
   arrow u : C → lim←−j Dj such that for all j,
     pj ◦ u = cj .
*)

Theorem limit_UMP {J C} {D : functor J C} :
  ∀ l : cone D, is_limit l →
  ∀ c : cone D, ∃! u, ∀ j, cn_fam l j ◦ u = cn_fam c j.
Proof.
intros * Hlim c.
unfold unique.
unfold is_limit in Hlim.
unfold is_terminal in Hlim.
specialize (Hlim c) as H1.
destruct H1 as (f, H1).
exists (cnh_hom f).
split. {
  intros j.
  destruct f as (f, Hf).
  now symmetry.
}
intros h Hh.
assert (Hh' : ∀ j : Ob J, cn_fam c j = cn_fam l j ◦ h). {
  intros j; specialize (Hh j).
  now symmetry.
}
remember
  (existT
     (λ ϑ : Hom (cn_top c) (cn_top l),
      ∀ j : Ob J, cn_fam c j = cn_fam l j ◦ ϑ) h Hh') as hh.
now rewrite (H1 hh); subst hh.
Qed.

(* another definition of category of co-cones *)

Definition CoConeCat2 {J C} (D : functor J C) := op (ConeCat (fop D)).

Definition cone_fop_of_co_cone {J C} {D : functor J C} :
    co_cone D → cone (fop D) :=
  λ cc,
  {| cn_top := cc_top cc : Ob (op C);
     cn_fam j := cc_fam cc j : @Hom (op C) (cc_top cc) (f_obj (fop D) j);
     cn_commute i j := cc_commute cc j i |}.

Definition co_cone_of_cone_fop {J C} {D : functor J C} :
    cone (fop D) → co_cone D :=
  λ cn,
  {| cc_top := cn_top cn : Ob C;
     cc_fam j := cn_fam cn j : @Hom (op C) (cn_top cn) (f_obj D j);
     cc_commute i j := cn_commute cn j i |}.

Definition F_CoConeCat_CoConeCat2_comp_prop {J C} {D : functor J C}
  {x y z : Ob (CoConeCat D)} :
  ∀ (f : Hom x y) (g : Hom y z),
   g ◦ f =
   @comp (CoConeCat2 D) (cone_fop_of_co_cone x) (cone_fop_of_co_cone y)
       (cone_fop_of_co_cone z) f g.
Proof.
intros; cbn.
apply eq_existT_uncurried; cbn.
exists eq_refl; cbn.
apply fun_ext.
intros j.
apply Hom_set.
Defined.

Definition F_CoConeCat2_CoConeCat_comp_prop {J C} {D : functor J C}
  {x y z : Ob (CoConeCat2 D)} :
  ∀ (f : Hom x y) (g : Hom y z),
  g ◦ f =
  @comp (CoConeCat D) (co_cone_of_cone_fop x) (co_cone_of_cone_fop y)
        (co_cone_of_cone_fop z) f g.
Proof.
intros; cbn.
apply eq_existT_uncurried; cbn.
exists eq_refl; cbn.
apply fun_ext.
intros j.
apply Hom_set.
Defined.

Definition F_CoConeCat_CoConeCat2 {J C} {D : functor J C} :
    functor (CoConeCat D) (CoConeCat2 D) :=
  {| f_obj :=
       cone_fop_of_co_cone : Ob (CoConeCat D) → Ob (CoConeCat2 D);
     f_hom _ _ f := f;
     f_comp_prop _ _ _ := F_CoConeCat_CoConeCat2_comp_prop;
     f_id_prop _ := eq_refl |}.

Definition F_CoConeCat2_CoConeCat {J C} {D : functor J C} :
    functor (CoConeCat2 D) (CoConeCat D) :=
  {| f_obj :=
       co_cone_of_cone_fop : Ob (CoConeCat2 D) → Ob (CoConeCat D);
     f_hom _ _ f := f;
     f_comp_prop _ _ _ := F_CoConeCat2_CoConeCat_comp_prop;
     f_id_prop _ := eq_refl |}.

Theorem F_CoConeCat_CoConeCat2_id {J C} {D : functor J C} :
  ∀ cc,
  f_obj F_CoConeCat2_CoConeCat (f_obj F_CoConeCat_CoConeCat2 cc) = cc.
Proof. now intros; destruct cc. Defined.

Theorem F_CoConeCat2_CoConeCat_id {J C} {D : functor J C} :
  ∀ cc,
  f_obj F_CoConeCat_CoConeCat2 (f_obj F_CoConeCat2_CoConeCat cc) = cc.
Proof. now intros; destruct cc. Defined.

Theorem CoConeCat_CoConeCat2_iso J C {D : functor J C} :
  are_isomorphic_categories (CoConeCat D) (CoConeCat2 D).
Proof.
exists F_CoConeCat_CoConeCat2.
exists F_CoConeCat2_CoConeCat.
exists F_CoConeCat_CoConeCat2_id.
exists F_CoConeCat2_CoConeCat_id.
split.
-now intros; destruct x, y.
-now intros; destruct x, y.
Qed.

(* cone image by a functor *)

Definition cone_image_fam {J C D} {X : functor J C} {cn : cone X}
    (F : functor C D) (j : Ob J) :
    Hom (f_obj F (cn_top cn)) (f_obj (F ◦ X) j) :=
  f_hom F (cn_fam cn j).

Theorem cone_image_commute {J C D} {X : functor J C} (F : functor C D)
    {cn : cone X} (i j : Ob J) (f : Hom i j) :
  f_hom F (cn_fam cn j) =
  f_hom (F ◦ X)%Fun f ◦ f_hom F (cn_fam cn i).
Proof.
cbn.
rewrite (cn_commute cn i j f).
apply f_comp_prop.
Qed.

Definition cone_image {J C D} {X : functor J C} (F : functor C D) :
    cone X → cone (F ◦ X) :=
  λ cn,
  {| cn_top := f_obj F (cn_top cn);
     cn_fam := cone_image_fam F;
     cn_commute := cone_image_commute F |}.

(* hom-functor preserves limits *)
(* https://ncatlab.org/nlab/show/hom-functor+preserves+limits *)

(* failed to understand and prove id

(*
   let X• : ℐ⟶𝒞 be a diagram. Then:
   1. If the limit lim_←i Xi exists in 𝒞 then for all Y ∈ 𝒞
      there is a natural isomorphism
        Hom_𝒞(Y,lim_←i Xi) ≃ lim_←i (Hom_𝒞(Y,Xi)),
      where on the right we have the limit over the diagram of
      hom-sets given by
        Hom_𝒞(Y,−) ∘ X : ℐ −(X)→ 𝒞 −(Hom_𝒞(Y,−))→ Set.
*)

(* this "hom_functor Y (cn_top c)", a functor is supposed to be isomorphic
   to .... something *)
Check
  (λ J C (X_ : functor J C) (Y : Ob C) (c : cone X_) (p : is_limit c),
   hom_functor Y (cn_top c)).
(* → functor (op C × C) SetCat *)
(* ... to? *)
Check
  (λ J C (X_ : functor J C) (Y : Ob C),
   (cov_hom_functor Y ◦ X_)%Fun).
(* → functor J SetCat *)

(* functors not of the same type! *)

Check @is_natural_isomorphism.

Theorem hom_functor_preserves_limit {C} :
  ∀ J (X_ : functor J C) (lim_i_Xi : cone X_),
  is_limit lim_i_Xi →
  ∀ (Y : Ob C) lim_i_Hom_C_Y_Xi,
  @is_natural_isomorphism _ _
    (hom_functor Y (cn_top lim_i_Xi))
    (cov_hom_functor Y ◦ X_)%Fun.
...
  ∀ Y (cn' : cone (cov_hom_functor Y ◦ X_)), is_limit cn'.
Proof.
intros * Hlim *.
(* "First observe that, by the very definition of limiting cones,
    maps out of some Y into them are in natural bijection with
    the set Cones(Y,X•) of cones over the diagram X• with tip Y:
       Hom(Y,lim⟵i Xi)≃Cones(Y,X•).
   " *)
(* ah bon *)
...

Theorem hom_functor_preserves_limit {C} (A B : Ob C)
    (F := hom_functor A B) :
  ∀ J (X : functor J (op C × C)) (cn : cone X),
  is_limit cn → is_limit (cone_image F cn).
...

(* RAPL : Right Adjoint Preserves Limit *)
(* https://ncatlab.org/nlab/show/adjoints+preserve+%28co-%29limits *)

Theorem RAPL {C D} (L : functor C D) (R : functor D C) :
  L ⊣ R →
  ∀ J (X : functor J D) (cn : cone X),
  is_limit cn → is_limit (cone_image R cn).
Proof.
intros HLR * Hlim.
unfold is_limit, is_terminal in Hlim |-*.
cbn in Hlim |-*.
intros cn'; move cn' before cn.
specialize (Hlim cn) as H1.
destruct H1 as (cn1 & Hcn1).
destruct HLR as (η & ε & H1 & H2).
...
Check @hom_functor.
Print cone.

Theorem lim_hom_fun {J C D} (E : functor J C) (F : functor C D) (X : Ob C) (j : Ob J) (cn : cone E) :
  hom_functor X (cn_fam cn j).
...
*)


(* This is a demo of developing a cancellation algorithm for
 * commutative monoids.
 *)
Require Import MirrorCore.ExprI.
Require Import MirrorCore.TypesI.
Require Import MirrorCore.SymI.
Require MirrorCore.syms.SymEnv.
Require MirrorCore.syms.SymSum.
Require Import MirrorCore.RTac.RTac.
Require Import MirrorCore.Lambda.Expr.
Require Import MirrorCore.Lambda.Rtac.
Require Import MirrorCore.Reify.Reify.

Require Import McExamples.Cancel.Monoid.
Require McExamples.Cancel.MonoidSyntaxSimple.
Require McExamples.Cancel.MonoidSyntaxNoDec.
Require McExamples.Cancel.MonoidSyntaxWithConst.
Require McExamples.Cancel.MonoidSyntaxModular.

Set Implicit Arguments.
Set Strict Implicit.

Module MonoidCancel (M : Monoid).

  (* Import the syntactic language *)
  Module Syntax := MonoidSyntaxModular.Syntax M.
  Import Syntax.

Set Printing All.

  (* The Core Monoid Lemmas *)
  Definition lem_plus_unit_c : Lemma.lemma typ (expr typ func) (expr typ func)
  := <:: M.plus_unit_c ::>.
  Definition lem_plus_assoc_c1 : Lemma.lemma typ (expr typ func) (expr typ func)
  := <:: M.plus_assoc_c1 ::>.
  Definition lem_plus_assoc_c2 : Lemma.lemma typ (expr typ func) (expr typ func)
  := <:: M.plus_assoc_c2 ::>.
  Definition lem_plus_comm_c : Lemma.lemma typ (expr typ func) (expr typ func)
  := <:: M.plus_comm_c ::>.
  Definition lem_plus_cancel : Lemma.lemma typ (expr typ func) (expr typ func)
  := <:: M.plus_cancel ::>.
  Definition lem_plus_unit_p : Lemma.lemma typ (expr typ func) (expr typ func)
  := <:: M.plus_unit_p ::>.
  Definition lem_plus_assoc_p1 : Lemma.lemma typ (expr typ func) (expr typ func)
  := <:: M.plus_assoc_p1 ::>.
  Definition lem_plus_assoc_p2 : Lemma.lemma typ (expr typ func) (expr typ func)
  := <:: M.plus_assoc_p2 ::>.
  Definition lem_plus_comm_p : Lemma.lemma typ (expr typ func) (expr typ func)
  := <:: M.plus_comm_p ::>.

  Definition lem_refl : Lemma.lemma typ (expr typ func) (expr typ func)
  := <:: M.refl ::>.

  (* Write the automation *)
  Section with_solver.
    Variable fs : @SymEnv.functions typ _.
    Let RSym_func := RSym_func fs.
    Local Existing Instance RSym_func.
    Let Expr_expr := @Expr.Expr_expr typ func RType_typ _ _.
    Local Existing Instance Expr_expr.

    Let ExprOk_expr : ExprOk Expr_expr :=
      @ExprOk_expr typ func _ _ _ _ Typ2Ok_tyArr _.
    Local Existing Instance ExprOk_expr.

    Instance RL_lem_plus_unit_c : ReifiedLemma lem_plus_unit_c :=
    { ReifiedLemma_proof := M.plus_unit_c }.
    Instance RL_lem_plus_assoc_c1 : ReifiedLemma lem_plus_assoc_c1 :=
    { ReifiedLemma_proof := M.plus_assoc_c1 }.
    Instance RL_lem_plus_assoc_c2 : ReifiedLemma lem_plus_assoc_c2 :=
    { ReifiedLemma_proof := M.plus_assoc_c2 }.
    Instance RL_lem_plus_comm_c : ReifiedLemma lem_plus_comm_c :=
    { ReifiedLemma_proof := M.plus_comm_c }.
    Instance RL_lem_plus_cancel : ReifiedLemma lem_plus_cancel :=
    { ReifiedLemma_proof := M.plus_cancel }.
    Instance RL_lem_plus_unit_p : ReifiedLemma lem_plus_unit_p :=
    { ReifiedLemma_proof := M.plus_unit_p }.
    Instance RL_lem_plus_assoc_p1 : ReifiedLemma lem_plus_assoc_p1 :=
    { ReifiedLemma_proof := M.plus_assoc_p1 }.
    Instance RL_lem_plus_assoc_p2 : ReifiedLemma lem_plus_assoc_p2 :=
    { ReifiedLemma_proof := M.plus_assoc_p2 }.
    Instance RL_lem_plus_comm_p : ReifiedLemma lem_plus_comm_p :=
    { ReifiedLemma_proof := M.plus_comm_p }.
    Instance RL_lem_refl : ReifiedLemma lem_refl :=
    { ReifiedLemma_proof := M.refl }.

    Variable solver : rtac typ (expr typ func).
    Hypothesis solver_ok : RtacSound solver.

    Definition iter_right (n : nat) : rtac typ (expr typ func) :=
      REC n (fun rec =>
               FIRST [ EAPPLY lem_plus_unit_c
                     | EAPPLY lem_plus_assoc_c1 ;; ON_ALL rec
                     | EAPPLY lem_plus_assoc_c2 ;; ON_ALL rec
                     | EAPPLY lem_plus_cancel ;;
                              ON_EACH [ SOLVE solver | IDTAC ]
            ])
          IDTAC.

    Instance iter_right_sound {Q} : RtacSound (iter_right Q).
    Proof.
      unfold iter_right; rtac_derive_soundness_default.
    Qed.

    Section afterwards.
      Variable k : rtac typ (expr typ func).
      Definition iter_left (n : nat) : rtac typ (expr typ func) :=
        REC n (fun rec =>
                 FIRST [ EAPPLY lem_plus_unit_p
                       | EAPPLY lem_plus_assoc_p1 ;; ON_ALL rec
                       | EAPPLY lem_plus_assoc_p2 ;; ON_ALL rec
                       | k
              ])
            IDTAC.

      Hypothesis k_sound : RtacSound k.

      Lemma iter_left_sound : forall Q, RtacSound (iter_left Q).
      Proof. unfold iter_left; rtac_derive_soundness_default. Qed.
    End afterwards.
    Local Existing Instance iter_left_sound.

    Definition cancel' (n m : nat) : rtac typ (expr typ func) :=
      let k :=
          FIRST [ EAPPLY lem_plus_comm_c ;; ON_ALL (iter_right m)
                | iter_right m
                ]
      in
      FIRST [ iter_left k n
            | EAPPLY lem_plus_comm_p ;; ON_ALL (iter_left k n)
            ].

    Local Instance cancel'_sound : forall P Q, RtacSound (cancel' P Q).
    Proof.
      cbv beta delta [ cancel' ]; rtac_derive_soundness_default.
    Qed.

    Fixpoint size (e : expr typ func) : nat :=
      match e with
      | App (App _ x) y => size x + size y
      | _ => 1
      end.

    Definition cancel : rtac typ (expr typ func) :=
      AT_GOAL (fun _ _ e =>
                 let fuel := size e in
                 REPEAT fuel
                        (FIRST [ SOLVE solver
                               | (cancel' fuel fuel ;; ON_ALL (TRY solver)) ;; MINIFY
              ])).

    Theorem cancel_sound : RtacSound cancel.
    Proof.
      unfold cancel.
      rtac_derive_soundness_default; eauto with typeclass_instances.
    Qed.

  End with_solver.

  Local Existing Instance cancel_sound.
  Local Existing Instance RL_lem_refl.

  Definition the_Expr fs := (@Expr.Expr_expr typ func _ _ (RSym_func fs)).

  Definition the_tactic fs :=
    @cancel fs (EAPPLY (RSym_sym:=RSym_func fs) lem_refl).

  Theorem the_tactic_sound fs : rtac_sound (Expr_expr:=the_Expr fs) (the_tactic fs).
  Proof.
    unfold the_tactic.
    intros. eapply cancel_sound; eauto with typeclass_instances.
  Qed.

  Ltac rtac_canceler :=
    lazymatch goal with
    | |- ?trm =>
      let k tbl e :=
          let result := constr:(@Interface.runRtac typ (expr typ func) nil nil e (the_tactic tbl)) in
          let resultV := eval vm_compute in result in
          match resultV with
          | Solved _ =>
            change (@env_propD _ _ _ Typ0_tyProp (the_Expr tbl) nil nil e) ;
              cut (result = resultV) ;
              [ set (pf := @Interface.rtac_Solved_closed_soundness
                             _ _ _ _ _ _ (the_tactic_sound tbl)
                             nil nil e) ;
                exact pf
              | vm_cast_no_check (@eq_refl _ resultV) ]
          end
      in
      reify_expr_bind reify_monoid k
                      [[ (fun x : @mk_dvar_map _ _ _ typD table_terms (@SymEnv.F typ _) => True) ]]
                      [[ trm ]]
  end.

  Module Demo.
    Axiom N : nat -> M.M.

    Fixpoint build_plusL n : M.M :=
      match n with
      | 0 => N 0
      | S n' => M.P (N n) (build_plusL n')
      end.

    Fixpoint build_plusR n : M.M :=
      match n with
      | 0 => N 0
      | S n' => M.P (build_plusR n') (N n)
      end.

    Definition goal n := M.R (build_plusL n) (build_plusR n).

    Ltac prep := unfold goal, build_plusL, build_plusR.

    Theorem test1 : goal 120.
      prep.
      Time rtac_canceler.
    Time Qed.
    Print Assumptions test1.
  End Demo.

End MonoidCancel.


From HoTT Require Import Basics Types Algebra.Rings Spaces.Nat.
From HoTT Require Import Colimits.Quotient.
Require Import Invertible.
Require Import RingsExtra.

Local Open Scope nat_scope.
Local Open Scope mc_scope.

(** * Localization of rings *)

(** ** Multiplicative subsets *)

(** *** Definitions *)

(** Multiplicative subsets of a ring [R] consist of: *)
Class IsMultiplicativeSubset {R : CRing} (S : R -> Type) : Type := {
  (** Being a hprop *)
  mss_ishprop : forall x, IsHProp (S x) ;
  (** Contains one *)
  mss_one : S 1 ;
  (** Closed under multiplication *)
  mss_mult : forall x y, S x -> S y -> S (x * y) ;
}.

Arguments mss_one {R _ _}.
Arguments mss_mult {R _ _ _ _}.

(** *** Examples *)

(** The multplicative subset of powers of a ring element. *)
Global Instance ismultiplicative_powers (R : CRing) (x : R)
  : IsMultiplicativeSubset (fun r => hexists (fun n : nat => rng_power x n = r)).
Proof.
  srapply Build_IsMultiplicativeSubset.
  1: by apply tr; exists 0%nat.
  intros a b np mq.
  strip_truncations.
  destruct np as [n p], mq as [m q].
  apply tr; exists (n + m)%nat.
  refine ((rng_power_mult_law _ _ _)^ @ _).
  f_ap.
Defined.

(** Invertible elements of a ring form a multiplicative subset. *)
Global Instance ismultiplicative_isinvertible (R : CRing)
  : IsMultiplicativeSubset (@IsInvertible R) := {}.

(** TODO: Property of being a localization. *)

(** ** Construction of localization. *)

Section Localization.

  (** We now construct the localization of a ring at a multiplicative subset as the following HIT:

  HIT Localization_type (R : CRing) (S : R -> Type)
    `{IsMultiplicativeSubset R} :=
  | loc_frac (n d : R) (p : S d) : Localization R S
  | loc_frac_eq (n1 d1 n2 d2 : R) (p1 : S d1) (p2 : S d2)
      (x : R) (q : S x) (r : x * (d2 * n1 - n2 * d1) = 0)
      : loc_frac n1 d1 p1 = loc_frac n2 d2 p2
  .
  *)

  Context (R : CRing) (S : R -> Type) `{!IsMultiplicativeSubset S}.

  (** *** Construction of underlying Localization type *)

  Record Fraction := {
    numerator : R ;
    denominator : R ;
    in_mult_subset_denominator : S denominator ;
  }.

  Definition fraction_eq : Relation Fraction.
  Proof.
    intros [n1 d1 ?] [n2 d2 ?].
    refine (exists (x : R), S x /\ _).
    exact (x * (n1 * d2 - n2 * d1) = 0).
  Defined.

  (** It is convenient to produce elements of this relation specalised to when the scaling factor is 1 *)
  Lemma fraction_eq_simple f1 f2
    (p : numerator f1 * denominator f2 = numerator f2 * denominator f1)
    : fraction_eq f1 f2.
  Proof.
    exists 1.
    refine (mss_one ,_).
    refine (rng_mult_one_l _ @ _).
    by apply rng_moveL_0M^-1.
  Defined.

  Lemma fraction_eq_refl f1 : fraction_eq f1 f1.
  Proof.
    apply fraction_eq_simple.
    reflexivity.
  Defined.

  Definition Localization_type : Type := Quotient fraction_eq.

  Definition loc_frac : Fraction -> Localization_type
    := class_of fraction_eq.

  Definition loc_frac_eq {f1 f2 : Fraction} (p : fraction_eq f1 f2)
    : loc_frac f1 = loc_frac f2
    := qglue p.

  Definition Localization_type_ind (Q : Localization_type -> Type)
    `{forall x, IsHSet (Q x)}
    (frac : forall f, Q (loc_frac f))
    (eq : forall f1 f2 p, loc_frac_eq p # frac f1 = frac f2)
    : forall x, Q x
    := Quotient_ind _ Q frac eq.

  Definition Localization_type_ind_hprop (Q : Localization_type -> Type)
    `{forall x, IsHProp (Q x)} (f : forall f, Q (loc_frac f))
    : forall x, Q x
    := Quotient_ind_hprop _ Q f.

  Definition Localization_type_rec (Q : Type) `{IsHSet Q}
    (f : Fraction -> Q)
    (t : forall f1 f2, fraction_eq f1 f2 -> f f1 = f f2)
    : Localization_type -> Q
    := Quotient_rec _ Q f t.

  Arguments loc_frac : simpl never.
  Arguments loc_frac_eq : simpl never.

  (** Now that we have defined the HIT as above, we can define the ring structure. *)

  (** *** Addition operation *)

  (** Fraction addition *)
  Definition frac_add : Fraction -> Fraction -> Fraction :=
    fun '(Build_Fraction n1 d1 p1) '(Build_Fraction n2 d2 p2)
      => Build_Fraction (n1 * d2 + n2 * d1) (d1 * d2) (mss_mult p1 p2).

  (** Fraction addition is well-defined upto equality of fractions. *)

  (** It is easier to prove well-definedness of both arguments at once. *)
  Lemma frac_add_wd (f1 f1' f2 f2' : Fraction)
    (p : fraction_eq f1 f1') (q : fraction_eq f2 f2')
    : fraction_eq (frac_add f1 f2) (frac_add f1' f2').
  Proof.
    destruct f1 as [a s ss], f1' as [a' s' ss'],
      f2 as [b t st], f2' as [b' t' st'],
      p as [x [sx p]], q as [y [sy q]].
    refine (x * y ; (mss_mult sx sy, _)).
    simpl.
    rewrite rng_dist_l_negate.
    rewrite 2 rng_dist_r.
    rewrite 2 rng_dist_l.
    rewrite <- rng_plus_assoc.
    rewrite (rng_plus_comm _ (- _)).
    rewrite rng_negate_plus.
    rewrite 2 rng_plus_assoc.
    rewrite <- (rng_plus_assoc _ (- _)).
    rewrite (rng_plus_comm (- _)).
    rewrite <- 2 rng_dist_l_negate.
    rewrite <- ? rng_mult_assoc.
    rewrite 2 (rng_mult_move_right_assoc a').
    rewrite (rng_mult_comm a' t).
    rewrite (rng_mult_move_right_assoc s).
    rewrite (rng_mult_comm s a').
    rewrite (rng_mult_move_right_assoc t).
    rewrite (rng_mult_comm t t').
    rewrite <- 2 (rng_mult_move_right_assoc t').
    rewrite <- (rng_dist_l_negate t').
    rewrite (rng_mult_comm _ t).
    rewrite (rng_mult_move_right_assoc _ t).
    rewrite <- (rng_dist_l_negate t).
    rewrite <- 2 (rng_mult_move_right_assoc t').
    rewrite <- 2 (rng_mult_move_right_assoc t).
    rewrite (rng_mult_move_right_assoc x).
    rewrite p.
    rewrite 3 rng_mult_zero_r.
    rewrite rng_plus_zero_l.
    rewrite 2 (rng_mult_move_right_assoc b).
    rewrite 2 (rng_mult_move_right_assoc b').
    rewrite (rng_mult_move_right_assoc s).
    rewrite <- 2 rng_dist_l_negate.
    rewrite 2 (rng_mult_move_right_assoc y).
    rewrite q.
    by rewrite 3 rng_mult_zero_r.
  Qed.

  Lemma frac_add_wd_l (f1 f1' f2 : Fraction) (p : fraction_eq f1 f1')
    : fraction_eq (frac_add f1 f2) (frac_add f1' f2).
  Proof.
    pose (fraction_eq_refl f2).
    by apply frac_add_wd.
  Defined.

  Lemma frac_add_wd_r (f1 f2 f2' : Fraction) (p : fraction_eq f2 f2')
    : fraction_eq (frac_add f1 f2) (frac_add f1 f2').
  Proof.
    pose (fraction_eq_refl f1).
    by apply frac_add_wd.
  Defined.

  (** The addition operation for fractions is the usual fraction addition. Most of the work is spent showing that this is well-defined. *)
  Instance plus_localization_type : Plus Localization_type.
  Proof.
    intros x; srapply Localization_type_rec.
    { intros f2; revert x.
      srapply Localization_type_rec.
      { intros f1.
        apply loc_frac.
        exact (frac_add f1 f2). }
      intros f1 f1' p.
      by apply loc_frac_eq, frac_add_wd_l. }
    intros f2 f2' p; revert x; cbn.
    srapply Localization_type_ind_hprop.
    intros f1.
    by apply loc_frac_eq, frac_add_wd_r.
  Defined.

  (** *** Multiplication operation *)

  Definition frac_mult : Fraction -> Fraction -> Fraction :=
    fun '(Build_Fraction n1 d1 p1) '(Build_Fraction n2 d2 p2)
      => Build_Fraction (n1 * n2) (d1 * d2) (mss_mult p1 p2).

  Lemma frac_mult_wd_l f1 f1' f2 (p : fraction_eq f1 f1')
    : fraction_eq (frac_mult f1 f2) (frac_mult f1' f2).
  Proof.
    destruct p as [x [s p]].
    refine (x; (s, _)); simpl.
    rewrite rng_dist_l.
    rewrite rng_dist_l in p.
    rewrite rng_mult_negate_r.
    rewrite rng_mult_negate_r in p.
    apply rng_moveL_0M in p.
    apply rng_moveL_0M^-1.
    rewrite 2 (rng_mult_comm _ (numerator f2)).
    rewrite 2 (rng_mult_comm _ (denominator f2)).
    rewrite <- 2 (rng_mult_assoc (numerator f2)).
    rewrite 2 (rng_mult_comm (numerator _) (denominator f2 * _)).
    rewrite ? (rng_mult_assoc (numerator f2)).
    rewrite <- ? (rng_mult_assoc (numerator f2 * denominator f2)).
    rewrite 2 (rng_mult_comm (denominator _) (numerator _)).
    rewrite 2 (rng_mult_comm (numerator f2 * denominator f2)).
    rewrite 2 (rng_mult_assoc x (numerator _ * denominator _)).
    f_ap.
  Defined.

  Lemma frac_mult_wd_r f1 f2 f2' (p : fraction_eq f2 f2')
    : fraction_eq (frac_mult f1 f2) (frac_mult f1 f2').
  Proof.
    destruct p as [x [s p]].
    refine (x; (s, _)); simpl.
    rewrite rng_dist_l.
    rewrite rng_dist_l in p.
    rewrite rng_mult_negate_r.
    rewrite rng_mult_negate_r in p.
    apply rng_moveL_0M in p.
    apply rng_moveL_0M^-1.
    rewrite 2 (rng_mult_comm (numerator f1)).
    rewrite <- 2 rng_mult_assoc.
    rewrite 2 (rng_mult_comm (numerator f1)).
    rewrite <- ? rng_mult_assoc.
    rewrite 2 (rng_mult_move_right_assoc (denominator f1)).
    rewrite ? rng_mult_assoc.
    rewrite ? rng_mult_assoc in p.
    do 2 f_ap.
  Defined.

  Instance mult_localization_type : Mult Localization_type.
  Proof.
    intros x; srapply Localization_type_rec.
    { intros f2; revert x.
      srapply Localization_type_rec.
      { intros f1.
        apply loc_frac.
        exact (frac_mult f1 f2). }
      intros f1 f1' p.
      by apply loc_frac_eq, frac_mult_wd_l. }
    intros f2 f2' p; revert x.
    srapply Localization_type_ind_hprop.
    intros f1.
    by apply loc_frac_eq, frac_mult_wd_r.
  Defined.

  (** *** Zero element *)

  Instance zero_localization_type : Zero Localization_type :=
    loc_frac (Build_Fraction 0 1 mss_one).

  (** *** One element *)

  Instance one_localization_type : One Localization_type :=
    loc_frac (Build_Fraction 1 1 mss_one).

  (** *** Negation operation *)

  Definition frac_negate : Fraction -> Fraction :=
    fun '(Build_Fraction n d p) => Build_Fraction (- n) d p.

  Lemma frac_negate_wd f1 f2 (p : fraction_eq f1 f2)
    : fraction_eq (frac_negate f1) (frac_negate f2).
  Proof.
    destruct p as [x [s p]].
    refine (x; (s,_)); simpl.
    rewrite 2 rng_mult_negate_l.
    rewrite <- rng_negate_plus.
    rewrite rng_mult_negate_r.
    rewrite p.
    apply rng_negate_zero.
  Defined.

  Instance negate_localization_type : Negate Localization_type.
  Proof.
    srapply Localization_type_rec.
    { intros f.
      apply loc_frac.
      exact (frac_negate f). }
    intros f1 f2 p.
    by apply loc_frac_eq, frac_negate_wd.
  Defined.

  (** *** Ring laws *)

  (** Left additive identity *)
  Instance leftidentity_plus_localization_type
    : LeftIdentity plus_localization_type zero_localization_type.
  Proof.
    srapply Localization_type_ind_hprop; intros f.
    apply loc_frac_eq, fraction_eq_simple; simpl.
    f_ap.
    - rewrite rng_mult_zero_l.
      rewrite rng_plus_zero_l.
      apply rng_mult_one_r.
    - symmetry.
      apply rng_mult_one_l.
  Defined.

  Instance rightidentity_plus_localization_type
    : RightIdentity plus_localization_type zero_localization_type.
  Proof.
    srapply Localization_type_ind_hprop; intros f.
    apply loc_frac_eq, fraction_eq_simple; simpl.
    f_ap.
    - rewrite rng_mult_zero_l.
      rewrite rng_plus_zero_r.
      apply rng_mult_one_r.
    - symmetry.
      apply rng_mult_one_r.
  Defined.

  Instance leftinverse_plus_localization_type
    : LeftInverse plus_localization_type negate_localization_type zero_localization_type.
  Proof.
    srapply Localization_type_ind_hprop; intros f.
    apply loc_frac_eq, fraction_eq_simple; simpl.
    refine (rng_mult_one_r _ @ _).
    refine (_ @ (rng_mult_zero_l _)^).
    rewrite rng_mult_negate_l.
    apply rng_plus_negate_l.
  Defined.

  Instance rightinverse_plus_localization_type
    : RightInverse plus_localization_type negate_localization_type zero_localization_type.
  Proof.
    srapply Localization_type_ind_hprop; intros f.
    apply loc_frac_eq, fraction_eq_simple; simpl.
    refine (rng_mult_one_r _ @ _).
    refine (_ @ (rng_mult_zero_l _)^).
    rewrite rng_mult_negate_l.
    apply rng_plus_negate_r.
  Defined.

  Instance associative_plus_localization_type
    : Associative plus_localization_type.
  Proof.
    intros x y; srapply Localization_type_ind_hprop; intros z; revert y.
    srapply Localization_type_ind_hprop; intros y; revert x.
    srapply Localization_type_ind_hprop; intros x.
    apply loc_frac_eq, fraction_eq_simple.
    simpl.
    rewrite ? rng_dist_r.
    rewrite ? rng_mult_assoc.
    rewrite ? rng_plus_assoc.
    do 4 f_ap.
    all: rewrite <- ? rng_mult_assoc.
    all: f_ap.
    2: apply rng_mult_comm.
    rewrite rng_mult_assoc.
    apply rng_mult_comm.
  Defined.

  Instance commutative_plus_localization_type
    : Commutative plus_localization_type.
  Proof.
    intros x; srapply Localization_type_ind_hprop; intros y; revert x.
    srapply Localization_type_ind_hprop; intros x.
    apply loc_frac_eq, fraction_eq_simple; simpl.
    rewrite (rng_mult_comm (denominator y) (denominator x)).
    f_ap; apply rng_plus_comm.
  Defined.

  Instance leftidentity_mult_localization_type
    : LeftIdentity mult_localization_type one_localization_type.
  Proof.
    srapply Localization_type_ind_hprop; intros f.
    apply loc_frac_eq, fraction_eq_simple; simpl.
    f_ap; [|symmetry]; apply rng_mult_one_l.
  Defined.

  Instance rightidentity_mult_localization_type
    : RightIdentity mult_localization_type one_localization_type.
  Proof.
    srapply Localization_type_ind_hprop; intros f.
    apply loc_frac_eq, fraction_eq_simple; simpl.
    f_ap; [|symmetry]; apply rng_mult_one_r.
  Defined.

  Instance associative_mult_localization_type
    : Associative mult_localization_type.
  Proof.
    intros x y; srapply Localization_type_ind_hprop; intros z; revert y.
    srapply Localization_type_ind_hprop; intros y; revert x.
    srapply Localization_type_ind_hprop; intros x.
    apply loc_frac_eq, fraction_eq_simple.
    f_ap; [|symmetry]; apply rng_mult_assoc.
  Defined.

  Instance commutative_mult_localization_type
    : Commutative mult_localization_type.
  Proof.
    intros x; srapply Localization_type_ind_hprop; intros y; revert x.
    srapply Localization_type_ind_hprop; intros x.
    apply loc_frac_eq, fraction_eq_simple; simpl.
    f_ap; rapply rng_mult_comm.
  Defined.

  Instance leftdistribute_localization_type
    : LeftDistribute mult_localization_type plus_localization_type.
  Proof.
    intros x y; srapply Localization_type_ind_hprop; intros z; revert y.
    srapply Localization_type_ind_hprop; intros y; revert x.
    srapply Localization_type_ind_hprop; intros x.
    apply loc_frac_eq, fraction_eq_simple.
    simpl.
    rewrite ? rng_dist_l, ? rng_dist_r.
    rewrite ? rng_mult_assoc.
    do 2 f_ap.
    all: rewrite <- ? rng_mult_assoc.
    all: do 2 f_ap.
    all: rewrite ? rng_mult_assoc.
    all: rewrite (rng_mult_comm (_ x)).
    all: rewrite <- ? rng_mult_assoc.
    all: f_ap.
    all: rewrite (rng_mult_comm _ (_ y)).
    all: rewrite <- ? rng_mult_assoc.
    all: f_ap.
  Defined.

  Instance isring_localization_type : IsRing Localization_type
    := ltac:(repeat split; exact _).

  Definition RingLocalization : CRing :=
    Build_CRing Localization_type _ _ _ _ _ _.

End Localization.

(** TODO: Show construction is a localization. *)


From mathcomp Require Import ssreflect ssrbool ssrnat eqtype ssrfun seq.
From mathcomp Require Import path.
From pcm Require Import pred prelude ordtype finmap pcm unionmap seqext.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Section Keys.
Variables (K : ordType) (V : Type) (U : union_map_class K V).
Implicit Types (k : K) (v : V) (f : U).

Lemma keys_last_mono f1 f2 k :
        path oleq k (dom f1) ->
        path oleq k (dom f2) ->
        (forall x, x \in dom f1 -> x \in dom f2) ->
        oleq (last k (dom f1)) (last k (dom f2)).
Proof.
rewrite !umEX; case: (UMC.from f1).
- by move=>_ H _; apply: path_lastR H=>//; apply: otrans.
move=>{f1} f1 /= _ H1; case: (UMC.from f2)=>/=.
- by move=>_ /allP; case: (supp f1)=>//; rewrite /oleq eq_refl orbT.
by move=>{f2} f2 /= _; apply: seq_last_monoR H1=>//; apply: otrans.
Qed.

End Keys.

(* Last_key and Fresh are constructs that work *)
(* for any union map with integer keys *)
(* Should be developed more generally for any union map class *)
(* with a proof that key U = nat, but I can't bother right now *)

Section FreshLastKey.
Variable V : Type.
Implicit Type f : union_map [ordType of nat] V.

Definition last_key f := last 0 (dom f).

Lemma last_key0 : last_key Unit = 0.
Proof. by rewrite /last_key /Unit /= !umEX. Qed.

Lemma last_key_dom f : valid f -> last_key f \notin dom f -> f = Unit.
Proof.
rewrite /valid /= /last_key /Unit /= !umEX /= -{4}[f]UMC.tfE.
case: (UMC.from f)=>//=; case=>s H /= H1 _ /seq_last_in.
rewrite /UM.empty UMC.eqE UM.umapE /supp fmapE /= {H H1}.
by elim: s.
Qed.

Lemma dom_last_key f :  valid f -> ~~ unitb f -> last_key f \in dom f.
Proof. by move=>X; apply: contraR; move/(last_key_dom X)=>->; apply: unitb0. Qed.

Lemma last_key_max f x : x \in dom f -> x <= last_key f.
Proof.
rewrite /last_key /= !umEX; case: (UMC.from f)=>//; case=>s H _ /=.
rewrite /supp /ord /= (leq_eqVlt x) orbC.
by apply: sorted_last_key_maxR (sorted_oleq H)=>//; apply: otrans.
Qed.

Lemma max_key_last f x :
        x \in dom f -> {in dom f, forall y, y <= x} -> last_key f = x.
Proof.
rewrite /last_key !umEX; case: (UMC.from f)=>//; case=>s H _ /=.
move=>H1 /= H2; apply: sorted_max_key_last (sorted_oleq H) H1 _.
- by apply: otrans.
- by apply: oantisym.
by move=>z /(H2 z); rewrite leq_eqVlt orbC.
Qed.

Lemma last_keyPt (x : nat) v : last_key (x \\-> v) = x.
Proof. by rewrite /last_key /um_pts /= !umEX. Qed.

Lemma hist_path f : path oleq 0 (dom f).
Proof.
rewrite !umEX; case: (UMC.from f)=>// {f} f /= _; case: f; case=>//= x s H.
rewrite {1}/oleq /ord /= orbC -leq_eqVlt /=.
by apply: sub_path H=>z y; rewrite /oleq=>->.
Qed.

Lemma last_key_mono f1 f2 :
        {subset dom f1 <= dom f2} -> last_key f1 <= last_key f2.
Proof.
rewrite leq_eqVlt orbC=>H; apply: (@keys_last_mono _ _ _ f1 f2);
try by apply: hist_path.
by move=>x /=; move: (H x).
Qed.

Lemma last_keyfUn f1 f2 :
        valid (f1 \+ f2) -> last_key f1 <= last_key (f1 \+ f2).
Proof. by move=>X; apply: last_key_mono=>x; rewrite domUn inE X => ->. Qed.

Lemma last_keyUnf f1 f2 :
        valid (f1 \+ f2) -> last_key f2 <= last_key (f1 \+ f2).
Proof. by rewrite joinC; apply: last_keyfUn. Qed.

(* freshness *)

Definition fresh f := (last_key f).+1.

Lemma dom_ordfresh f x : x \in dom f -> x < fresh f.
Proof. by move/last_key_max. Qed.

Lemma dom_freshn f n : fresh f + n \notin dom f.
Proof. by apply: contra (@dom_ordfresh _ _) _; rewrite -leqNgt leq_addr. Qed.

Lemma dom_fresh f : fresh f \notin dom f.
Proof. by move: (dom_freshn f 0); rewrite addn0.  Qed.

Lemma valid_fresh f v : valid (f \+ fresh f \\-> v) = valid f.
Proof. by rewrite joinC validPtUn dom_fresh andbT. Qed.

Lemma valid_fresh' f v i w :
  valid (f \+ i \\-> w) ->
  valid (f \+ fresh (f \+ i \\-> w) \\-> v).
Proof.
move=> W; rewrite joinC validPtUn.
move: (dom_fresh (f \+ i \\-> w)); rewrite domUn inE; rewrite W/=.
by rewrite negb_or=>/andP; case=>-> _;move/validL: W=>->.
Qed.

Lemma last_fresh f v : valid f -> last_key (f \+ fresh f \\-> v) = fresh f.
Proof.
move=>Vf; apply: max_key_last=>[|x] /=.
- by rewrite domUn inE valid_fresh Vf domPt inE eq_refl orbT.
rewrite domUn inE /= valid_fresh Vf /= domPt inE /= orbC eq_sym.
by rewrite leq_eqVlt; case: eqP=>//= _; apply: dom_ordfresh.
Qed.

End FreshLastKey.


(** This file was originally written by Niels van der Weide and Dan Frumin.  *)
Require Import HoTT.
From GCTT Require Export path_over.

(** A globe represents an equality between two paths. *)
Inductive globe
          {A : Type}
  : forall {a₁ a₂ : A} (p q : a₁ = a₂), Type
  :=
  | globe_id : forall {a : A}, @globe A a a idpath idpath.

(** A globe is thus the same as a path between two paths. *)
Definition path_to_globe
           {A : Type}
           {a₁ a₂ : A}
           {p q : a₁ = a₂}
           (h : p = q)
  : globe p q
  := match h with
     | idpath =>
       match p with
       | idpath => globe_id
       end
     end.

Definition globe_to_path
           {A : Type}
           {a₁ a₂ : A}
           {p q : a₁ = a₂}
           (h : globe p q)
  : p = q
  := match h with
     | globe_id _ => idpath
     end.

Global Instance path_to_globe_isequiv
       {A : Type}
       {a₁ a₂ : A}
       {p q : a₁ = a₂}
  : IsEquiv (@path_to_globe A a₁ a₂ p q).
Proof.
  simple refine (isequiv_adjointify _ globe_to_path _ _).
  - intros x.
    induction x ; reflexivity.
  - intros x.
    induction x, p ; reflexivity.
Defined.

Arguments globe_id {_} {_}.

(** We can also define `globe_over`, which represents an equality between two `path_over`. *)
Inductive globe_over
          {A : Type}
          (Y : A -> Type)
  : forall {a₁ a₂ : A}
           {c₁ : Y a₁} {c₂ : Y a₂}
           {p₁ p₂ : a₁ = a₂}
           (h : globe p₁ p₂)
           (q₁ : path_over Y p₁ c₁ c₂)
           (q₂ : path_over Y p₂ c₁ c₂),
    Type
  :=
  | globe_over_id : forall {a : A} {c₁ c₂ : Y a} (q : path_over Y idpath c₁ c₂),
      globe_over Y globe_id q q.

(** In a constant fibration, this is the same as proving two paths are equal. *)
Definition const_globe_over
           {A B : Type}
           {a₁ a₂ : A}
           {b₁ b₂ : B}
           {p₁ p₂ : a₁ = a₂}
           (h₁ : globe p₁ p₂)
           (q₁ q₂ : b₁ = b₂)
           (h₂ : globe q₁ q₂)
  : globe_over (fun _ => B) h₁ (const_path_over q₁) (const_path_over q₂).
Proof.
  induction h₁, h₂.
  apply globe_over_id.
Defined.

(** This changes the sides of a `globe_over`. *)
Definition globe_over_whisker
           {A : Type}
           (Y : A -> Type)
           {a₁ a₂ : A}
           {c₁ : Y a₁} {c₂ : Y a₂}
           {p₁ p₂ : a₁ = a₂}
           (h : globe p₁ p₂)
           {q₁ q₃ : path_over Y p₁ c₁ c₂}
           {q₂ q₄ : path_over Y p₂ c₁ c₂}
           (s₁ : q₁ = q₃) (s₂ : q₂ = q₄)
  : globe_over Y h q₁ q₂ -> globe_over Y h q₃ q₄
  := match s₁, s₂ with
     | idpath, idpath => idmap
     end.

(** One way to provide a `globe_over`, is by giving a path between two paths. *)
Definition path_to_globe_over
           {A : Type}
           (Y : A -> Type)
           {a₁ a₂ : A}
           {c₁ : Y a₁} {c₂ : Y a₂}
           {p₁ p₂ : a₁ = a₂}
           (h : globe p₁ p₂)
           (q₁ : path_over Y p₁ c₁ c₂)
           (q₂ : path_over Y p₂ c₁ c₂)
           (s : path_over_to_path (transport (fun r => path_over Y r c₁ c₂)
                                             (globe_to_path h)
                                             q₁)
                = path_over_to_path q₂)
  : globe_over Y h q₁ q₂.
Proof.
  pose (ap path_over_to_path^-1 s) as p.
  rewrite !eissect in p.
  induction p, h ; clear s.
  exact (globe_over_id Y q₁).
Defined.

(** `globe_over` in a family of sets. *)
Definition path_globe_over_hset
           {A : Type}
           (Y : A -> Type)
           `{forall (a : A), IsHSet (Y a)}
           {a₁ a₂ : A}
           {c₁ : Y a₁} {c₂ : Y a₂}
           {p₁ p₂ : a₁ = a₂}
           (h : globe p₁ p₂)
           (q₁ : path_over Y p₁ c₁ c₂)
           (q₂ : path_over Y p₂ c₁ c₂)
  : globe_over Y h q₁ q₂.
Proof.
  apply path_to_globe_over.
  apply path_ishprop.
Defined.


Load LFindLoad.
From lfind Require Import LFind.
From adtind Require Import goal9.

Set Printing Depth 1000.
Definition lfind_eval  z n x:=
drop x (Cons n z).

Compute lfind_eval  (Nil) (Zero) (Succ Zero).

Compute lfind_eval  (Cons (Succ (Succ Zero)) Nil) (Succ (Succ Zero)) (Zero).

Compute lfind_eval  (Cons (Succ Zero) Nil) (Succ (Succ Zero)) (Zero).

Compute lfind_eval  (Cons (Succ (Succ Zero)) (Cons Zero Nil)) (Zero) (Zero).

Compute lfind_eval  (Cons (Succ (Succ Zero)) (Cons Zero (Cons Zero Nil))) (Zero) (Succ (Succ (Succ Zero))).

Compute lfind_eval  (Nil) (Succ (Succ (Succ Zero))) (Succ (Succ (Succ Zero))).

Compute lfind_eval  (Nil) (Succ (Succ (Succ Zero))) (Succ (Succ Zero)).

Compute lfind_eval  (Cons (Succ (Succ Zero)) (Cons (Succ (Succ Zero)) (Cons (Succ Zero) (Cons Zero (Cons Zero (Cons (Succ Zero) Nil)))))) (Succ Zero) (Zero).

Compute lfind_eval  (Nil) (Zero) (Succ (Succ Zero)).

Compute lfind_eval  (Cons (Succ (Succ (Succ Zero))) Nil) (Zero) (Succ Zero).

Compute lfind_eval  (Nil) (Succ Zero) (Zero).

Compute lfind_eval  (Cons Zero (Cons Zero (Cons Zero Nil))) (Zero) (Zero).

Compute lfind_eval  (Nil) (Succ (Succ Zero)) (Succ (Succ Zero)).

Compute lfind_eval  (Cons (Succ (Succ Zero)) Nil) (Succ (Succ (Succ Zero))) (Zero).

Compute lfind_eval  (Cons Zero (Cons (Succ Zero) (Cons (Succ (Succ Zero)) Nil))) (Succ (Succ Zero)) (Succ Zero).

Compute lfind_eval  (Cons Zero (Cons Zero Nil)) (Succ (Succ Zero)) (Zero).

Compute lfind_eval  (Nil) (Succ (Succ Zero)) (Succ Zero).

Compute lfind_eval  (Cons (Succ Zero) Nil) (Succ Zero) (Succ Zero).

Compute lfind_eval  (Cons Zero (Cons (Succ Zero) (Cons (Succ Zero) Nil))) (Succ (Succ (Succ Zero))) (Succ (Succ (Succ Zero))).

Compute lfind_eval  (Cons (Succ (Succ Zero)) Nil) (Succ (Succ (Succ (Succ Zero)))) (Succ Zero).

Compute lfind_eval  (Cons (Succ (Succ (Succ Zero))) Nil) (Succ Zero) (Zero).

Compute lfind_eval  (Cons (Succ Zero) Nil) (Succ Zero) (Succ Zero).

Compute lfind_eval  (Nil) (Zero) (Succ Zero).

Compute lfind_eval  (Cons (Succ Zero) (Cons (Succ (Succ (Succ Zero))) (Cons Zero Nil))) (Zero) (Succ (Succ (Succ Zero))).

Compute lfind_eval  (Cons Zero (Cons Zero Nil)) (Zero) (Succ Zero).

Compute lfind_eval  (Nil) (Zero) (Zero).

Compute lfind_eval  (Cons Zero Nil) (Succ (Succ Zero)) (Zero).

Compute lfind_eval  (Nil) (Succ (Succ Zero)) (Zero).

Compute lfind_eval  (Cons (Succ (Succ (Succ Zero))) (Cons (Succ (Succ Zero)) (Cons Zero Nil))) (Succ Zero) (Succ Zero).

Compute lfind_eval  (Cons (Succ Zero) Nil) (Zero) (Zero).

Compute lfind_eval  (Nil) (Succ Zero) (Succ (Succ Zero)).

Compute lfind_eval  (Cons (Succ Zero) (Cons (Succ Zero) (Cons Zero Nil))) (Zero) (Succ Zero).

Compute lfind_eval  (Nil) (Zero) (Zero).


(* Show that algebras with homomorphisms between them form a category. *)
Require Import
  MathClasses.interfaces.abstract_algebra MathClasses.interfaces.universal_algebra MathClasses.theory.ua_homomorphisms MathClasses.theory.categories.
Require
  MathClasses.categories.setoids MathClasses.categories.product.

Record Object (sign: Signature) : Type := object
  { algebra_carriers:> sorts sign → Type
  ; algebra_equiv: ∀ a, Equiv (algebra_carriers a)
  ; algebra_ops: AlgebraOps sign algebra_carriers
  ; algebra_proof: Algebra sign algebra_carriers }.

Arguments object _ _ {algebra_equiv algebra_ops algebra_proof}.

(* Avoid Coq trying to apply algebra_equiv to find arbitrary Equiv instances *)
Hint Extern 0 (Equiv (algebra_carriers _ _ _)) => eapply @algebra_equiv : typeclass_instances.
Existing Instance algebra_ops.
Existing Instance algebra_proof.

Section contents.
  Variable sign: Signature.

  Global Instance: Arrows (Object sign) := λ X Y, sig (HomoMorphism sign X Y).

  Program Definition arrow `{Algebra sign A} `{Algebra sign B}
    f `{!HomoMorphism sign A B f}: object sign A ⟶ object sign B := f.

  Global Program Instance: CatId (Object sign) := λ _ _, id.

  Global Program Instance comp: CatComp (Object sign) := λ _ _ _ f g v, f v ∘ g v.

  Global Program Instance: ∀ x y: Object sign, Equiv (x ⟶ y)
    := λ _ _ x y, ∀ b, pointwise_relation _ (=) (x b) (y b).

  Global Instance: ∀ x y: Object sign, Setoid (x ⟶ y).
  Proof.
   constructor.
     repeat intro. reflexivity.
    intros ? ? E ? ?. symmetry. apply E.
   intros ? ? ? E F ? ?. rewrite (E _ _). apply F.
  Qed.

  Instance: Proper ((=) ==> (=) ==> (=)) (comp x y z).
  Proof.
   intros ? ? ? x0 ? E ? ? F ? ?.
   simpl. unfold compose. do 3 red in E, F.
   destruct (proj2_sig x0). rewrite F, E. reflexivity.
  Qed.

  Global Instance: Category (Object sign).
  Proof. constructor; try apply _; repeat intro; reflexivity. Qed.
End contents.


Require Import GeoCoq.Axioms.parallel_postulates.
Require Import GeoCoq.Tarski_dev.Annexes.saccheri.

Section rah_similar.

Context `{TnEQD:Tarski_neutral_dimensionless_with_decidable_point_equality}.

Lemma rah__similar : postulate_of_right_saccheri_quadrilaterals -> postulate_of_existence_of_similar_triangles.
Proof.
  intro rah.
  destruct lower_dim_ex as [A [B0 [C]]].
  assert(~ Col A B0 C) by (unfold Col; assumption).
  destruct (l10_15 C A C B0) as [B []]; Col.
  assert(HNCol1 : ~ Col C A B) by (apply (one_side_not_col123 _ _ _ B0); Side).
  assert(Per A C B) by Perp.
  destruct (symmetric_point_construction A B) as [B'].
  assert_diffs.
  assert(HNCol2 : ~ Col A C B') by (intro; apply HNCol1; ColR).
  assert(HNCol3 : ~ Col B B' C) by (intro; apply HNCol2; ColR).
  destruct (l8_18_existence A C B') as [C' []]; auto.
  exists A, B, C, A, B', C'.
  assert(Par_strict B C B' C').
    apply (par_not_col_strict _ _ _ _ B'); Col; apply (l12_9 _ _ _ _ A C); Perp; Cop.
  assert(HNCol4 : ~ Col B C C') by (apply (par_strict_not_col_4 _ _ B'); auto).
  assert_diffs.
  assert(Bet A C C').
  { apply (col_two_sides_bet _ B); Col.
    apply l9_2.
    apply (l9_8_2 _ _ B').
      repeat split; Col; exists B; split; Col; Between.
      apply l12_6; Par.
  }
  assert(A <> C') by (intro; treat_equalities; auto).
  assert(Per B' C' A) by (apply perp_per_1, (perp_col1 _ _ _ C); Col; Perp).
  assert(CongA B C A B' C' A) by (apply l11_16; Perp).
  assert(CongA C A B C' A B').
    apply out2__conga; apply l6_6, bet_out; Between.
  split; Col; split.

    {
    intro.
    absurd(B = B'); auto.
    apply (between_cong A); Between.
    }

    {
    split; [|split; auto].
    apply (sams2_suma2__conga456 C A B _ _ _ _ _ _ B C A).
      SumA.
      apply (conga2_sams__sams C' A B' A B' C'); CongA; SumA.
      apply t22_12__rah; Perp.
      apply (conga3_suma__suma C' A B' A B' C' B' C' A); CongA; apply t22_12__rah; auto.
    }
Qed.

End rah_similar.


Load LFindLoad.
From lfind Require Import LFind.
Unset Printing Notations.
Set Printing Implicit.

Inductive natural : Type := Succ : natural -> natural |  Zero : natural.

Inductive lst : Type := Cons : natural -> lst -> lst |  Nil : lst.

Inductive tree : Type := Node : natural -> tree -> tree -> tree |  Leaf : tree.

Inductive Pair : Type := mkpair : natural -> natural -> Pair
with Zlst : Type := zcons : Pair -> Zlst -> Zlst |  znil : Zlst.

Fixpoint drop (drop_arg0 : natural) (drop_arg1 : lst) : lst
           := match drop_arg0, drop_arg1 with
              | x, Nil => Nil
              | Zero, x => x
              | Succ x, Cons y z => drop x z
              end.

Lemma lem: forall n1 n2 l, drop (Succ n1) (drop n2 l) = drop n1 (drop (Succ n2) l).
Proof.
intros. generalize dependent n1. generalize dependent n2. induction l.
- intros. assert (forall n x l, drop (Succ n) (Cons x l) = drop n l).
  + intros. reflexivity.
  + destruct n2.
    * rewrite H. rewrite H. rewrite <- IHl. reflexivity.
    * simpl. destruct l. reflexivity. reflexivity.
- intros. assert (forall n, drop n Nil = Nil).
  + intros. destruct n. reflexivity. reflexivity.
  + rewrite H. rewrite H. rewrite H. reflexivity.
Qed.

Theorem theorem0 : forall (u : natural) (v : natural) (w : natural) (x : natural) (y : natural) (z : lst),
  eq (drop (Succ u) (drop v (drop (Succ w) (Cons x (Cons y z))))) (drop (Succ u) (drop v (drop w (Cons x z)))).
Proof.
intros.
rewrite lem.
lfind. Admitted.


Require Import List Map Envs AllInRel MoreList.
Require Import Take TakeSet.

Set Implicit Arguments.

(* pick *)
Definition pick (X:Type) `{OrderedType X} (k : nat) (s t : ⦃X⦄) : ⦃X⦄
  := s ∪ set_take (k - cardinal s) (t \ s).

Lemma incl_pick (X:Type) `{OrderedType X} (k : nat) (s t : ⦃X⦄) :
  s ⊆ pick k s t.
Proof.
  unfold pick. cset_tac.
Qed.

Lemma pick_incl (X:Type) `{OrderedType X} (k : nat) (s t : ⦃X⦄) :
  pick k s t ⊆ s ∪ t.
Proof.
  unfold pick. rewrite set_take_incl. cset_tac.
Qed.

Lemma pick_card (X:Type) `{OrderedType X} (k : nat) (s t : ⦃X⦄) :
  k <= cardinal (s ∪ t)
  -> k <= cardinal (pick k s t).
Proof.
  intros card. unfold pick. rewrite union_cardinal.
  - unfold set_take. rewrite cardinal_of_list_nodup; [|apply take_dupFree].
    assert (s ∪ t [=] s ∪ t \ s) as seteq by cset_tac.
    rewrite seteq in card. rewrite union_cardinal in card; [|clear;cset_tac].
    rewrite take_length_le; eauto.
    + omega.
    + rewrite elements_length. omega.
  - intros. rewrite set_take_incl. cset_tac.
Qed.

Lemma pick_card' (X:Type) `{OrderedType X} (k : nat) (s t : ⦃X⦄) :
  cardinal s <= k -> cardinal (pick k s t) <= k.
Proof.
  intros card. unfold pick. rewrite union_cardinal.
  - unfold set_take.  rewrite cardinal_of_list_nodup; [|apply take_dupFree].
    decide (k - cardinal s <= cardinal (t \ s)).
    + rewrite take_length_le; eauto.
      * omega.
      * rewrite elements_length. eauto.
    + rewrite take_length_ge; eauto.
      * rewrite elements_length. omega.
      * rewrite elements_length. omega.
  - intros. rewrite set_take_incl. cset_tac.
Qed.

Lemma pick_eq (X:Type) `{OrderedType X} k (s t : ⦃X⦄)
  : cardinal s + cardinal (t \ s) <= k -> pick k s t [=] s ∪ t.
Proof.
  intros card. apply incl_eq; [|apply pick_incl].
  unfold pick. unfold set_take.
  rewrite take_eq_ge.
  - rewrite of_list_elements. cset_tac.
  - rewrite elements_length. unfold ">=". apply Nat.le_add_le_sub_r.
    omega.
Qed.

Lemma pick_eq' (X:Type) `{OrderedType X} (k:nat) (s t : ⦃X⦄) :
  k <= cardinal s
  -> pick k s t [=] s.
Proof.
  intros card. unfold pick. replace (k - cardinal s) with 0 by omega.
  cbn. clear; cset_tac.
Qed.

(* pick_kill *)
Definition pick_kill (X:Type) `{OrderedType X} (k:nat) (s t u v : ⦃X⦄) : ⦃X⦄
  := pick (cardinal s + cardinal t - k) ((s \ (u ∪ v)) ∪ (s ∩ t)) (s ∩ v \ u).

Lemma incl_pick_kill (X:Type) `{OrderedType X} (k:nat) (s t u v : ⦃X⦄) :
  ((s \ (u ∪ v)) ∪ (s ∩ t)) ⊆ pick_kill k s t u v.
Proof.
  eapply incl_pick.
Qed.

Lemma pick_kill_incl (X:Type) `{OrderedType X} (k : nat) (s t u v : ⦃X⦄) :
  pick_kill k s t u v ⊆ (s ∩ t) ∪ (s \ u).
Proof.
  unfold pick_kill. rewrite pick_incl. cset_tac.
Qed.

Lemma pick_kill_card (X:Type) `{OrderedType X} (k : nat) (s t u v : ⦃X⦄) :
  cardinal (s ∩ u \ t) + cardinal t <= k
  -> cardinal s + cardinal t - k <= cardinal (pick_kill k s t u v).
Proof.
  intros card.
  assert (s ∩ u \ t [=] s \ (((s \ (u ∪ v)) ∪ (s ∩ t)) ∪ (s ∩ v \ u))) as seteq by cset_tac.
  rewrite seteq in card. rewrite cardinal_difference' in card; [|clear;cset_tac].
  eapply pick_card. omega.
Qed.

Lemma pick_kill_eq (X:Type) `{OrderedType X} (k:nat) (s t u v : ⦃X⦄) :
  let w := s \ (u ∪ v) ∪ (s ∩ t) in
  cardinal (s \ w ∪ t) <= k
  -> pick_kill k s t u v [=] s \ (u ∪ v) ∪ (s ∩ t).
Proof.
  intros w card. subst w.
  rewrite union_cardinal in card; [|clear;cset_tac].
  unfold pick_kill. apply pick_eq'.
  assert (forall l m n o : nat, (l - o) + m <= n -> l + m - n <= o) as nateq by (intros;omega).
  apply nateq. rewrite <-cardinal_difference'; [|clear;intros;intro N;cset_tac].
  eauto.
Qed.

(* pick_killx *)
Definition pick_killx (X:Type) `{OrderedType X} (k:nat) (s t : ⦃X⦄) : ⦃X⦄
  := pick (S (cardinal s) - k) (s \ t) (s ∩ t).

Lemma incl_pick_killx (X:Type) `{OrderedType X} (k:nat) (s t : ⦃X⦄) :
  s \ t ⊆ pick_killx k s t.
Proof.
  eapply incl_pick.
Qed.

Lemma pick_killx_incl (X:Type) `{OrderedType X} (k:nat) (s t : ⦃X⦄) :
  pick_killx k s t ⊆ s.
Proof.
  unfold pick_killx. rewrite pick_incl. clear;cset_tac.
Qed.

Lemma pick_killx_card (X:Type) `{OrderedType X} (k:nat) (s t : ⦃X⦄) :
  S (cardinal s) - k <= cardinal (s \t ∪ (s ∩ t))
  -> S (cardinal s) - k  <= cardinal (pick_killx k s t).
Proof.
  intros card.
  unfold pick_killx. rewrite <-pick_card; eauto.
Qed.

Lemma pick_killx_eq (X:Type) `{OrderedType X} (k:nat) (s t : ⦃X⦄) :
  S (cardinal s) - k <= cardinal (s \ t)
  -> pick_killx k s t [=] (s \ t).
Proof.
  apply pick_eq'.
Qed.

(* pick_load *)
Definition pick_load (X:Type) `{OrderedType X} (k:nat)  (r m sp l fv : ⦃X⦄) : ⦃X⦄
  := let l' := l ∩ (sp ∩ r ∪ m) in
     (fv ∩ r ∩ l') ∪ pick (k - cardinal (fv ∩ r)) (fv \ r) (l' \ (fv ∩ r)).

Lemma incl_pick_load (X:Type) `{OrderedType X} (k:nat)  (r m sp l fv : ⦃X⦄) :
  fv ∩ r ∩ (l ∩ (sp ∩ r ∪ m)) ∪ fv \ r ⊆ pick_load k r m sp l fv.
Proof.
  unfold pick_load. rewrite <-incl_pick. reflexivity.
Qed.

Lemma pick_load_eq (X:Type) `{OrderedType X} (k:nat)  (r m sp l fv : ⦃X⦄) :
  sp ⊆ r
  -> l ⊆ sp ∪ m
  -> fv \ r ⊆ l
  -> cardinal (fv ∪ l) <= k
  -> pick_load k r m sp l fv [=] l.
Proof.
  intros spr lspm fvrl card.
  assert (sp ∩ r [=] sp) as speq by (apply inter_subset_equal; eauto).
  assert (l ∩ (sp ∩ r ∪ m) [=] l) as leq
      by (apply inter_subset_equal in lspm; rewrite speq, lspm; eauto).
  unfold pick_load.
  rewrite pick_eq.
  - rewrite leq. clear - fvrl. cset_tac.
  - rewrite leq. rewrite <-union_cardinal.
    + apply Nat.le_add_le_sub_r.
      rewrite <-union_cardinal.
      * rewrite subset_cardinal; eauto. clear; cset_tac.
      * clear. intros. intro N. cset_tac.
    + clear. intros. intro N. cset_tac.
Qed.

Lemma pick_load_incl (X:Type) `{OrderedType X} (k:nat) (r m sp l fv : ⦃X⦄) :
  pick_load k r m sp l fv ⊆ (sp ∩ r) ∪ m ∪ (fv \ r).
Proof.
  unfold pick_load. rewrite pick_incl. cset_tac.
Qed.

Lemma pick_load_card (X:Type) `{OrderedType X} (k:nat) (r m sp l fv : ⦃X⦄) :
  cardinal fv <= k -> cardinal (pick_load k r m sp l fv) <= k - cardinal (fv ∩ r \ (l ∩ (sp ∪ m))) .
Proof.
  assert (fv ∩ r \ (l ∩ (sp ∪ m)) [=] (fv ∩ r) \ (l ∩ (sp ∩ r ∪ m))) as seteq by (clear; cset_tac).
  intros card. unfold pick_load. rewrite union_cardinal.
  - rewrite pick_card'; eauto.
    + apply Nat.le_add_le_sub_r. setoid_rewrite plus_comm at 2. rewrite <-plus_assoc.
      rewrite seteq.
      rewrite <-union_cardinal; [|clear;intros;intro N;cset_tac].
      setoid_rewrite <-set_decomp with (s:=fv ∩ r).
      assert (cardinal (fv ∩ r) <= k).
      { rewrite subset_cardinal; eauto. clear;cset_tac. }
      omega.
    + apply Nat.le_add_le_sub_r. rewrite <-union_cardinal; [|clear;cset_tac].
      rewrite union_comm, <-set_decomp. eauto.
  - clear. intros. intro N. dcr. rewrite pick_incl in H1. cset_tac.
Qed.