(*|
###################################################################
How to prove that terms of a first-order language are well-founded?
###################################################################

:Link: https://stackoverflow.com/q/52087304
|*)

(*|
Question
********

Currently, I've started working on proving theorems about first-order
logic in Coq (`VerifiedMathFoundations
<https://github.com/georgydunaev/VerifiedMathFoundations>`__). I've
proved deduction theorem, but then I got stuck with lemma 1 for
theorem of correctness. So I've formulated one elegant piece of the
lemma compactly and I invite the community to look at it. That is an
incomplete the proof of well-foundness of the terms. How to get rid of
the pair of ``admit``\ s properly?
|*)

(* PUBLIC DOMAIN *)
Require Export Coq.Vectors.Vector.
Require Export Coq.Lists.List.
Require Import Bool.Bool.
Require Import Logic.FunctionalExtensionality.
Require Import Coq.Program.Wf.

Definition SetVars  := nat.
Definition FuncSymb := nat.
Definition PredSymb := nat.
Record FSV :=
  {
  fs : FuncSymb;
  fsv : nat;
  }.
Record PSV :=
  MPSV {
      ps : PredSymb;
      psv : nat;
    }.
Inductive Terms : Type :=
| FVC :> SetVars -> Terms
| FSC (f : FSV) : Vector.t Terms (fsv f) -> Terms.

Definition rela : forall (x y : Terms), Prop.
Proof.
  fix rela 2. intros x y. destruct y as [s|f t].
  - exact False.
  - refine (or _ _).
    exact (Vector.In x t).
    simple refine (@Vector.fold_left Terms Prop _ False (fsv f) t).
    intros Q e.
    exact (or Q (rela x e)).
Defined.

Definition snglV {A} (a : A) := Vector.cons A a 0 (Vector.nil A).

Definition wfr : @well_founded Terms rela.
Proof.
  clear. unfold well_founded.
  assert (H : forall (n:Terms) (a:Terms), (rela a n) -> Acc rela a).
  { fix iHn 1. destruct n.
    - simpl. intros a b. destruct b.
    - simpl. intros a Q. destruct Q as [L|R].
      + admit.
        (* smth like apply Acc_intro. intros m Hm. apply (iHn a). exact Hm. *)
      + admit.
        (* like in /Arith/Wf_nat.v *)
  }
  intros a. simple refine (H _ _ _).
  exact (FSC (Build_FSV 0 1) (snglV a)).
  simpl. apply or_introl. constructor.
Fail Defined. (* .fails *)
Admitted. (* .none *)

(*|
It is also available here: `pastebin
<https://pastebin.com/UqpxM5Xb>`__.

*Update:* At least transitivity is needed for well-foundness. I also
started a proof, but didn't finished.
|*)

Fixpoint Tra (a b c : Terms) (Hc : rela c b) (Hb : rela b a) {struct a} :
  rela c a.
Proof.
  destruct a.
  - simpl in * |- *. exact Hb.
  - simpl in * |- *. destruct Hb.
    + apply or_intror. revert f t H . fix RECU 1. intros f t H.
    (* ... *)
Admitted.

(*|
Answer
******

You can do it by defining a height function on ``Terms``, and showing
that decreasing ``rela`` implies decreasing heights:
|*)

Reset Initial. (* .none *)
Require Export Coq.Vectors.Vector.
Require Export Coq.Lists.List.
Require Import Bool.Bool.
Require Import Logic.FunctionalExtensionality.
Require Import Coq.Program.Wf.

Definition SetVars  := nat.
Definition FuncSymb := nat.
Definition PredSymb := nat.
Record FSV :=
  {
  fs : FuncSymb;
  fsv : nat;
  }.
Record PSV :=
  MPSV {
      ps : PredSymb;
      psv : nat;
    }.

Unset Elimination Schemes.
Inductive Terms : Type :=
| FVC :> SetVars -> Terms
| FSC (f : FSV) : Vector.t Terms (fsv f) -> Terms.
Set Elimination Schemes.

Definition Terms_rect (T : Terms -> Type)
           (H_FVC : forall sv, T (FVC sv))
           (H_FSC : forall f v,
               (forall n, T (Vector.nth v n)) -> T (FSC f v)) :=
  fix loopt (t : Terms) : T t :=
    match t with
    | FVC sv  => H_FVC sv
    | FSC f v =>
      let fix loopv s (v : Vector.t Terms s) : forall n, T (Vector.nth v n) :=
          match v with
          | @Vector.nil _ => Fin.case0 _
          | @Vector.cons _ t _ v =>
            fun n =>
              Fin.caseS' n (fun n => T (Vector.nth (Vector.cons _ t _ v) n))
                         (loopt t)
                         (loopv _ v)
          end in
      H_FSC f v (loopv _ v)
    end.

Definition Terms_ind := Terms_rect.

Fixpoint height (t : Terms) : nat :=
  match t with
  | FVC _ => 0
  | FSC f v => S (Vector.fold_right (fun t acc => Nat.max acc (height t)) v 0)
  end.

Definition rela : forall (x y : Terms), Prop.
Proof.
  fix rela 2. intros x y. destruct y as [s|f t].
  - exact False.
  - refine (or _ _). exact (Vector.In x t).
    simple refine (@Vector.fold_left Terms Prop _ False (fsv f) t).
    intros Q e. exact (or Q (rela x e)).
Defined.

Require Import Lia.

Definition wfr : @well_founded Terms rela.
Proof.
  apply (Wf_nat.well_founded_lt_compat _ height).
  intros t1 t2. induction t2 as [sv2|f2 v2 IH]; simpl; try easy.
  intros [t_v|t_sub]; apply Lt.le_lt_n_Sm.
  { clear IH. induction t_v; simpl; lia. }
  revert v2 IH t_sub. generalize (fsv f2). clear f2.
  intros k v2 IH t_sub.
  enough (H : exists n, rela t1 (Vector.nth v2 n)).
  { destruct H as [n H]. apply IH in H. clear IH t_sub.
    transitivity (height (Vector.nth v2 n)); try lia; clear H.
    induction v2 as [|t2 m v2 IHv2].
    - inversion n.
    - apply (Fin.caseS' n); clear n; simpl; try lia.
      intros n. specialize (IHv2 n). lia. }
  clear IH.
  assert (H : Vector.fold_right (fun t Q => Q \/ rela t1 t) v2 False).
  { revert t_sub. generalize False.
    induction v2 as [|t2 n v2]; simpl in *; trivial.
    intros P H. specialize (IHv2 _ H). clear H.
    induction v2 as [|t2' n v2 IHv2']; simpl in *; tauto. }
  clear t_sub.
  induction v2 as [|t2 k v2 IH]; simpl in *; try easy.
  destruct H as [H|H].
  - apply IH in H. destruct H as [n Hn]. now (exists (Fin.FS n)).
  - now exists Fin.F1.
Qed.

(*|
(Note the use of the custom induction principle, which is needed
because of the nested inductives.)

This style of development, however, is too complicated. Avoiding
certain pitfalls would greatly simplify it:

1. The Coq standard vector library is too hard to use. The issue here
   is exacerbated because of the nested inductives. It would probably
   be better to use plain lists and have a separate well-formedness
   predicate on terms.

2. Defining a relation such as ``rela`` in proof mode makes it harder
   to read. Consider, for instance, the following simpler alternative:
|*)

Reset rela. (* .none *)
Fixpoint rela x y :=
  match y with
  | FVC _ => False
  | FSC f v =>
    Vector.In x v \/
    Vector.fold_right (fun z P => rela x z \/ P) v False
  end.

(*|
3. Folding left has a poor reduction behavior, because it forces us to
   generalize over the accumulator argument to get the induction to go
   through. This is why in my proof I had to switch to a
   ``fold_right``.
|*)


(* Authors: Christian Doczkal and Jan-Oliver Kaiser *)
(* Distributed under the terms of CeCILL-B. *)
From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq choice.
From mathcomp Require Import fintype path fingraph finfun finset generic_quotient.
From RegLang Require Import misc languages dfa.

Set Default Proof Using "Type".

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

Local Open Scope quotient_scope.

(** * DFA Minimization *)

Section Minimization.
Variable (char : finType).
Local Notation word := (word char).
Local Notation dfa := (dfa char).

Definition coll (A : dfa) x y := forall w, (delta x w \in dfa_fin A) = (delta y w \in dfa_fin A).

Definition connected (A : dfa) := surjective (delta_s A).
Definition collapsed (A : dfa) := forall x y: A, coll x y <-> x = y.
Definition minimal (A : dfa) := forall B, dfa_lang A =i dfa_lang B -> #|A| <= #|B|.

(** ** Uniqueness of connected and collapsed automata *)

Definition dfa_iso (A1 A2 : dfa) :=
  exists i: A1 -> A2,
    [/\ bijective i,
        forall x a, i (dfa_trans x a) = dfa_trans (i x) a,
        forall x, i (x) \in dfa_fin A2 = (x \in dfa_fin A1) &
        i (dfa_s A1) = dfa_s A2 ].

Section Isomopism.
  Variables (A B : dfa).
  Hypothesis L_AB : dfa_lang A =i dfa_lang B.

  Hypothesis (A_coll: collapsed A) (B_coll: collapsed B).
  Hypothesis (A_conn : connected A) (B_conn : connected B).

  Definition iso := delta_s B \o cr A_conn.
  Definition iso_inv := delta_s A \o cr B_conn.

  Lemma delta_iso w x : delta (iso x) w \in dfa_fin B = (delta x w \in dfa_fin A).
  Proof using L_AB. by rewrite -{2}[x](crK (Sf := A_conn)) -!delta_cat !delta_lang L_AB. Qed.

  Lemma delta_iso_inv w x : delta (iso_inv x) w \in dfa_fin A = (delta x w \in dfa_fin B).
  Proof using L_AB. by rewrite -{2}[x](crK (Sf := B_conn)) -!delta_cat !delta_lang L_AB. Qed.

  Lemma can_iso : cancel iso_inv iso.
  Proof using B_coll L_AB. move => x. apply/B_coll => w. by rewrite delta_iso delta_iso_inv. Qed.

  Lemma can_iso_inv : cancel iso iso_inv.
  Proof using A_coll L_AB. move => x. apply/A_coll => w. by rewrite delta_iso_inv delta_iso. Qed.

  Lemma coll_iso : dfa_iso A B.
  Proof using A_coll B_coll A_conn B_conn L_AB.
    exists iso. split.
    - exact: Bijective can_iso_inv can_iso.
    - move => x a. apply/B_coll => w. rewrite -[_ (iso x) a]/(delta (iso x) [::a]).
      by rewrite -delta_cat -!delta_iso_inv !can_iso_inv.
    - move => x. by rewrite -[iso x]/(delta _ [::]) delta_iso.
    - apply/B_coll => w. by rewrite delta_iso !delta_lang.
  Qed.

  Lemma dfa_iso_size : dfa_iso A B -> #|A| = #|B|.
  Proof. move => [iso [H _ _ _]]. exact (bij_card H). Qed.
End Isomopism.

Lemma abstract_minimization A f :
  (forall B, dfa_lang (f B) =i dfa_lang B /\ #|f B| <= #|B| /\ connected (f B) /\ collapsed (f B))
  -> minimal (f A).
Proof.
  move => H B L_AB. apply: (@leq_trans #|f B|); last by firstorder. apply: eq_leq.
  apply: dfa_iso_size. (apply: coll_iso; try apply H) => w. rewrite L_AB. by case (H B) => ->.
Qed.

(** ** Construction of the Connected Sub-Automaton *)

Section Prune.
  Variable A : dfa.

  Definition reachable (q:A) := exseq_dec (@delta_rc _ A) (pred1 q).
  Definition connectedb := [forall x: A, reachable x].

  Lemma connectedP : reflect (connected A) (connectedb).
  Proof.
    apply: (iffP forallP) => H y; first by move/dec_eq: (H y).
    apply/dec_eq. case (H y) => x Hx. by exists x.
  Qed.

  Definition reachable_type := { x:A | reachable x }.

  Lemma reachable_trans_proof (x : reachable_type) a : reachable (dfa_trans (val x) a).
  Proof.
    apply/dec_eq. case/dec_eq : (svalP x) =>  /= y /eqP <-.
    exists (y++[::a]). by rewrite delta_cat.
  Qed.

  Definition reachable_trans (x : reachable_type) a : reachable_type :=
    Sub (dfa_trans (val x) a) (reachable_trans_proof x a).

  Lemma reachabe_s_proof : reachable (dfa_s A).
  Proof. apply/dec_eq. exists nil. exact: eqxx. Qed.

  Definition reachable_s : reachable_type := Sub (dfa_s A) reachabe_s_proof.

  Definition dfa_prune := {|
      dfa_s := reachable_s;
      dfa_fin := [set x | val x \in dfa_fin A];
      dfa_trans := reachable_trans |}.

  Lemma dfa_prune_correct : dfa_lang dfa_prune =i dfa_lang A.
  Proof.
    rewrite /dfa_lang /= -[dfa_s A]/(val reachable_s) => w.
    rewrite !inE. elim: w (reachable_s) => [|a w IHw] [x Hx] //=.
    + by rewrite /dfa_accept inE.
    + by rewrite accE IHw.
  Qed.

  Lemma dfa_prune_connected : connected dfa_prune.
  Proof.
    move => q. case/dec_eq: (svalP q) => /= x Hx. exists x.
    elim/last_ind : x q Hx => //= x a IHx q.
    rewrite -!cats1 /delta_s !delta_cat -!/(delta_s _ x) => H.
    have X : reachable (delta_s A x). apply/dec_eq; exists x. exact: eqxx.
    by rewrite (eqP (IHx (Sub (delta_s A x) X) _)).
  Qed.

  Hint Resolve dfa_prune_connected : core.

  Lemma dfa_prune_size : #|dfa_prune| <= #|A|.
  Proof. by rewrite card_sig subset_leq_card // subset_predT. Qed.

  (** If pruning does not remove any states, the automaton is connected *)

  Lemma prune_eq_connected : #|A| = #|dfa_prune| -> connected A.
  Proof.
    move => H. apply/connectedP. apply/forallP => x.
    by move: (cardT_eq (Logic.eq_sym H)) ->.
  Qed.

End Prune.

(** ** Quotient modulo collapsing relation

For the minimization of connected automata we construct the quotient of the
input automaton with respect to the collapsing relation. To form the quotient
constructively, we have to show that the collapsing relation is decidable. *)

Section Collapse.
  Variable A : dfa.

  (** Decidabilty of the collapsing relation   *)

  Definition coll_fun (p q : A) x := (delta p x,delta q x).

  Lemma coll_fun_RC p q x y a :
    coll_fun p q x = coll_fun p q y -> coll_fun p q (x++[::a]) = coll_fun p q (y++[::a]).
  Proof. move => [H1 H2]. by rewrite /coll_fun !delta_cat H1 H2. Qed.

  Definition collb p q : bool :=
    allseq_dec (@coll_fun_RC p q) [pred p | (p.1 \in dfa_fin A) == (p.2 \in dfa_fin A)].

  Lemma collP p q : reflect (coll p q) (collb p q).
  Proof.
    apply: (iffP idP).
    - move/dec_eq => H x. by move/eqP: (H x).
    - move => H. apply/dec_eq => x. apply/eqP. exact: H.
  Qed.

  Lemma collb_refl x : collb x x.
  Proof. apply/collP. rewrite /coll. auto. Qed.

  Lemma collb_sym : symmetric collb.
  Proof. move => x y. by apply/collP/collP; move => H w; rewrite H. Qed.

  Lemma collb_trans : transitive collb.
  Proof. move => x y z /collP H1 /collP H2. apply/collP => w. by rewrite H1 H2. Qed.

  Lemma collb_step a x y : collb x y -> collb (dfa_trans x a) (dfa_trans y a).
  Proof. move => /collP H. apply/collP => w. by rewrite !delta_cons H. Qed.

  (** We make collb the canonical equivalence relation on [A] and take
  the corresponding quotient type as state space for the minimized automaton *)

  Canonical collb_equiv := EquivRelPack (EquivClass collb_refl collb_sym collb_trans).

  Definition collapse_state := {eq_quot collb_equiv}.

  Canonical min_quotType := [quotType of collapse_state].
  Canonical min_subType := [subType collapse_state of A by %/].
  Canonical min_eqType := EqType _ [eqMixin of collapse_state by <:%/].
  Canonical min_choiceType := ChoiceType _ [choiceMixin of collapse_state by <:%/].
  Canonical min_finType := FinType _ [finMixin of min_eqType by <:%/].
  Canonical min_subFinType := [subFinType of collapse_state].

  Definition collapse : dfa := {|
    dfa_s := \pi_(collapse_state) (dfa_s A);
    dfa_trans x a := \pi (dfa_trans (repr x) a);
    dfa_fin := [set x : collapse_state | repr x \in dfa_fin A ] |}.

  Lemma collapse_delta (x : A) w :
    delta (\pi x : collapse) w = \pi (delta x w).
  Proof.
    elim: w x => //= a w IHw x. rewrite -IHw. f_equal.
    apply/eqmodP. apply: collb_step. exact: epiK.
  Qed.

  Lemma collapse_fin (x : A) :
    (\pi x \in dfa_fin collapse) = (x \in dfa_fin A).
  Proof.
    rewrite /collapse /= inE.
    by move/collP: (epiK collb_equiv x) => /(_ [::]).
  Qed.

End Collapse.

(** ** Correctness of Minimization *)

(** Minimization yields a fully collapsed DFA accepting the same language *)

Lemma collapse_collapsed (A  : dfa) : collapsed (collapse A).
Proof.
  split => [H|->]; last by apply/collP; exact: collb_refl.
  rewrite -[x]reprK -[y]reprK. apply/eqmodP/collP => w.
  by rewrite -!collapse_fin -!collapse_delta !reprK.
Qed.

Lemma collapse_correct A : dfa_lang (collapse A) =i dfa_lang A.
Proof.
  move => w. rewrite !inE /dfa_accept {1}/dfa_s /= inE collapse_delta.
  by rewrite -!collapse_fin reprK.
Qed.

Lemma collapse_size A : #|collapse A| <= #|A|.
Proof. rewrite card_sub. exact: max_card. Qed.

Lemma collapse_connected A : connected A -> connected (collapse A).
Proof.
  move => H x. case: (H (repr x)) => w /eqP Hw. exists w.
  by rewrite /delta_s collapse_delta -/(delta_s A w) Hw reprK.
Qed.

(** Combine pruning and collapsing into minimization function *)

Definition minimize := collapse \o dfa_prune.

Lemma minimize_size (A : dfa) : #|minimize A| <= #|A|.
Proof. exact: leq_trans (collapse_size _) (dfa_prune_size _). Qed.

Lemma minimize_collapsed (A : dfa) : collapsed (minimize A).
Proof. exact: collapse_collapsed. Qed.

Lemma minimize_connected (A : dfa) : connected (minimize A).
Proof. apply collapse_connected. exact: dfa_prune_connected. Qed.

Lemma minimize_correct (A : dfa) : dfa_lang (minimize A) =i dfa_lang A.
Proof. move => x. by rewrite collapse_correct dfa_prune_correct. Qed.

Hint Resolve minimize_size minimize_collapsed minimize_connected : core.

Lemma minimize_minimal A : minimal (minimize A).
Proof. apply: abstract_minimization => B. auto using minimize_correct. (* and hints *) Qed.

(** ** Uniqueness of minimal automaton *)

Lemma minimal_connected A : minimal A -> connected A.
Proof.
  move => MA. apply: prune_eq_connected.
  apply/eqP. rewrite eqn_leq dfa_prune_size andbT.
  apply: MA => x. by rewrite dfa_prune_correct.
Qed.

Lemma minimal_collapsed A : minimal A -> collapsed A.
Proof.
  move => MA.
  have B : bijective (\pi_(collapse_state A)).
    apply: surj_card_bij.
    - move => x. exists (repr x). by rewrite reprK.
    - apply/eqP. rewrite eqn_leq collapse_size (MA (collapse A)) // => x.
      by rewrite collapse_correct.
  move => x y. split => [|->]; last exact/collP/collb_refl.
  move/collP/eqmodP. exact: bij_inj.
Qed.

(** In order to generalize the reasoning above to arbitrary quotients
types over finite types we would first have to ensure that [{eq_quot e}]
inherits the finType structure on the carrier of [e]. By default
this is not the case *)

Lemma minimalP A : minimal A <-> (connected A /\ collapsed A).
Proof.
  split.
  - move => H. split. exact: minimal_connected. exact: minimal_collapsed.
  - move => [H1 H2] B L_AB. apply: leq_trans _ (minimize_size _). apply: eq_leq.
    apply: dfa_iso_size. apply: coll_iso => // x. by rewrite minimize_correct.
Qed.

Lemma minimal_iso A B :
  dfa_lang A =i dfa_lang B -> minimal A -> minimal B -> dfa_iso A B.
Proof. move => L_AB /minimalP [? ?] /minimalP [? ?]. exact: coll_iso. Qed.

End Minimization.


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

(* Contribution to the Coq Library   V6.3 (July 1999)                    *)
(****************************************************************************)
(*                                                                          *)
(*                                Coq V6.3                                  *)
(*                                                                          *)
(*                 A choice axiom that entails excluded middle              *)
(*                                                                          *)
(* Following ideas of Diaconescu, Goodman, Myhill and Lacas.                *)
(*                                                                          *)
(*                             Benjamin Werner                              *)
(*                                                                          *)
(*                                  1997                                    *)
(****************************************************************************)

Section TTDiaconescu.

(* Definition of what is an equivalence relation *)

Definition EquivRel (A : Set) (R : A -> A -> Prop) :=
  (forall x : A, R x x) /\
  (forall x y : A, R x y -> R y x) /\
  (forall x y z : A, R x y -> R y z -> R x z).

(* The axiom of choice *)

Definition Tchoice :=
  forall (A : Set) (R : A -> A -> Prop),
  EquivRel A R ->
  ex
    (fun f : A -> A =>
     (forall x : A, R x (f x)) /\ (forall x y : A, R x y -> f x = f y)).

Hypothesis TTCA : Tchoice.

(* The proposition to be decided  *)

Hypothesis P : Prop.

(* The relation R *)

Inductive rel : bool -> bool -> Prop :=
  | rrefl : forall b : bool, rel b b
  | rel2 : forall b c : bool, P -> rel b c.

Hint Resolve rrefl rel2.

(* R is an equivalence relation *)
Lemma rel_trans : forall x y z : bool, rel x y -> rel y z -> rel x z.
intros x y z h1; inversion h1; auto.
Qed.

Lemma rel_sym : forall x y : bool, rel x y -> rel y x.
intros x y h; inversion h; auto.
Qed.

Hint Resolve rel_sym rel_trans.

Lemma rel_equiv : EquivRel bool rel.
split; auto; split; intros; eauto.
Qed.

(* equality is decidable over booleans -- of course  *)
Lemma eq_bool_dec : forall a b : bool, a = b \/ a <> b.
simple induction a; simple induction b; auto; try (right; discriminate).
Qed.

(* The proof of the excluded middle  *)
Theorem EM : P \/ ~ P.

(* first we exhibit the choice function f *)
elim (TTCA bool rel rel_equiv).
intros f; simple induction 1; intros hf1 hf2.

(* the actual "decision": compare (f true) and (f false) *)
elim (eq_bool_dec (f true) (f false)); intros h.

(* case where P is true *)
cut (rel true false).
intros hr; inversion hr; auto.
apply rel_trans with (f true); auto.

rewrite h.
apply rel_sym; auto.

(* case where P is false *)
right; unfold not in |- *; intros p.
apply h.
apply hf2.
auto.

Qed.

End TTDiaconescu.

(* We obtain the closed term   EM : Tchoice->(P:Prop)P\/~P        *)

(************************************************************)
(* A variant, using another formulation of the choice axiom *)
(************************************************************)

Inductive EXType (A : Type) (P : A -> Prop) : Prop :=
    EXi : forall a : A, P a -> EXType A P.

Section TTDiaconescu2.

(* The axiom of choice *)

Definition Tchoice2 :=
  forall (A : Set) (R : A -> A -> Prop),
  EquivRel A R ->
  EXType (A -> Prop)
    (fun P : A -> Prop =>
     (forall x : A, ex (fun y : A => R x y /\ P y)) /\
     (forall x y : A, R x y -> P x -> P y -> x = y)).

Hypothesis TTAC2 : Tchoice2.

Hypothesis P : Prop.

Definition rel' := rel P.

Hint Resolve rel2.

Lemma EM2 : P \/ ~ P.
elim (TTAC2 bool rel' (rel_equiv P)).
intro Q; simple induction 1; intros hQ1 hQ2.
elim (hQ1 true); intros w_true; simple induction 1; intros ht1 ht2.
elim (hQ1 false); intros w_false; simple induction 1; intros hf1 hf2.
elim (eq_bool_dec w_true w_false); intro e.
left; cut (rel' true false).
intro hr; inversion hr; auto.
unfold rel' in |- *; apply rel_trans with w_true; auto.
apply rel_sym; rewrite e; auto.
right; unfold not in |- *; intro p; apply e; auto.
apply hQ2; auto.
unfold rel' in |- *; auto.
Qed.

End TTDiaconescu2.


(* infotheo (c) AIST. R. Affeldt, M. Hagiwara, J. Senizergues. GNU GPLv3. *)
From mathcomp Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq div choice fintype.
From mathcomp Require Import tuple finfun bigop prime binomial ssralg finset fingroup finalg.
From mathcomp Require Import perm zmodp matrix.
Require Import Reals Fourier FunctionalExtensionality ProofIrrelevance.
Require Import Reals_ext ssr_ext ssralg_ext Rssr log2 Rbigop proba entropy.
Require Import num_occ channel_code channel typ_seq.

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

Local Open Scope entropy_scope.
Local Open Scope num_occ_scope.
Local Open Scope Rb_scope.

Module type.

Section type_def.

Variable A : finType.
Variable n : nat.

(** * Type definition *)

Record type : predArgType := mkType {
  d :> dist A ;
  f : {ffun A -> 'I_n.+1} ;
  d_f : forall a, d a = INR (f a) / INR n }.

End type_def.

End type.

Coercion type_coercion := type.d.

Notation "'P_' n '(' A ')'" := (type.type A n) (at level 9, n, A at next level) : types_scope.

Local Open Scope types_scope.

Lemma type_fun_type A n (_ : n != O) (P : P_ n ( A )) a : INR ((type.f P) a) = INR n * P a.
Proof.
destruct P => /=.
rewrite d_f mulRA Rinv_r_simpl_m //.
apply not_0_INR; by apply/eqP.
Qed.

Lemma INR_type_fun A n (P : P_ n ( A )) a : INR ((type.f P) a) / INR n = P a.
Proof. destruct P as [d f d_f] => /=. by rewrite d_f. Qed.

Lemma no_0_type A (d : dist A) (t : {ffun A -> 'I_1}) :
  (forall a, d a = INR (t a) / INR 0) -> False.
Proof.
move=> H.
apply R1_neq_R0.
rewrite -(pmf1 d).
transitivity (\rsum_(a | a \in A) INR (t a) / 0); first by apply eq_bigr.
rewrite -big_distrl /= -(@big_morph _ _ _ 0 _ O _ morph_plus_INR) //.
rewrite (_ : \sum_(a in A) _ = O); first by rewrite Rmult_0_l.
transitivity (\sum_(a in A) 0); first by apply eq_bigr => a _; rewrite (ord1 (t a)).
by rewrite big_const iter_addn.
Qed.

Definition type_of_tuple (A : finType) n (ta : n.+1.-tuple A) : P_ n.+1 ( A ).
set f := fun a => INR N(a | ta) / INR n.+1.
assert (H1 : forall a, (0 <= f a)%R).
  move=> a.
  rewrite /f.
  apply Rle_mult_inv_pos; by [apply pos_INR | apply lt_0_INR; apply/ltP].
assert (H2 : \rsum_(a in A) f a = 1%R).
  rewrite /f -big_distrl /= -(@big_morph _ _ _ 0 _ O _ morph_plus_INR) //.
  rewrite sum_num_occ_alt Rinv_r //; apply not_0_INR; by apply/eqP.
have H : forall a, (N(a | ta) < n.+2)%nat.
  move=> a; rewrite ltnS; by apply num_occ_leq_n.
refine (@type.mkType _ n.+1 (@mkDist _ (@mkPosFun _ f H1) H2)
  [ffun a => @Ordinal n.+2 (N(a | ta)) (H a)] _).
move=> a /=; by rewrite /f ffunE.
Defined.

Definition ffun_of_type A n (P : P_ n ( A )) := let: type.mkType _ f _ := P in f.

Lemma type_proj_eq A n (t1 t2 : P_ n ( A )) : type.f t1 = type.f t2 -> t1 = t2.
Proof.
case: t1 t2 => d1 f1 H1 /= [] d2 f2 H2 /= f1f2.
subst f2.
suff ? : d1 = d2.
  subst d2.
  f_equal.
  by apply proof_irrelevance.
apply dist_eq => /=.
apply pos_fun_eq => /=.
apply functional_extensionality => a /=.
by rewrite H1 H2.
Qed.

Definition type_eq A n (t1 t2 : P_ n ( A )) :=
  match t1, t2 with
    | type.mkType _ f1 _, type.mkType _ f2 _ => f1 == f2
  end.

Lemma type_eqP A n : Equality.axiom (@type_eq A n).
Proof.
case=> d1 f1 H1 [] d2 f2 H2 /=.
apply: (iffP idP).
- move/eqP => H; subst f2.
  suff ? : d1 = d2.
    subst d2.
    f_equal.
    by apply proof_irrelevance.
  apply dist_eq => /=.
  apply pos_fun_eq => /=.
  apply functional_extensionality => a.
  by rewrite H1 H2.
by case => _ ->.
Qed.

Definition type_eqMixin A n := EqMixin (@type_eqP A n).
Canonical type_eqType A n := Eval hnf in EqType _ (@type_eqMixin A n).

Lemma type_ffunP A n (P Q : P_ n.+1 ( A )) :
  (forall c, P c = Q c) -> P = Q.
Proof.
move=> H.
destruct P as [d1 f1 H1].
destruct Q as [d2 f2 H2].
rewrite /= in H.
apply/type_eqP => /=.
apply/eqP/ffunP => a.
move: {H}(H a).
rewrite H1 H2.
move/Rmult_eq_reg_r.
have Htmp : / INR n.+1 <> 0.
  apply Rinv_neq_0_compat.
  apply not_0_INR; by apply/eqP.
move/(_ Htmp).
move/INR_eq => {Htmp}Htmp.
by apply val_inj.
Qed.

Definition pos_fun_of_ffun (A : finType) n (f : {ffun A -> 'I_n.+2}) : pos_fun A.
set d := fun a : A => INR (f a) / INR n.+1.
refine (@mkPosFun _ d _) => a.
apply Rle_mult_inv_pos; by [apply pos_INR  | apply lt_0_INR; apply/ltP].
Defined.

Definition dist_of_ffun (A : finType) n (f : {ffun A -> 'I_n.+2})
  (Hf : \sum_(a in A) f a == n.+1) : dist A.
set pf := pos_fun_of_ffun f.
assert (H : \rsum_(a in A) pf a = 1).
  rewrite /pf /= /Rdiv -big_distrl /= -(@big_morph _ _ _ 0 _ O _ morph_plus_INR) //.
  move/eqP : Hf => ->.
  rewrite Rinv_r //; by apply not_0_INR.
exact (mkDist H).
Defined.

Lemma dist_of_ffun_prop (A : finType) n (f : {ffun A -> 'I_n.+2})
  (Hf : \sum_(a in A) f a == n.+1) :
forall a : A, (dist_of_ffun Hf) a = INR (f a) / INR n.+1.
Proof. by move=> a. Qed.

Definition type_choice_f (A : finType) n (f : {ffun A -> 'I_n.+1}) : option (P_ n ( A )).
destruct n; first by exact None.
refine (match Sumbool.sumbool_of_bool (\sum_(a in A) f a == n.+1) with
          | left H => Some (@type.mkType _ _ (dist_of_ffun H) f (dist_of_ffun_prop H))
          | right _ => None
        end).
Defined.

Lemma ffun_of_dist A n (d : dist A) (t : {ffun A -> 'I_n.+2})
  (H : forall a : A, d a = INR (t a) / INR n.+1) : \sum_(a in A) t a == n.+1.
Proof.
suff : INR (\sum_(a in A) t a) == INR n.+1 * \rsum_(a | a \in A) d a.
  move/eqP.
  rewrite (pmf1 d) mulR1.
  by move/INR_eq/eqP.
apply/eqP.
transitivity (INR n.+1 * (\rsum_(a|a \in A) INR (t a) / INR n.+1)).
  rewrite -big_distrl -(@big_morph _ _ _ 0 _ O _ morph_plus_INR) //.
  rewrite mulRA Rinv_r_simpl_m //; by apply not_0_INR.
f_equal; by apply eq_bigr.
Qed.

Lemma type_choice_pcancel A n : pcancel (@type.f A n) (@type_choice_f A n).
Proof.
case=> d t H /=.
destruct n.
  by move: (no_0_type H).
rewrite /type_choice_f /=; f_equal.
move: (ffun_of_dist H) => H'.
destruct Sumbool.sumbool_of_bool as [e|e]; last first.
  by rewrite H' in e.
f_equal.
set d1 := dist_of_ffun _.
suff ? : d1 = d.
  subst d; f_equal; by apply proof_irrelevance.
apply dist_eq => /=.
apply pos_fun_eq => /=.
apply functional_extensionality => a.
by rewrite H.
Qed.

Lemma type_choiceMixin A n : choiceMixin (P_ n ( A )).
Proof. apply (PcanChoiceMixin (@type_choice_pcancel A n)). Qed.

Canonical type_choiceType A n := Eval hnf in ChoiceType _ (type_choiceMixin A n).

Definition type_pickle A n (P : P_ n (A)) : nat.
destruct P as [d f H].
destruct (finfun_countMixin A [finType of 'I_n.+1]) as [pi unpi Hcan].
apply (pi f).
Defined.

Definition type_unpickle A n (m : nat) : option (P_ n ( A )).
destruct n.
  exact None.
case: (finfun_countMixin A [finType of 'I_n.+2]) => pi unpi Hcan.
case: (unpi m); last first.
  exact None.
move=> f.
refine (match Sumbool.sumbool_of_bool (\sum_(a in A) f a == n.+1) with
          | left H => Some (@type.mkType _ _ (dist_of_ffun H) f (dist_of_ffun_prop H))
          | right _ => None
        end).
Defined.

Lemma type_count_pcancel A n : pcancel (@type_pickle A n) (@type_unpickle A n).
Proof.
destruct n.
  case=> d t H /=; by move: (no_0_type H).
case=> d t H /=.
rewrite pcan_pickleK; last by apply valK.
move: (ffun_of_dist H) => H'.
destruct Sumbool.sumbool_of_bool as [e|e]; last first.
  by rewrite H' in e.
f_equal.
set d1 := dist_of_ffun _.
suff ? : d1 = d.
  subst d; f_equal; by apply proof_irrelevance.
apply dist_eq, pos_fun_eq, functional_extensionality => a.
by rewrite H.
Qed.

Definition type_countMixin A n := CountMixin (@type_count_pcancel A n).
Canonical type_countType A n :=
  Eval hnf in CountType (P_ n ( A )) (@type_countMixin A n).

Definition type_enum_f (A : finType) n (f : { f : {ffun A -> 'I_n.+1} | \sum_(a in A) f a == n} ) : option (P_ n ( A )).
destruct n.
  apply None.
refine (Some (@type.mkType _ _ (dist_of_ffun (proj2_sig f)) (sval f) (dist_of_ffun_prop (proj2_sig f)))).
Defined.

Definition type_enum A n := pmap (@type_enum_f A n)
  (enum [finType of {f : {ffun A -> 'I_n.+1} | \sum_(a in A) f a == n}]).

Lemma type_enumP A n : Finite.axiom (@type_enum A n).
Proof.
destruct n.
  case=> d t H /=; by move: (no_0_type H).
case=> d t H /=.
move: (ffun_of_dist H) => H'.
have : Finite.axiom (enum [finType of { f : {ffun A -> 'I_n.+2} | \sum_(a in A) f a == n.+1}]).
  rewrite enumT; by apply enumP.
move/(_ (@exist {ffun A -> 'I_n.+2} (fun f => \sum_(a in A) f a == n.+1) t H')) => <-.
rewrite /type_enum /= /type_enum_f /= count_map.
by apply eq_count.
Qed.

Definition type_finMixin A n := Eval hnf in FinMixin (@type_enumP A n).
Canonical type_finType A n := Eval hnf in FinType _ (@type_finMixin A n).

Section type_facts.

Variable A : finType.
Local Open Scope nat_scope.

(** Upper-bound of the number of types: *)

Lemma type_counting n : #| P_ n ( A ) | <= expn (n.+1) #|A|.
Proof.
rewrite -(card_ord n.+1) -card_ffun /=.
rewrite cardE /enum_mem.
apply (@leq_trans (size (map (@ffun_of_type A n) (Finite.enum (type_finType A n))))).
  by rewrite 2!size_map.
rewrite cardE.
apply uniq_leq_size.
  rewrite map_inj_uniq //.
    move: (enum_uniq (type_finType A n)).
    by rewrite enumT.
  case=> d f Hd [] d2 f2 Hd2 /= ?; subst f2.
  have ? : d = d2.
    apply dist_eq => /=. apply pos_fun_eq => /=. apply functional_extensionality => a.
    by rewrite Hd Hd2.
  subst d2.
  f_equal.
  by apply proof_irrelevance.
move=> /= f Hf.
by rewrite mem_enum.
Qed.

Lemma type_not_empty n : 0 < #|A| -> 0 < #|P_ n.+1(A)|.
Proof.
case/card_gt0P => a _.
apply/card_gt0P.
have [f Hf] : [finType of {f : {ffun A -> 'I_n.+2} | \sum_(a in A) f a == n.+1}].
  exists [ffun a1 => if pred1 a a1 then Ordinal (ltnSn n.+1) else Ordinal (ltn0Sn n.+1)].
  rewrite (bigD1 a) //= big1; first by rewrite ffunE eqxx addn0.
  move=> p /negbTE Hp; by rewrite ffunE Hp.
exists (@type.mkType _ _ (dist_of_ffun Hf) _ (dist_of_ffun_prop Hf)).
by rewrite inE.
Qed.

Lemma type_empty1 n : #|A|= 0 -> #|P_ n(A)| = 0.
Proof.
move => Ais0.
apply eq_card0; case=> d f df.
suff : false by done.
move: (dist_support_not_empty d).
by rewrite Ais0.
Qed.

Lemma type_empty2 : #|P_ 0(A)| = 0.
Proof.
apply eq_card0; case=> d f Hf.
suff : false by done.
by move/no_0_type in Hf.
Qed.

End type_facts.

Section typed_tuples.

Variable A : finType.
Variable n : nat.
Variable P : P_ n ( A ).

Local Open Scope nat_scope.

(** * Typed Tuples *)

(** Tuples that are representative of a type: *)

Definition typed_tuples :=
  [set t : n.-tuple A | [forall a, P a == (INR N(a | t) / INR n)%R] ].

End typed_tuples.

Notation "'T_{' P '}'" := (typed_tuples P) (at level 9) : types_scope.

Section typed_tuples_facts.

Variable A : finType.
Variable n' : nat.
Let n := n'.+1.
Variable P : P_ n ( A ).

Lemma type_numocc ta (Hta : ta \in T_{P}) a : N(a | ta) = type.f P a.
Proof.
move: Hta.
rewrite in_set.
move/forallP/(_ a)/eqP.
destruct P as [d f H] => /=.
rewrite H.
move/Rmult_eq_reg_r.
have Hn : / INR n <> 0.
  apply Rinv_neq_0_compat.
  apply not_0_INR; by apply/eqP.
by move/(_ Hn)/INR_eq.
Qed.

Lemma typed_tuples_not_empty' : exists x : seq A,
  exists Hx : size x == n, Tuple Hx \in T_{P}.
Proof.
exists (flatten (map (fun x0 => nseq (type.f P x0) x0) (enum A))).
have Hx : size (flatten [seq nseq (type.f P x0) x0 | x0 <- enum A]) == n.
  rewrite size_flatten /shape -map_comp sumn_big_addn big_map.
  case: (P) => P' f HP' /=.
  apply/eqP.
  transitivity (\sum_(a in A) f a); last first.
     apply/eqP.
     by apply ffun_of_dist with P'.
  apply congr_big => //.
  by rewrite enumT.
  move=> a /= _.
  by rewrite size_nseq.
exists Hx.
rewrite inE.
apply/forallP => a.
rewrite /num_occ /= -size_filter.
rewrite filter_flatten size_flatten /shape -!map_comp sumn_big_addn big_map.
rewrite (bigD1 a) // big1 /= => [|a' Ha'].
- rewrite addn0 -(INR_type_fun P).
  apply/eqP.
  do 2 f_equal.
  rewrite -{1}(_ : size (nseq (type.f P a) a) = type.f P a); last by rewrite size_nseq.
  congr (size _).
  apply/esym/all_filterP/all_pred1P.
  by rewrite size_nseq.
- transitivity (size (@List.nil A)) => //.
  congr (size _).
  apply/eqP/negPn; rewrite -has_filter; apply/hasPn => l Hl.
  by move/mem_nseq/eqP : Hl => ->.
Qed.

Lemma typed_tuples_not_empty : { t | t \in T_{P} }.
Proof.
apply sigW.
case: typed_tuples_not_empty' => x [Hx H].
by exists (Tuple Hx).
Qed.

End typed_tuples_facts.

Section typed_tuples_facts_continued.

Variable A : finType.
Variable n : nat.
Hypothesis Hn : n != O.
Variable P : P_ n ( A ).

Lemma typed_tuples_not_empty_alt : {t : n.-tuple A | t \in T_{P}}.
Proof. destruct n => //. apply typed_tuples_not_empty. Qed.

Local Open Scope proba_scope.
Local Open Scope tuple_ext_scope.
Local Open Scope vec_ext_scope.

Lemma tuple_dist_type t : tuple_of_row t \in T_{P} ->
  P `^ n t = \rmul_(a : A) P a ^ (type.f P a).
Proof.
move=> Hx.
rewrite (_ : P `^ n t = TupleDist.f P t) // /TupleDist.f.
rewrite (_ : \rmul_(i < n) P (t ``_ i) =
  \rmul_(a : A) (\rmul_(i < n) (if a == t ``_ i then P t ``_ i else 1))); last first.
  rewrite exchange_big ; apply eq_big ; first done.
  move=> i _.
  rewrite (bigID (fun y => y == t ``_ i)) /=.
  rewrite -/(INR n.+1) big_pred1_eq eqxx big1 ; first by rewrite Rmult_1_r.
  by move=> i0 /negbTE ->.
apply eq_bigr => a _.
rewrite -big_mkcond /= -/(INR n.+1).
transitivity (\big[Rmult/1]_(i < n | t ``_ i == a) (INR (type.f P a) / INR n)).
  apply eq_big => // i.
  move/eqP => ->.
  by rewrite INR_type_fun.
rewrite big_const iter_Rmult_pow INR_type_fun.
congr (_ ^ _).
rewrite /typed_tuples inE in Hx.
move/forallP/(_ a)/eqP : Hx => Hx.
rewrite -INR_type_fun in Hx.
apply Rmult_eq_reg_r in Hx; last first.
  apply Rinv_neq_0_compat, not_0_INR; by apply/eqP.
move/INR_eq in Hx.
rewrite Hx num_occ_alt cardsE /=.
apply eq_card => /= n0.
by rewrite /in_mem /= tnth_mktuple.
Qed.

Local Close Scope tuple_ext_scope.

(** Probability of tuples representative of a type using the entropy: *)

Lemma tuple_dist_type_entropy t : tuple_of_row t \in T_{P} ->
  P `^ n t = exp2 (- INR n * `H P).
Proof.
move/(@tuple_dist_type t) => ->.
rewrite (_ : \rmul_(a : A) P a ^ (type.f P) a =
             \rmul_(a : A) exp2 (P a * log (P a) * INR n)); last first.
  apply eq_bigr => a _.
  case/boolP : (0 == P a) => H; last first.
    have {H}H : 0 < P a.
      have : 0 <= P a by apply Rle0f.
      case/Rle_lt_or_eq_dec => // abs.
      by rewrite abs eqxx in H.
    rewrite -{1}(exp2_log H) -exp2_pow.
    f_equal.
    rewrite -mulRA [X in _ = X]mulRC -mulRA mulRC.
    f_equal.
    by rewrite type_fun_type.
  - move/eqP : (H) => <-.
    rewrite -(_ : O = type.f P a); first by rewrite !mul0R exp2_0 /pow.
    apply INR_eq.
    rewrite {1}/INR.
      apply (Rmult_eq_reg_r ( / INR n)); last first.
        apply Rinv_neq_0_compat, not_0_INR; by apply/eqP.
    rewrite type_fun_type //.
    by move/eqP : H => <-; rewrite mulR0.
rewrite -(big_morph _ morph_exp2_plus exp2_0) -(big_morph _ (morph_mulRDl _) (mul0R _)).
by rewrite /entropy Rmult_opp_opp mulRC.
Qed.

Local Open Scope typ_seq_scope.

Lemma typed_tuples_are_typ_seq : (@row_of_tuple A n @: T_{ P }) \subset `TS P n 0.
Proof.
apply/subsetP => t Ht.
rewrite /set_typ_seq inE /typ_seq tuple_dist_type_entropy; last first.
  case/imsetP : Ht => x Hx ->.
  by rewrite row_of_tupleK.
by rewrite addR0 subR0 !leRR.
Qed.

(** Upper-bound of the number of tuples representative of a type using the entropy: *)

Lemma card_typed_tuples : INR #| T_{ P } | <= exp2 (INR n * `H P).
Proof.
rewrite -(Rinv_involutive (exp2 (INR n * `H P))%R); last by apply exp2_not_0.
rewrite -exp2_Ropp -Ropp_mult_distr_l_reverse.
set aux := - INR n * `H P.
apply (Rmult_le_reg_r (exp2 aux) _ _ (exp2_pos aux)).
rewrite Rinv_l ; last by apply exp2_not_0.
rewrite /aux ; clear aux.
case/boolP : [exists x, x \in T_{P}] => x_T_P.
- case/existsP : x_T_P => ta Hta.
  rewrite -(row_of_tupleK ta) in Hta.
  rewrite -(tuple_dist_type_entropy Hta).
  rewrite [X in X <= _](_ : _ = Pr P `^ n (@row_of_tuple A n @: T_{P})).
    by apply Pr_1.
  symmetry.
  rewrite /Pr.
  transitivity (\rsum_(a| (a \in [finType of 'rV[A]_n]) && [pred x in (@row_of_tuple A n @: T_{P})] a)
      exp2 (- INR n * `H P)).
    apply eq_big => // ta'/= Hta'.
    rewrite -(@tuple_dist_type_entropy ta') //.
    case/imsetP : Hta' => x Hx ->. by rewrite row_of_tupleK.
  rewrite big_const iter_Rplus_Rmult tuple_dist_type_entropy //.
  do 2 f_equal.
  rewrite card_imset //.

Lemma row_of_tuple_inj {C : finType} {m} : injective (@row_of_tuple C m).
Proof. move=> a b ab; by rewrite -(row_of_tupleK b) -ab row_of_tupleK. Qed.

  exact row_of_tuple_inj.
- rewrite (_ : (INR #| T_{P} | = 0)%R); first by fourier.
  rewrite (_ : 0%R = INR 0) //; f_equal; apply/eqP.
  rewrite cards_eq0; apply/negPn.
  move: x_T_P; apply contra; by move/set0Pn/existsP.
Qed.

Lemma card_typed_tuples_alt : INR #| T_{P} | <= exp2 (INR n * `H P).
Proof.
apply Rle_trans with (INR #| `TS P n 0 |).
  apply le_INR; apply/leP.
  eapply leq_trans; last first.
    apply subset_leq_card.
    by apply typed_tuples_are_typ_seq.
  rewrite card_imset //.
  exact row_of_tuple_inj.
eapply Rle_trans; first by apply TS_sup.
rewrite addR0.
apply Rle_refl.
Qed.

Lemma perm_tuple_in_Ttuples ta (s : 'S_n) :
  perm_tuple s ta \in T_{P} <-> ta \in T_{P}.
Proof.
rewrite 2!in_set.
split => /forallP H; apply/forallP => a; move: H => /(_ a)/eqP => ->; by rewrite num_occ_perm.
Qed.

End typed_tuples_facts_continued.

Section enc_pre_img_partition.

Variables A B M : finType.
Variable n' : nat.
Let n := n'.+1.
Variable c : code A B M n.

Definition enc_pre_img (P : P_ n ( A )) := [set m | tuple_of_row (enc c m) \in T_{P}].

Lemma enc_pre_img_injective (P Q : P_ n ( A )) :
  enc_pre_img P != set0 -> enc_pre_img P = enc_pre_img Q ->
  forall a, P a = Q a.
Proof.
rewrite /enc_pre_img.
case/set0Pn => m.
rewrite in_set => HmP /setP HPQ.
have HmQ : tuple_of_row (enc c m) \in T_{Q} by move:(HPQ m) ; rewrite 2!in_set => <-.
move=> a {HPQ}.
move: HmP ; rewrite in_set => /forallP/(_ a)/eqP => ->.
move: HmQ ; rewrite in_set => /forallP/(_ a)/eqP => <-.
reflexivity.
Qed.

Definition enc_pre_img_partition :=
  enc_pre_img @: [set P in P_ n ( A ) | enc_pre_img P != set0].

Lemma cover_enc_pre_img : cover enc_pre_img_partition = [set: M].
Proof.
rewrite /cover /enc_pre_img_partition.
apply/setP => m.
rewrite in_set.
apply/bigcupP.
exists (enc_pre_img (type_of_tuple (tuple_of_row (enc c m)))).
- apply/imsetP; exists (type_of_tuple (tuple_of_row (enc c m))) => //.
  rewrite in_set.
  apply/andP; split => //.
  apply/set0Pn.
  exists m.
  rewrite 2!in_set.
  by apply/forallP.
- rewrite 2!in_set.
  by apply/forallP.
Qed.

Lemma trivIset_enc_pre_img : trivIset enc_pre_img_partition.
Proof.
apply/trivIsetP => S1 S2 /imsetP ; case => P1 _ HP1. case/imsetP => P2 _ HP2 HP12.
subst S1 S2.
rewrite /disjoint.
apply/pred0P => m /=.
apply/negP/negP.
move: m.
apply/forallP; rewrite -negb_exists; apply/negP; case/existsP => m /andP [H1 H2]; contradict HP12.
apply/negP/negPn/eqP/setP => m'.
case/boolP : (m' \in enc_pre_img P2) => [|/negbTE] Hcase.
- apply/negPn/negPn.
  rewrite 2!in_set; apply/forallP => a.
  move: H1; rewrite 2!in_set => /forallP/(_ a)/eqP ->.
  move: Hcase; rewrite 2!in_set => /forallP/(_ a)/eqP <-.
  move: H2; rewrite 2!in_set => /forallP/(_ a)/eqP <-.
  by rewrite eqxx.
- apply/negP/negPn; move: Hcase => /negP/negPn; apply contra => Hcase.
  rewrite 2!in_set; apply/forallP => a.
  move: H2; rewrite 2!in_set => /forallP/(_ a)/eqP ->.
  move: Hcase; rewrite 2!in_set => /forallP/(_ a)/eqP <-.
  move: H1; rewrite 2!in_set => /forallP/(_ a)/eqP <-.
  by rewrite eqxx.
Qed.

End enc_pre_img_partition.

Section sum_messages_types.

Variables A B M : finType.
Variable n' : nat.
Let n := n'.+1.
Variable c : code A B M n.

Lemma sum_messages_types' f :
  \rsum_(P : P_ n ( A )) (\rsum_(m |m \in enc_pre_img c P) f m) =
  \rsum_ (S | S \in enc_pre_img_partition c) \rsum_(m in S) f m.
Proof.
rewrite (bigID (fun P => [exists m, m \in enc_pre_img c P] )).
rewrite (_ : forall a b, addR_comoid a b = a + b) //.
rewrite Rplus_comm big1 ; last first.
  move=> P ; rewrite andTb negb_exists => HP.
  apply big_pred0 => m /=.
  apply/negP/negPn; by move:HP => /forallP/(_ m) ->.
rewrite Rplus_0_l big_imset.
  apply eq_big => [P|P _] //=.
  rewrite in_set.
  case: set0Pn.
    by move/existsP.
  move=> H; by apply/existsP.
move=> P Q; rewrite 2!in_set => HP HQ HPQ /=.
move: (enc_pre_img_injective HP HPQ) => {HP HQ HPQ}HPQ.
case: P HPQ => /= Pd Pf HP HPQ.
case: Q HPQ => /= Qd Qf HQ HPQ.
apply/type_eqP => /=.
apply/eqP.
apply ffunP => a.
move: {HPQ}(HPQ a).
rewrite HP HQ.
move/Rmult_eq_reg_r.
have H' : / INR n <> 0.
  apply Rinv_neq_0_compat.
  apply not_0_INR.
  by apply/eqP.
move/(_ H').
move/INR_eq => ?; by apply val_inj.
Qed.

Lemma sum_messages_types f :
  \rsum_(P : P_ n ( A )) (\rsum_(m |m \in enc_pre_img c P) f m) = \rsum_ (m : M) (f m).
Proof.
transitivity (\rsum_ (m in [set: M]) (f m)); last by apply eq_bigl => b; rewrite in_set.
rewrite -(cover_enc_pre_img c) /enc_pre_img_partition sum_messages_types'.
symmetry.
by apply big_trivIset, trivIset_enc_pre_img.
Qed.

End sum_messages_types.

Section typed_code_def.

Variables A B M : finType.
Variable n : nat.
Variable P : P_ n ( A ).

Record typed_code := mkTypedCode {
  untyped_code :> code A B M n ;
  typed_prop : forall m, tuple_of_row (enc untyped_code m) \in T_{P} }.

End typed_code_def.

Section typed_code_of_code.

Variables A B M : finType.
Variable n' : nat.
Let n := n'.+1.
Variable P : P_ n ( A ).
Variable c : code A B M n.

Definition def := row_of_tuple (sval (typed_tuples_not_empty P)).
Definition Hdef := proj2_sig (typed_tuples_not_empty P).

Definition tcode_untyped_code := mkCode
  [ffun m => if tuple_of_row (enc c m) \in T_{P} then enc c m else def] (dec c).

Lemma tcode_typed_prop : forall m : M, tuple_of_row ((enc tcode_untyped_code) m) \in T_{P}.
Proof.
move=> m /=.
rewrite ffunE.
case: ifP.
  exact.
move=> _.
rewrite /def.
rewrite row_of_tupleK.
exact Hdef.
Qed.

Definition tcode : typed_code B M P := mkTypedCode tcode_typed_prop.

End typed_code_of_code.

Notation "P '.-typed_code' c" := (tcode P c) (at level 50, c at next level) : types_scope.


From Undecidability.Shared.Libs.PSL Require Export BasicDefinitions FinTypesDef.
From Undecidability.Shared.Libs.PSL Require Import Bijection.

(* ** Formalisation of finite types using canonical structures and type classes *)

Definition elem (F: finType) := @enum (type F) (class F).
#[export] Hint Unfold elem : core.
#[export] Hint Unfold class : core.

Lemma elem_spec (X: finType) (x:X) : x el (elem X).
Proof.
  apply countIn.  pose proof (enum_ok x) as H. unfold elem. lia.
Qed.

#[export] Hint Resolve elem_spec : core.
#[export] Hint Resolve enum_ok : core.

Lemma allSub (X: finType) (A:list X) : A <<= elem X.
Proof.
  intros x _. apply elem_spec.
Qed.
#[export] Hint Resolve allSub : core.

(* A properties that hold on every element of (elem X) hold for every element of the finType X *)
Theorem Equivalence_property_all (X: finType) (p: X -> Prop) :
  (forall x, p x) <-> forall x, x el (elem X) -> p x.
Proof.
  split; auto.
Qed.

Theorem Equivalence_property_exists (X: finType) (p:X -> Prop):
  (exists x, p x) <-> exists x, x el (elem X) /\ p x.
Proof.
  split.
  - intros [x P]. eauto.
  - intros [x [E P]]. eauto.
Qed.

#[global]
Instance finType_forall_dec (X: finType) (p: X -> Prop): (forall x, dec (p x)) -> dec (forall x, p x).
Proof.
  intros D. eapply dec_transfer.
  - symmetry. exact (Equivalence_property_all p).
  - auto.
Qed.

#[global]
Instance finType_exists_dec (X:finType) (p: X -> Prop) : (forall x, dec (p x)) -> dec (exists x, p x).
Proof.
  intros D. eapply dec_transfer.
  - symmetry. exact (Equivalence_property_exists p).
  - auto.
Qed.

Definition finType_cc (X: finType) (p: X -> Prop) (D: forall x, dec (p x)) : (exists x, p x) -> {x | p x}.
Proof.
  intro H.
  assert(exists x, x el (elem X) /\ p x) as E by firstorder.
  pose proof (list_cc D E) as [x G].
  now exists x.
Defined.

Definition pickx (X: finType): X + (X -> False).
Proof.
  destruct X as [X [enum ok]]. induction enum.
  - right. intro x. discriminate (ok x).
  - tauto.
Defined.

(* * Properties of decidable Propositions *)

Lemma DM_notAll (X: finType) (p: X -> Prop) (D:forall x, dec (p x)): (~ (forall x, p x)) <-> exists x, ~ (p x).
Proof.
  decide (exists x,~ p x); firstorder.
Qed.

Lemma DM_exists (X: finType) (p: X -> Prop) (D: forall x, dec (p x)):
  (exists x, p x) <->  ~(forall x, ~ p x).
Proof.
  split.
  - firstorder.
  - decide (exists x, p x); firstorder.
Qed.

(* Index is an injective function *)

Fixpoint  getPosition {E: eqType} (A: list E) x := match A with
                                                   | nil => 0
                                                   | cons x' A' => if Dec (x=x') then 0 else 1 + getPosition A' x end.

Lemma getPosition_correct {E: eqType} (x:E) A: if Dec (x el A) then forall z, (nth (getPosition A x) A z) = x else getPosition A x = |A |.
Proof.
  induction A;cbn.
  -repeat destruct Dec;tauto.
  -repeat destruct Dec;intuition; congruence.
Qed.

Lemma getPosition_nth (X:eqType) k (d :X) xs:
  Dupfree.dupfree xs ->
  k < length xs ->
  getPosition xs (nth k xs d) = k.
Proof.
  induction xs in k|-*. now cbn.
  intros H1 H2. inv H1.
  cbn. destruct k.
  -decide _. all:easy.
  -decide _.
   +subst a. cbn in H2. edestruct H3. eapply nth_In. lia.
   + cbn in H2. rewrite IHxs. all:try easy;lia.
Qed.

Definition pos_def (X : eqType) (x : X) A n :=  match pos x A with None => n | Some n => n end.

Definition index {F: finType} (x:F) := getPosition (elem F) x.

Lemma index_nth {F : finType} (x:F) y: nth (index x) (elem F) y = x.
Proof.
  unfold index, elem, enum.
  destruct F as [[X E] [A all_A]];cbn.
  pose proof (getPosition_correct x A) as H.
  destruct Dec. auto. apply notInZero in n. now setoid_rewrite all_A in n.
Qed.

Lemma injective_index (A: finType) (x1 x2 : A) : index x1 = index x2 -> x1 = x2.
Proof.
  destruct (elem A) eqn:E.
  - hnf. intros. assert (x1 el elem A) by eauto using elem_spec. rewrite E in H0. auto.
  - clear E. eapply (left_inv_inj (g := (fun y => nth y (elem A) e))).
    hnf. intros. now rewrite index_nth.
Qed.

Lemma index_le (A:finType) (x:A): index x < length (elem A).
Proof.
  unfold index.
  assert (H:x el elem A) by apply elem_spec.
  revert H.
  generalize (elem A). intros l H.
  induction l;cbn;[|decide _].
  -easy.
  -lia.
  -destruct H. congruence. apply IHl in H. lia.
Qed.

Lemma index_leq (A:finType) (x:A): index x <= length (elem A).
Proof.
  eapply Nat.lt_le_incl,index_le.
Qed.


From mathcomp
     Require Import all_ssreflect.
Require Export mylib.

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

(* ***************************** *)
Section Sbigop_def.
  Variable (R:Type).

  Fixpoint Sbigop_def (op:R -> R -> R) x0 I (r:seq I) (P:pred I) F :=
    if r is x :: r' then if P x
                         then \big[op/(F x)]_(i <- rev r' | P i) F i
                         else Sbigop_def op x0 r' P F
    else x0.

  Definition Sbigop op x0 I (r:seq I) := Sbigop_def op x0 (rev r).

End Sbigop_def.

Notation "\Sbig [ op / x0 ]_ ( i <- r | P ) F" :=
  (Sbigop op x0 r (fun i => P) (fun i => F))
    (at level 36, F at level 36, op, x0 at level 10, i, r at level 50,
     format "'[' \Sbig [ op / x0 ]_ ( i <- r | P ) '/ ' F ']'") : big_scope.

Notation "\Sbig [ op / x0 ]_ ( i <- r ) F" :=
  (Sbigop op x0 r predT (fun i => F))
    (at level 36, F at level 36, op, x0 at level 10, i, r at level 50,
     format "\Sbig [ op / x0 ]_ ( i <- r ) F") : big_scope.

Notation "\Sbig [ op / x0 ]_ ( i | P ) F" :=
  (Sbigop op x0 (index_enum _) (fun i => P) (fun i => F))
    (at level 36, F at level 36, op, x0 at level 10, i at level 50,
     format "'[' \Sbig [ op / x0 ]_ ( i | P ) '/ ' F ']'") : big_scope.

Notation "\Sbig [ op / x0 ]_ i F" :=
  (Sbigop op x0 (index_enum _) predT (fun i => F))
    (at level 36, F at level 36, op, x0 at level 10, i at level 50,
     format "'[' \Sbig [ op / x0 ]_ i '/ ' F ']'") : big_scope.

Section Sbigop_basis.
  Variable (R:Type).
  Variable (op:R -> R -> R).
  Variable (x0:R).

  Lemma Sbig_big :
    right_id x0 op ->
    forall I r (P:pred I) F,
    \Sbig[op/x0]_(i <- r | P i) F i = \big[op/x0]_(i <- r | P i) F i.
  Proof.
    rewrite /Sbigop => Hid I r P F.
    elim /last_ind : r =>[|r x IHr]/=; first by rewrite big_nil.
    rewrite rev_rcons /= IHr -cats1 big_cat_nested big_cons big_nil revK.
    case : ifP =>//_. by rewrite Hid.
  Qed.

  Lemma Sbig_hasC I r (P:pred I) F :
    ~~ has P r -> \Sbig[op/x0]_(i <- r | P i) F i = x0.
  Proof.
    rewrite /Sbigop. elim /last_ind : r =>[|r x IHr]//.
    rewrite rev_rcons -cats1 has_cat /= orbF.
      by case /norP => /IHr ->/negPf ->.
  Qed.

  Lemma Sbig_nil I (P:pred I) F : \Sbig[op/x0]_(i <- [::] | P i) F i = x0.
  Proof. by apply : Sbig_hasC. Qed.

  Lemma Sbig_cons I x r (P:pred I) F :
    \Sbig[op/x0]_(i <- x :: r | P i) F i =
    if P x then if has P r then op (F x) (\Sbig[op/x0]_(i <- r | P i) F i)
                else F x
    else \Sbig[op/x0]_(i <- r | P i) F i.
  Proof.
    rewrite /Sbigop.
    elim /last_ind : r =>[/=|r y IHr];
      first by (case : ifP=>//_; exact : big_nil).
    rewrite -rcons_cons !rev_rcons /= IHr !revK big_cons has_rcons.
      by case : ifP.
  Qed.

End Sbigop_basis.

Section Sbigop.
  Variable (R:Type).
  Variable (op:R -> R -> R).
  Variable (x0:R).

  Lemma Sbig_cat_nested I r1 r2 (P:pred I) F:
    let x := \Sbig[op/x0]_(i <- r2 | P i) F i in
    \Sbig[op/x0]_(i <- r1 ++ r2 | P i) F i =
    if has P r2 then \big[op/x]_(i <- r1 | P i) F i
    else \Sbig[op/x0]_(i <- r1 | P i) F i.
  Proof.
    elim : r1 =>[|y r1 IHr1]/=.
    - rewrite Sbig_nil big_nil. case : ifP=>// /negbT. exact : Sbig_hasC.
    - rewrite !Sbig_cons big_cons IHr1 has_cat. case : ifP =>//_.
      by move : (has P r1) (has P r2) =>[][].
  Qed.

  Lemma Sbig_ind (K:R -> Type) I r (P:pred I) F:
    (forall x y, K x -> K y -> K (op x y)) ->
    (forall i, P i -> K (F i)) ->
    has P r -> K (\Sbig[op/x0]_(i <- r | P i) F i).
  Proof.
    move => Hop HP. elim : r =>[|x r IHr]//=.
    rewrite Sbig_cons. case : ifP =>//= /HP Hx _. case : ifP=>// /IHr.
    exact : Hop.
  Qed.

End Sbigop.

(* ***************************** *)
Module CTTpred.

  Structure class_of (V:Type) (R:rel V) (P:pred V) :=
    Class{
        _:{in P & &, transitive R};
        _:{in P &, total R};
        op:V -> V -> V;
        _:forall x y, op x y = if R x y then x else y
      }.

  Section Packing.
    Structure type V R := Pack {cttP; _:@class_of V R cttP}.
    Variable (V:Type) (R:rel V) (cT:type R).
    Definition class := let: Pack _ c := cT return class_of _ (cttP cT) in c.
    Definition predPredType : pred_sort _ := (cttP cT).
  End Packing.

  Module Exports.
    Definition CTTpred V R := (@type V R).
    Definition CTTop V R (P:@type V R) := @op _ _ _ (class P).
    Coercion cttP : type >-> pred.
    Coercion predPredType : type >-> pred_sort.
  End Exports.
End CTTpred.
Export CTTpred.Exports.

Section CTTpred_lemma.
  Variable (V:Type) (R:rel V).
  Variable (P:CTTpred R).
  Let op := @CTTop _ _ P.

  Lemma CTTtrans : {in P & &, transitive R}.
  Proof. by case : P => CtP []. Qed.

  Lemma CTTtotal : {in P &, total R}.
  Proof. by case : P => CtP []. Qed.

  Lemma CTTrefl : {in P, reflexive R}.
  Proof. move => x Hx. by case /orP : (CTTtotal Hx Hx). Qed.

  Lemma CTTop_def x y : op x y = if R x y then x else y.
  Proof. rewrite /op. by case : P => CtP []. Qed.

  Lemma CTTop_closed : {in P &, forall x y, op x y \in P}.
  Proof. move => x y Hx Hy. rewrite CTTop_def. by case : ifP. Qed.

  Lemma CTTopA : {in P & &, associative op}.
  Proof.
    move => x y z Hx Hy Hz. rewrite !CTTop_def.
    case Ryz : (R y z); case Rxy : (R x y);
    rewrite ?Ryz ?(CTTtrans Hy Hx Hz Rxy Ryz) =>//.
    move : Ryz (CTTtotal Hy Hz) Rxy =>->/=. case : ifP =>// Rxy.
    by move /(CTTtrans Hz Hx Hy Rxy) =>->.
  Qed.

  Lemma CTTopI : idempotent op.
  Proof. move => x. rewrite CTTop_def. by case : ifP. Qed.

  Lemma CTTorder_opl : {in P & &, forall x y z, R (op x y) z = R x z || R y z}.
  Proof.
    move => x y z Hx Hy Hz. rewrite CTTop_def. move : (CTTtotal Hx Hy).
    case : ifP =>[Hxy _|_/= Hyx]; first rewrite orbC.
    - case Hyz : (R y z) =>//=. exact : CTTtrans Hxy Hyz.
    - case Hxz : (R x z) =>//=. exact : CTTtrans Hyx Hxz.
  Qed.

  Lemma CTTorder_opr : {in P & &, forall x y z, R x (op y z) = R x y && R x z}.
  Proof.
    move => x y z Hx Hy Hz. rewrite CTTop_def. move : (CTTtotal Hy Hz).
    case : ifP =>[|_/=]; last rewrite andbC.
    - by case Hxy : (R x y) =>// /(CTTtrans _ _ _ Hxy)->.
    - by case Hxz : (R x z) =>// /(CTTtrans _ _ _ Hxz)->.
  Qed.

End CTTpred_lemma.

(* ***************************** *)
Section Sbigop_CTTpred.
  Variable (V:Type) (R:rel V).
  Variable (cttP:CTTpred R).
  Let op := @CTTop _ _ cttP.

  Variable (x0:V).
  Hypothesis (Hx0:x0 \in cttP).
  Variable (I:eqType) (P:pred I) (F:I -> V).
  Hypothesis (HP : forall x, P x -> (F x) \in cttP).

  Lemma Sbig_in_CTT r:
    \Sbig[op/x0]_(i <- r | P i) F i \in cttP.
  Proof.
    elim : r =>[|x r IHr]//=. rewrite Sbig_cons. case : ifP =>// /HP Hx.
    case : ifP =>//_. exact : CTTop_closed.
  Qed.

  Lemma Sbig_cat r1 r2:
    \Sbig[op/x0]_(i <- r1 ++ r2 | P i) F i =
    if has P r1
    then if has P r2 then op (\Sbig[op/x0]_(i <- r1 | P i) F i)
                             (\Sbig[op/x0]_(i <- r2 | P i) F i)
         else \Sbig[op/x0]_(i <- r1 | P i) F i
    else \Sbig[op/x0]_(i <- r2 | P i) F i.
  Proof.
    elim : r1 =>[|x r1 IHr1]//=. rewrite !Sbig_cons IHr1 has_cat.
    case : ifP =>//= /HP Hx. move : (has P r1) (has P r2) =>[][]//=.
    exact : (CTTopA Hx (Sbig_in_CTT _) (Sbig_in_CTT _)).
  Qed.

  Lemma CTT_Sbigl r M:
    M \in cttP ->
          {in r, forall x,
                P x -> R (F x) M -> R (\Sbig[op/x0]_(i <- r | P i) F i) M}.
  Proof.
    move => HM x. elim : r =>[|y r IHr]//. rewrite in_cons Sbig_cons.
    case /orP =>[/eqP<- Hx|Hxr Hx]; move /HP : Hx (Hx) => HFx.
    - move =>->. case : ifP =>//_ HxM.
      rewrite (CTTorder_opl _ (Sbig_in_CTT _))=>//. by rewrite HxM.
    - case : ifP =>[/HP Hy Hx HxM|_]; last exact : IHr.
      have : has P r; first by (apply /hasP; exists x). move =>->.
      rewrite (CTTorder_opl _ (Sbig_in_CTT _))=>//.
      by rewrite (IHr Hxr Hx HxM) orbT.
  Qed.

  Lemma CTT_SbiglP r M:
    M \in cttP -> has P r ->
          reflect (exists2 x, x \in r & P x /\ R (F x) M)
                  (R (\Sbig[op/x0]_(i <- r | P i) F i) M).
  Proof.
    move => HM Hhas. apply /(iffP idP) =>[|[x Hx []]]; last exact : CTT_Sbigl.
    elim : r Hhas =>[|x r IHr]//=. rewrite Sbig_cons.
    case : ifP =>[Hx _|_/IHr IH /IH [y Hy Hy2]];
      last by (exists y =>//; rewrite in_cons Hy orbT).
    case : ifP =>[Hhas|_ HRx];
      last by (exists x; first exact : mem_head; split).
    rewrite (CTTorder_opl (HP _) (Sbig_in_CTT _))=>//.
    case /orP =>[HRx|/(IHr Hhas) [y Hy Hy2]];
      first by (exists x; first exact : mem_head; split).
    exists y=>//. by rewrite in_cons Hy orbT.
  Qed.

  Lemma CTT_SbigrP r m:
    m \in cttP -> has P r ->
          reflect {in r, forall x, P x -> R m (F x)}
                  (R m (\Sbig[op/x0]_(i <- r | P i) F i)).
  Proof.
    move => Hm. elim : r =>[|x r IHr]//=. rewrite Sbig_cons.
    case : ifP =>[Hx _|Hx /= /IHr IH].
    - apply : (iffP idP) =>[|HR].
      + case : ifP =>[/IHr IH|/hasPn Hr HFx y];
          last by rewrite in_cons =>/orP [/eqP->|/Hr /negP].
        rewrite (CTTorder_opr Hm (HP Hx) (Sbig_in_CTT _))
                =>/andP [] Hfx /IH Hr y.
          by rewrite in_cons =>/orP [/eqP->|/Hr].
      + case : ifP =>[/IHr IH|_]; last exact : HR (mem_head _ _) Hx.
        rewrite (CTTorder_opr _ (HP _) (Sbig_in_CTT _))=>//.
        move : (HR x). rewrite in_cons eq_refl =>->//=. apply /IH => y Hy.
          by apply : HR; rewrite in_cons Hy orbT.
    - apply : (iffP idP) =>[/IH Hr y|Hr];
        first by (rewrite in_cons =>/orP [/eqP->|/Hr]//; rewrite Hx).
      apply /IH => y Hy. apply /Hr. by rewrite in_cons Hy orbT.
  Qed.

  Lemma CTT_Sbig_rel r:
    {in r, forall x, P x -> R (\Sbig[op/x0]_(i <- r | P i) F i) (F x)}.
  Proof.
    move => x Hx Px. exact : (CTT_Sbigl (HP _)) (CTTrefl (HP _)).
  Qed.

End Sbigop_CTTpred.

Section nat_CTTpred.

  Lemma leq_CTTop_def x y: minn x y = if x <= y then x else y.
  Proof.
    move : (leq_total x y). by case : ifP =>[/minn_idPl|_/=/minn_idPr].
  Qed.

  Definition leq_CTTpred_class_of :=
    @CTTpred.Class _ _ {:nat}
                  (fun _ _ _ _ _ _ Hxy Hyz => leq_trans Hxy Hyz)
                  (fun x y _ _ => leq_total x y) _ leq_CTTop_def.
  Canonical leq_CTTpred := CTTpred.Pack leq_CTTpred_class_of.

  Lemma geq_CTTop_def x y : maxn x y = if x >= y then x else y.
  Proof.
    move : (leq_total y x). by case : ifP =>[/maxn_idPl|_/=/maxn_idPr].
  Qed.

  Definition geq_CTTpred_class_of :=
    @CTTpred.Class _ geq {:nat}
                  (fun _ _ _ _ _ _ Hxy Hyz => leq_trans Hyz Hxy)
                  (fun x y _ _ => leq_total y x) _ geq_CTTop_def.
  Canonical geq_CTTpred := CTTpred.Pack geq_CTTpred_class_of.

End nat_CTTpred.

Notation "\min_ ( i <- r | P ) F" :=
(*  (\big[minn/(\max_(i <- r | P) F)]_(i <- r | P%B) F%N)*)
  (\Sbig[minn/0]_(i <- r | P) F)
    (at level 41, F at level 41, i, r at level 50,
     format "'[' \min_ ( i <- r | P ) '/ ' F ']'") : nat_scope.

Notation "\min_ ( i <- r ) F" :=
(*  (\big[minn/(\max_(i <- r) F)]_(i <- r) F%N)*)
  (\Sbig[minn/0]_(i <- r) F)
    (at level 41, F at level 41, i, r at level 50,
     format "\min_ ( i <- r ) F") : nat_scope.

Notation "\min_ ( i | P ) F" :=
(*  (\big[minn/(\max_(i | P) F)]_(i | P%B) F%N)*)
  (\Sbig[minn/0]_(i | P) F%N)
    (at level 41, F at level 41, i at level 50,
     format "\min_ ( i | P ) F") : nat_scope.
(*
Notation "\min_ i F" :=
  (\Sbig[minn/0]_i F%N)
    (at level 41, F at level 41, i at level 50,
     format "\min_ i F") : nat_scope.

Notation "\min_ ( i : I | P ) F" :=
  (\big[minn/(\max_(i : I | P) F)]_(i : I | P%B) F%N)
    (at level 41, F at level 41, i at level 50, only parsing) : nat_scope.

Notation "\min_ ( i : I ) F" :=
  (\big[minn/(\max_(i : I) F)]_(i : I) F%N)
    (at level 41, F at level 41, i at level 50, only parsing) : nat_scope.

Notation "\min_ ( m <= i < n | P ) F" :=
  (\big[minn/(\max_(m <= i < n | P) F)]_(m <= i < n | P%B) F%N)
    (at level 41, F at level 41, i, m, n at level 50,
     format "\min_ ( m <= i < n | P ) F") : nat_scope.

Notation "\min_ ( m <= i < n ) F" :=
  (\big[minn/(\max_(m <= i < n) F)]_(m <= i < n) F%N)
    (at level 41, F at level 41, i, m, n at level 50,
     format "\min_ ( m <= i < n ) F") : nat_scope.

Notation "\min_ ( i < n | P ) F" :=
  (\big[minn/(\max_(i < n | P) F)]_(i < n | P%B) F%N)
    (at level 41, F at level 41, i, n at level 50,
     format "\min_ ( i < n | P ) F") : nat_scope.

Notation "\min_ ( i < n ) F" :=
  (\big[minn/(\max_(i < n) F)]_(i < n) F%N)
    (at level 41, F at level 41, i, n at level 50,
     format "\min_ ( i < n ) F") : nat_scope.

Notation "\min_ ( i 'in' A | P ) F" :=
  (\big[minn/(\max_(i in A | P) F)]_(i in A | P%B) F%N)
    (at level 41, F at level 41, i, A at level 50,
     format "\min_ ( i 'in' A | P ) F") : nat_scope.

Notation "\min_ ( i 'in' A ) F" :=
  (\big[minn/(\max_(i in A) F)]_(i in A) F%N)
    (at level 41, F at level 41, i, A at level 50,
     format "\min_ ( i 'in' A ) F") : nat_scope.
*)
Section Sbignat.
  Variable (I:eqType).
  Implicit Types (P:pred I).

  Lemma bigmin_hasC r P F: ~~ has P r -> \min_(i <- r | P i) F i = 0.
  Proof. exact : Sbig_hasC. Qed.

  Lemma bigmin_sup r P F M:
    {in r, forall x, P x -> F x <= M -> \min_(i <- r | P i) F i <= M}.
  Proof. exact : (@CTT_Sbigl _ _ leq_CTTpred). Qed.

  Lemma bigmin_infP r P F m:
    has P r ->
    reflect {in r, forall x, P x -> m <= F x} (m <= \min_(i <- r | P i) F i).
  Proof. exact : (@CTT_SbigrP _ _ leq_CTTpred). Qed.

  Lemma Sbigmax_inf r P F m:
    {in r, forall x,
                P x -> m <= F x -> m <= \Sbig[maxn/0]_(i <- r | P i) F i}.
  Proof. exact : (@CTT_Sbigl _ _ geq_CTTpred). Qed.

  Lemma Sbigmax_supP r P F M:
    has P r ->
    reflect {in r, forall x, P x -> F x <= M}
            (\Sbig[maxn/0]_(i <- r | P i) F i <= M).
  Proof. exact : (@CTT_SbigrP _ _ geq_CTTpred). Qed.

  Lemma bigmax_inf r P F m:
    {in r, forall x, P x -> m <= F x -> m <= \max_(i <- r | P i) F i}.
  Proof.
    move => x. rewrite -(Sbig_big maxn0). exact : Sbigmax_inf.
  Qed.

  Lemma bigmax_supP r P F M:
    reflect {in r, forall x, P x -> F x <= M} (\max_(i <- r | P i) F i <= M).
  Proof.
    case Hhas : (has P r).
    - rewrite -(Sbig_big maxn0). exact : Sbigmax_supP.
    - rewrite big_hasC; last by rewrite Hhas.
      apply /(iffP idP) =>[_ x|]; last by rewrite leq0n.
        by move /hasPn : Hhas => H /H /negP.
  Qed.

End Sbignat.
(*
Section leq_bigmin.

  Variable (I:finType).
  Implicit Types (P:pred I).

  Lemma leq_bigmin_cond P F i0: P i0 -> \min_(i | P i) F i <= F i0.
  Proof.
    move => HPi0.
    elim : (index_enum I) (mem_index_enum i0) =>[|i r IHr];
      first by rewrite !big_nil. rewrite in_cons bigmin_cons.
    case /orP; first (move /eqP =><-; rewrite HPi0).
    - case : ifP =>//. by rewrite geq_minl.
    - move => Hin. have : has P r; first by (apply /hasP; exists i0).
      move =>->/=. by case : ifP; rewrite ?geq_min (IHr Hin) ?orbT.
  Qed.

  Lemma bigmin_eq_arg P F i0:
    P i0 -> \min_(i | P i) F i = F [arg min_(i < i0 | P i) F i].
  Proof.
    move => HPi0. case : arg_minP =>// x HPx Hleq.
    elim : (index_enum I) (mem_index_enum x) =>[|i r IHr];
      first by rewrite !big_nil. rewrite in_cons bigmin_cons.
    case /orP; first (move /eqP =><-; rewrite HPx).
    - case : ifP =>//={IHr} Hhas.
      apply : (big_ind (fun k => minn (F x) k = F x)).
      + apply : minn_idPl.
        elim : r Hhas =>[|j r IHr]//=. rewrite big_cons. case : ifP =>//Hj _.
        by rewrite leq_max (Hleq _ Hj).
      + move => j k. move /minn_idPl => Hj. move /minn_idPl => Hk.
        apply /minn_idPl. by rewrite leq_min Hj Hk.
      + move => k Hk. apply /minn_idPl. exact : Hleq.
      + case : ifP =>/=;
                   last by (move /negbT /hasPn => H; move /H; rewrite HPx).
        case : ifP =>// HPi _. move /IHr =>->. apply /minn_idPr. exact : Hleq.
  Qed.

End leq_bigmin.
*)


(**
  Some tools from Homotopy Type Theory. They are already defined in the standard
  library under different names, but we use the HoTT names for simplicity.
*)

(** Transport is basically rewriting. *)
Definition transport {A : Type} (P : A -> Type) {x y : A} (p : x = y) : P x -> P y :=
match p with
| eq_refl _ => fun u : P x => u
end.

(** Functions preserve equality. *)
Definition ap
  {A B : Type} (f : A -> B) {x y : A} (p : x = y) : f x = f y :=
match p with
| eq_refl => eq_refl
end.

(** Dependent functions preserve equality *)
Definition apd
  {A : Type} {P : A -> Type} (f : forall x : A, P x) {x y : A} (p : x = y)
  : transport P p (f x) = (f y) :=
match p with
| eq_refl => eq_refl
end.

(** We define finite sets as a Private Inductive Type hidden inside a module. *)
Module FinSet.

(** Finite sets are made using constructors which look like [nil] and [cons] for lists. *)
Private Inductive FinSet (A : Type) : Type :=
| empty : FinSet A
| scons : A -> FinSet A -> FinSet A.

Arguments empty {A}.
Arguments scons {A} _ _.

(**
  Now comes the hack: we assume that we can change the ordering of elements in
  the set with [swap] and remove duplicates using [idem].

  Note that this allows us to prove [False] inside the module, because constructors
  of inductive types are injective by default. But of course we won't do it.
*)
Axiom swap :
  forall {A : Type} (x y : A) (s : FinSet A),
    scons x (scons y s) = scons y (scons x s).

Axiom idem :
  forall {A : Type} (x : A) (s : FinSet A),
    scons x (scons x s) = scons x s.

(** Now we define the recursion principle. *)
Section rec.

(**
  Given a type [P] that has the structure of a finite set, i.e.:
  - there's an empty set
  - we can add an element to the set
  - we can swap elements in the set
  - we can remove duplicates
*)
Context
  (A : Type)
  (P : Type)
  (empty' : P)
  (scons' : A -> P -> P)
  (swap'  : forall (x y : A) (s : P), scons' x (scons' y s) = scons' y (scons' x s))
  (idem'  : forall (x : A) (s : P), scons' x (scons' x s) = scons' x s).

(**
  We can define an element of [P] from any finite set [s] by replacing the
  constructors of [s] with the provided operations. Note that the arguments
  [swap'] and [idem'] guarantee that the provided operations behave nicely.
*)
Fixpoint FinSet_rec
  (swap'  : forall (x y : A) (s : P), scons' x (scons' y s) = scons' y (scons' x s))
  (idem'  : forall (x : A) (s : P), scons' x (scons' x s) = scons' x s)
  (s : FinSet A) : P :=
match s with
| empty => empty'
| scons x s' => scons' x (FinSet_rec swap' idem' s')
end.

(**
  The path [swap] of [FinSet] gets mapped to the path [swap'] provided by [P]
  and analogously for [idem].
*)
Axiom FinSet_rec_swap :
  forall (x y : A) (s : FinSet A),
    ap (FinSet_rec swap' idem') (swap x y s) = swap' x y (FinSet_rec swap' idem' s).

Axiom FinSet_rec_idem :
  forall (x : A) (s : FinSet A),
    ap (FinSet_rec swap' idem') (idem x s) = idem' x (FinSet_rec swap' idem' s).

End rec.

(** Now we define the induction principle. *)
Section ind.

(**
  This time we are given a type [P] that supports making the empty set and adding
  elements to the set, but we don't need any guarantees that these operations
  behave nicely, because the induction principle will be only used to construct
  proofs - we kind of implicitly assume proof irrelevance here.
*)

Context
  (A : Type)
  (P : FinSet A -> Prop)
  (empty' : P empty)
  (scons' : forall (x : A) {s : FinSet A}, P s -> P (scons x s)).

(**
  If we can prove [P] for the empty case and for the "add element" case,
  we can prove it for all finite sets.
*)
Fixpoint FinSet_ind (s : FinSet A) : P s :=
match s with
| empty => empty'
| scons x s' => scons' x s' (FinSet_ind s')
end.

End ind.

(** Now we define the dependent recursor. This is a joint generalization of the
    recursor and the induction principle. *)
Section rect.

Context
  (A : Type)
  (P : FinSet A -> Type)
  (empty' : P empty)
  (scons' : forall (x : A) {s : FinSet A}, P s -> P (scons x s))
  (Swap'  :=
    forall (x y : A) (s : FinSet A) (s' : P s),
      transport _ (swap x y s) (scons' x (scons' y s')) = scons' y (scons' x s'))
  (swap'  : Swap')
  (Idem'  :=
    forall (x : A) (s : FinSet A) (s' : P s),
      transport _ (idem x s) (scons' x (scons' x s')) = scons' x s')
  (idem'  : Idem').

Fixpoint FinSet_rect
  (swap' : Swap') (idem' : Idem') (s : FinSet A) : P s :=
match s with
| empty => empty'
| scons x s' => scons' x s' (FinSet_rect swap' idem' s')
end.

Axiom FinSet_rect_swap :
  forall (x y : A) (s : FinSet A),
    apd (FinSet_rect swap' idem') (swap x y s) = swap' x y s (FinSet_rect swap' idem' s).

Axiom FinSet_rect_idem :
  forall (x : A) (s : FinSet A),
    apd (FinSet_rect swap' idem') (idem x s) = idem' x s (FinSet_rect swap' idem' s).

End rect.

End FinSet.

(**
  After closing the module, we can no longer define functions out of [FinSet]
  by pattern matching, because the type is private. Now the only way to define
  functions (and prove theorems) is to use the recursion/induction principles
  that we defined inside the module.

  Also note that even though we could have proved [False] inside the module,
  we didn't do it and now after closing the module we are back in a safe world
  with no contradictions.
*)
Import FinSet.

(**
  Now we define the union of two finite sets. This corresponds to [app] on
  lists. Note that because we can't use pattern matching, we must do this
  in proof mode using [refine].
*)
Definition union {A : Type} (s1 s2 : FinSet A) : FinSet A.
Proof.
  (*
    The first argument of [FinSet_rec] is [A], the type of elements of the set.
    The second argument of is the codomain, in this case [FinSet A].
    The third argument is the result for the [empty] case.
    The fourth argument is the result for the [scons] case. Note that the result
      of the recursive call is [rc].
    The fifth and sixth arguments are the proofs that the thrid and fourth
      arguments behave nicely. Note that we'll prove them with tactics.
    The last argument is the thing we're matching on.
  *)
  refine
  (
    @FinSet_rec A (FinSet A)   (* match s with                            *)
    s2                         (* | empty       => s2                     *)
    (fun x rc => scons x rc)   (* | scons x s1' => scons x (union s1' s2) *)
    _ _ s1                     (* end                                     *)
  ); clear s1 s2.
  (* Now we need to prove that we didn't do anything silly. *)
  - now apply swap.
  - now apply idem.
Defined.

(**
  One problem with our approach is that the proofs (the [swap]/[idem] cases)
  are part of function definitions, so when we try to [cbn] or [unfold], they
  get out and things get ugly. Therefore, we prove (by reflexivity) separate
  lemmas which we'll use for rewriting.
*)

Lemma union_empty_l :
  forall {A : Type} (s : FinSet A),
    union empty s = s.
Proof. easy. Defined.

Lemma union_scons_l :
  forall {A : Type} (x : A) (s1 s2 : FinSet A),
    union (scons x s1) s2 = scons x (union s1 s2).
Proof. easy. Defined.

(**
  Proofs in our approach are very pleasant - we only need to handle the cases
  which correspond to [empty] and [scons], so it's as simple as proving lemmas
  about lists.
*)

Lemma union_empty_r :
  forall {A : Type} (s : FinSet A),
    union s empty = s.
Proof.
  intros A.
  (*
    We can use the [induction] tactic, but we must give [@FinSet_ind A] in
    the [using] clause for it to get accepted by Coq.
  *)
  induction s as [| x s IH] using (@FinSet_ind A).
  - now rewrite union_empty_l.
  - now rewrite union_scons_l, IH.
Qed.

Lemma union_scons_r :
  forall {A : Type} (x : A) (s1 s2 : FinSet A),
    union s1 (scons x s2) = scons x (union s1 s2).
Proof.
  intros A; induction s1 as [| y s1' IH] using (@FinSet_ind A); intros.
  - now rewrite !union_empty_l.
  - now rewrite !union_scons_l, IH, swap.
Qed.

Lemma union_comm :
  forall {A : Type} (s1 s2 : FinSet A),
    union s1 s2 = union s2 s1.
Proof.
  intros A; induction s1 as [| x s1' IH] using (@FinSet_ind A); intros.
  - now rewrite union_empty_l, union_empty_r.
  - now rewrite union_scons_l, union_scons_r, IH.
Qed.

Lemma union_idem :
  forall {A : Type} (s : FinSet A),
    union s s = s.
Proof.
  intros A; induction s as [| x s' IH] using (@FinSet_ind A); intros.
  - now rewrite union_empty_l.
  - now rewrite union_scons_l, union_scons_r, IH, idem.
Qed.

Lemma union_assoc :
  forall {A : Type} (s1 s2 s3 : FinSet A),
    union (union s1 s2) s3 = union s1 (union s2 s3).
Proof.
  intros A; induction s1 as [| x s1' IH] using (@FinSet_ind A); intros.
  - now rewrite !union_empty_l.
  - now rewrite !union_scons_l, IH.
Qed.

(**
  What happens when we try to define an evil function, like the one that
  tries to extract the "head" element from a set?
*)
Definition head {A : Type} (s : FinSet A) : option A.
Proof.
  (*
    match s with
    | empty => None
    | scons x _ => Some x
    end
  *)
  refine
  (
    @FinSet_rec A (option A)
    None
    (fun x _ => Some x)
    _ _ s
  ); clear s; cycle 1.
  (* The [idem] case goes through quite easily. *)
  - easy.
  (*
    But in the [swap] case we need to prove [Some x = Some y] for arbitrary
    [x] and [y], which won't be possible.
  *)
  - intros x y s.
Abort.

Definition map {A B : Type} (f : A -> B) (s : FinSet A) : FinSet B.
Proof.
  refine
  (
    @FinSet_rec A (FinSet B)
    empty
    (fun x rc => scons (f x) rc)
    _ _ s
  ); clear s.
  - now intros x y s; apply swap.
  - now intros; apply idem.
Defined.

Definition filter {A : Type} (p : A -> bool) (s : FinSet A) : FinSet A.
Proof.
  refine
  (
    @FinSet_rec A (FinSet A)
    empty
    (fun x rc => if p x then scons x rc else rc)
    _ _ s
  ); clear s.
  - now intros x y s'; destruct (p x), (p y); [apply swap | | |].
  - now intros x s; destruct (p x); [apply idem |].
Defined.

Definition join {A : Type} (ss : FinSet (FinSet A)) : FinSet A.
Proof.
  refine
  (
    @FinSet_rec (FinSet A) (FinSet A)
    empty
    (fun x rc => union x rc)
    _ _ ss
  ); clear ss.
  - now intros x y z; rewrite <- union_assoc, (union_comm x y), union_assoc.
  - now intros x y; rewrite <- union_assoc, union_idem.
Defined.

Definition any {A : Type} (p : A -> bool) (s : FinSet A) : bool.
Proof.
  refine
  (
    @FinSet_rec A bool
    false
    (fun x rc => orb (p x) rc)
    _ _ s
  ); clear s.
  - now intros x y s; destruct (p x), (p y).
  - now intros x s; destruct (p x); cbn.
Defined.

Definition all {A : Type} (p : A -> bool) (s : FinSet A) : bool.
Proof.
  refine
  (
    @FinSet_rec A bool
    true
    (fun x rc => andb (p x) rc)
    _ _ s
  ); clear s.
  - now intros x y s; destruct (p x), (p y).
  - now intros x s; destruct (p x); cbn.
Defined.

(*
Definition elem_of {A : Type} `{EqDecision A} (s : FinSet A) (x : A) : bool.
Proof.
  refine
  (
    @FinSet_rec A bool
    false
    (fun y rc => if decide (x = y) then true else rc)
    _ _ s
  ); clear s.
  - by intros y1 y2 b; destruct (decide (x = y1)), (decide (x = y2)).
  - by intros y b; destruct (decide (x = y)).
Defined.
*)


(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *)
Require Import ssreflect.
Require Import ssrbool.
Require Import funs.
Require Import dataset.
Require Import ssrnat.
Require Import seq.

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

(*   A small theory of data sets of finite cardinal, based on sequences.     *)
(* A finite data set is a data set plus a duplicate-free sequence of all its *)
(* elements. This is equivalent to requiring only a list, and we do give a   *)
(* construction of a finSet from a list, but it is preferable to specify the *)
(* structure of the dataset in general.                                      *)

Record finSet : Type := FinSet {
  element :> dataSet;
  enum : seq element;
  count_set1_enum : forall x, count (set1 x) enum = 1
}.

Section SeqFinSet.

Variables (d : dataSet) (e : seq d).

Let d' : dataSet := subData e.

Fixpoint subd_enum (s : seq d) : seq d' :=
  if s is Adds x s' then
    let s'' := subd_enum s' in
    if subdIopt e x is Some u then
      if s'' u then s'' else Adds u s''
    else s''
  else seq0.

Lemma subd_enumP : forall u, count (set1 u) (subd_enum e) = 1.
Proof.
move=> [x Hx]; rewrite /eqd /= -[1]/(true : nat) -Hx.
have: forall y, e y -> e y by done.
elim: {1 5 6}e => [|y s Hrec] //=.
case: subdIoptP => [u _ Du|Hy] Hs; last by case/idP: Hy; apply Hs; rewrite setU11.
have Hs' := Hs _ (setU1r _ _).
rewrite (fun_if (@count d' _)) /= (Hrec Hs') /eqd /= (Du) eqd_sym /setU1.
case: (y =P x) => [Dy|_]; last by rewrite /= add0n if_same.
by rewrite -has_set1 has_count /eqd /= Du Dy (Hrec Hs'); case (s x).
Qed.

Definition SeqFinSet := FinSet subd_enumP.

End SeqFinSet.

Lemma boolEnumP : forall b, count (set1 b) (seq2 true false) = 1.
Proof. by move=> [|]. Qed.

Canonical Structure boolEnum := FinSet boolEnumP.

Section FiniteSet.

Variable d : finSet.

Lemma mem_enum : enum d =1 d.
Proof. by move=> x; rewrite -has_set1 has_count count_set1_enum. Qed.

Lemma filter_enum : forall a : set d, filter a (enum d) =1 a.
Proof. by move=> a x; rewrite mem_filter /setI andbC mem_enum. Qed.

Lemma uniq_enum : uniq (enum d).
Proof.
have: forall x, count (set1 x) (enum d) <= 1.
  by move=> x; rewrite count_set1_enum.
elim: (enum d) => [|x s Hrec] Hs //=; apply/andP; split.
  rewrite -has_set1 has_count -ltnNge /=.
  by apply: leq_trans (Hs x); rewrite /= set11 leqnn.
by apply: Hrec => [y]; apply: leq_trans (Hs y); rewrite /= leq_addl.
Qed.

Section Pick.

Variable a : set d.

Inductive pick_spec : option d -> Set :=
  | Pick : forall x, a x -> pick_spec (Some x)
  | Nopick : a =1 set0 -> pick_spec None.

Definition pick : option d :=
  if filter a (enum d) is Adds x _ then Some x else None.

Lemma pickP : pick_spec pick.
Proof.
rewrite /pick; case: (filter a (enum d)) (filter_enum a) => [|x s] Ha.
  by right; apply: fsym.
by left; rewrite -Ha /= setU11.
Qed.

End Pick.

Lemma eq_pick : forall a b, a =1 b -> pick a = pick b.
Proof. move=> a *; symmetry; rewrite /pick -(@eq_filter _ a); auto. Qed.

Opaque pick.

Section Cardinal.

Definition card a := count a (enum d).

Lemma eq_card : forall a b, a =1 b -> card a = card b.
Proof. move=> a b Eab; apply: (eq_count Eab). Qed.

Lemma card0 : card set0 = 0. Proof. apply: count_set0. Qed.

Lemma cardA : card d = size (enum d). Proof. apply: count_setA. Qed.

Lemma card1 : forall x, card (set1 x) = 1.
Proof. move=> x; apply: count_set1_enum. Qed.

Lemma cardUI : forall a b, card (setU a b) + card (setI a b) = card a + card b.
Proof. move=> a b; apply: count_setUI. Qed.

Lemma cardIC : forall b a, card (setI a b) + card (setI a (setC b)) = card a.
Proof.
by move=> b a; apply: etrans _ (add0n _); rewrite -cardUI addnC -card0;
   congr (_ + _); apply: eq_card => x; rewrite /setI /setU /setC;
   case (a x); case (b x).
Qed.

Lemma cardC : forall a, card a + card (setC a) = card d.
Proof. move=> a; apply: etrans (esym cardA); exact: count_setC. Qed.

Lemma cardU1 : forall x a, card (setU1 x a) = negb (a x) + card a.
Proof.
move=> x a; apply: addn_injr (etrans (cardUI _ _) _); symmetry.
rewrite addnC addnA; congr addn; rewrite -(@eq_card (filter a (seq1 x))).
  simpl; case: (a x); last by rewrite /= card0 card1.
  by rewrite addnC; apply: eq_card => y; exact: mem_seq1.
by move=> y; rewrite mem_filter /setI mem_seq1 andbC.
Qed.

Lemma card2 : forall x y, card (set2 x y) = S (negb (x =d y)).
Proof.
move=> x y /=; apply: (etrans (cardU1 x (eqd y))).
by rewrite card1 addn1 eqd_sym.
Qed.

Lemma cardC1 : forall x, card (setC1 x) = pred (card d).
Proof. by move=> x; rewrite -(cardC (eqd x)) card1. Qed.

Lemma cardD1 : forall x a, card a = a x + card (setD1 a x).
Proof.
move=> x a; rewrite addnC; apply: (addn_injr (etrans (cardC a) _)).
rewrite -addnA (negb_intro (a x)) -[negb (a x)]/(setC a x) -cardU1.
symmetry; apply: etrans (congr1 (addn _) _) (cardC _).
by apply: eq_card => y; rewrite /setC /setU1 /setD1 negb_andb negb_elim.
Qed.

Lemma max_card : forall a, card a <= card d.
Proof. move=> a; rewrite -(cardC a); apply: leq_addr. Qed.

Lemma card_size : forall s : seq d, card s <= size s.
Proof.
elim=> [|x s Hrec] /=; first by rewrite card0.
by rewrite cardU1; case (s x); first exact (leqW Hrec).
Qed.

Lemma card_uniqPx : forall s : seq d, reflect (card s = size s) (uniq s).
Proof.
move=> s; elim: s => [|x s Hrec]; first by left; exact card0.
rewrite /= cardU1 /addn; case (s x); simpl.
  by right; move=> H; move: (card_size s); rewrite H ltnn.
by apply: (iffP Hrec) => [<-| [<-]].
Qed.

End Cardinal.

Definition set0b a := card a =d 0.
Definition disjoint a b := set0b (setI a b).
Definition subset a b := disjoint a (setC b).

Lemma card0_eq : forall a, card a = 0 -> a =1 set0.
Proof. by move=> a Ha x; apply/idP => [Hx]; rewrite (cardD1 x) Hx in Ha. Qed.

Lemma eq_card0 : forall a, a =1 set0 -> card a = 0.
Proof. by move=> a Da; rewrite (eq_card Da) card0. Qed.

Lemma set0Px : forall a, reflect (a =1 set0) (set0b a).
Proof. move=> a; apply: (iffP eqP); [apply: card0_eq | apply: eq_card0]. Qed.

Lemma set0Pnx : forall a : set d, reflect (exists x, a x) (negb (set0b a)).
Proof.
move=> a; case: (set0Px a) => [Ha|Hna]; constructor.
  by move=> [x Hx]; case/idP: (Ha x).
by case: (pickP a) => [x Hx|Ha]; [ exists x | case (Hna Ha) ].
Qed.

Lemma subsetPx : forall a b, reflect (sub_set a b) (subset a b).
Proof.
move=> a b; rewrite /subset /disjoint /setI /setC.
apply: (iffP (set0Px _)).
  by move=> Hab x Ha; apply negbEf; rewrite -(Hab x) Ha.
by move=> Hab x; case Ha: (a x); try rewrite (Hab _ Ha).
Qed.

Lemma subset_leq_card : forall a b, subset a b -> card a <= card b.
Proof.
move=> a b; move/(set0Px _)=> Hab.
rewrite -(leq_add2l (card (setC b))) 2!(addnC (card (setC b))).
rewrite -cardUI (eq_card Hab) card0 addn0 cardC; apply max_card.
Qed.

Lemma subset_refl : forall a, subset a a.
Proof. by move=> a; apply/(subsetPx _ _); move. Qed.

Lemma eq_subset : forall a a', a =1 a' -> subset a =1 subset a'.
Proof.
by move=> a a' Eaa' b; congr eqn; apply: eq_card => x; rewrite /setI Eaa'.
Qed.

Lemma eq_subset_r : forall b b', b =1 b' -> forall a, subset a b = subset a b'.
Proof.
by move=> b b' Ebb' a; congr eqn; apply: eq_card => x; rewrite /setI /setC Ebb'.
Qed.

Lemma subset_setA : forall a, subset a d.
Proof. by move=> a; apply/(subsetPx _ _). Qed.

Lemma subsetA : forall a, subset d a -> forall x, a x.
Proof. move=> a; move/subsetPx=> Ha x; auto. Qed.

Lemma subset_eqPx : forall a b, reflect (a =1 b) (subset a b && subset b a).
Proof.
move=> a b; apply: (iffP andP) => [[Hab Hba] x|Eab].
  by apply/idP/idP; apply: subsetPx.
by rewrite (eq_subset_r Eab) (eq_subset Eab) subset_refl.
Qed.

Lemma subset_cardP : forall a b, card a = card b -> reflect (a =1 b) (subset a b).
Proof.
move=> a b Ecab; case Hab: (subset a b) (subset_eqPx a b); simpl; auto.
case: (subsetPx b a) => [H|[]] // x Hbx; apply/idPn => Hax.
case/idP: (ltnn (card a)); rewrite {2}Ecab (cardD1 x b) Hbx /setD1.
apply: subset_leq_card; apply/(subsetPx _ _) => y Hy; rewrite andbC.
by rewrite (subsetPx _ _ Hab _ Hy); apply/eqP => Dx; rewrite Dx Hy in Hax.
Qed.

Lemma subset_trans : forall a b c, subset a b -> subset b c -> subset a c.
Proof.
move=> a b c; move/subsetPx=> Hab; move/subsetPx=> Hbc.
apply/(subsetPx _ _) => x Hx; auto.
Qed.

Lemma subset_all : forall (s : seq d) a, subset s a = all a s.
Proof. by move=> s a; exact (sameP (subsetPx _ _) allP). Qed.

Lemma disjoint_sym : forall a b, disjoint a b = disjoint b a.
Proof. by move=> a b; congr eqn; apply: eq_card => x; apply: andbC. Qed.

Lemma eq_disjoint : forall a a', a =1 a' -> disjoint a =1 disjoint a'.
Proof. by move=> a a' Ea b; congr eqn; apply: eq_card => x; congr andb. Qed.

Lemma disjoint_subset : forall a b, disjoint a b = subset a (setC b).
Proof.
move=> a b; rewrite /subset; rewrite 2!(disjoint_sym a).
by apply: eq_disjoint => x; rewrite /setC negb_elim.
Qed.

Lemma disjoint_trans : forall a b c, subset a b -> disjoint b c -> disjoint a c.
Proof. move=> a b c; rewrite 2!disjoint_subset; apply subset_trans. Qed.

Lemma disjoint0 : forall a, disjoint set0 a.
Proof. by move=> a; apply/(set0Px _). Qed.

Lemma disjoint1 : forall x a, disjoint (set1 x) a = negb (a x).
Proof.
move=> x a; apply negb_sym; apply: (sameP _ (set0Pnx (setI (set1 x) a))).
rewrite /setI; apply introP; move=> Hx; first by exists x; rewrite eqd_refl.
by case=> y; case/andP=> [Dx Hy]; case: (negP Hx); rewrite (eqP Dx).
Qed.

Lemma disjointU : forall a a' b,
  disjoint (setU a a') b = disjoint a b && disjoint a' b.
Proof.
move=> a a' b; rewrite /disjoint; case: (set0Px (setI a b)) => [Hb|Hb] /=.
congr eqn; apply: eq_card => x; move: {Hb}(Hb x); rewrite /setI /setU.
  by case (b x); [ rewrite andbT; move -> | rewrite !andbF ].
apply/(set0Px _) => [Ha]; case: Hb => x; apply/nandP.
case/nandP: {Ha}(Ha x); auto; case/norP; auto.
Qed.

Lemma disjointU1 : forall x a b,
  disjoint (setU1 x a) b = negb (b x) && disjoint a b.
Proof.
by move=> x a b; rewrite -(@eq_disjoint (setU (set1 x) a)) ?disjointU ?disjoint1.
Qed.

Lemma disjoint_has : forall (s : seq d) a, disjoint s a = negb (has a s).
Proof.
move=> s a; rewrite has_count -(eq_count (filter_enum a)) -has_count has_sym.
by rewrite has_count count_filter -filter_setI -count_filter -leqNgt leqn0.
Qed.

Lemma disjoint_cat : forall s1 s2 a,
  disjoint (cat s1 s2) a = disjoint s1 a && disjoint s2 a.
Proof. by move=> *; rewrite !disjoint_has has_cat negb_orb. Qed.

End FiniteSet.

Notation card_uniqP := (card_uniqPx _).
Notation subsetP := (subsetPx _ _).
Notation set0P := (set0Px _).
Notation set0Pn := (set0Pnx _).
Notation subset_eqP := (subset_eqPx _ _).

Prenex Implicits card set0b pick subset disjoint.

Section FunImage.

Variables (d : finSet) (d' : dataSet) (f : d -> d').

Definition codom : set d' := fun x' => negb (set0b (preimage f (set1 x'))).

Remark Hiinv : forall x', codom x' -> {x : d | x' =d f x}.
Proof.
move=> x' Hx'; pose a := x' =d f _.
case: (pickP a) => [x Dx | Hnx']; first by exists x.
by rewrite /codom /preimage -/a (introT set0P Hnx') in Hx'.
Qed.

Definition iinv x' (Hx' : codom x') := let (x, _) := Hiinv Hx' in x.

Lemma codom_f : forall x, codom (f x).
Proof. move=> x; apply/set0Pn; exists x; apply: set11. Qed.

Lemma f_iinv : forall x' (Hx' : codom x'), f (iinv Hx') = x'.
Proof.
by move=> x' Hx'; rewrite /iinv; case: (Hiinv Hx') => [x]; case/eqP.
Qed.

Hypothesis Hf : injective f.

Lemma iinv_f : forall x (Hfx : codom (f x)), iinv Hfx = x.
Proof. move=> x Hfx; apply Hf; apply f_iinv. Qed.

Lemma preimage_iinv : forall a' x' (Hx' : codom x'),
  preimage f a' (iinv Hx') = a' x'.
Proof. by move=> *; rewrite /preimage f_iinv. Qed.

Section Image.

Variable a : set d.

Definition image : set d' := fun x' => negb (disjoint (preimage f (set1 x')) a).

(* This first lemma does not depend on Hf : (injective f). *)
Lemma image_codom : forall x', image x' -> codom x'.
Proof.
move=> x'; case/set0Pn=> x; case/andP; move/eqP=> Dx _; rewrite Dx.
apply codom_f.
Qed.

Lemma image_f : forall x, image (f x) = a x.
Proof.
move=> x; apply/set0Pn/idP => [[y Hy]|Hx].
  by case/andP: Hy => [Dx Hy]; rewrite (Hf (eqP Dx)).
by exists x; rewrite /setI /preimage eqd_refl.
Qed.

Lemma image_iinv : forall x' (Hx' : codom x'), image x' = a (iinv Hx').
Proof. by move=> x' Hx'; rewrite -image_f f_iinv. Qed.

Lemma pre_image : preimage f image =1 a.
Proof. by move=> x; rewrite /preimage image_f. Qed.

End Image.

Lemma image_pre : forall a', image (preimage f a') =1 setI a' codom.
Proof.
move=> a' x'; rewrite /setI andbC; case Hx': (codom x'); simpl.
  by rewrite -(f_iinv Hx') image_f /preimage f_iinv.
apply/idPn => [Hax']; case/idPn: Hx'; exact (image_codom Hax').
Qed.

Fixpoint preimage_seq (s : seq d') : seq d :=
  if s is Adds x s' then
    (if pick (preimage f (set1 x)) is Some y then Adds y else id) (preimage_seq s')
  else seq0.

Lemma maps_preimage : forall s : seq d',
  sub_set s codom -> maps f (preimage_seq s) = s.
Proof.
elim=> [|x s Hrec] //=; case: pickP => [y Dy|Hs'] Hs.
  rewrite /= (eqP Dy) Hrec // => z Hz; apply Hs; exact: setU1r.
by case/set0P: (Hs x (setU11 _ _)).
Qed.

End FunImage.

Prenex Implicits codom iinv image.

Section Ordinal.

Variable n : nat.

Let ordp : set natData := fun m => m < n.

Definition ordData := subData ordp.

Fixpoint iota (m : nat) : seq ordData :=
  if m is S m' then
    if subdIopt ordp m' is Some u then add_last (iota m') u else iota m'
  else seq0.

Lemma iota_ltn : forall m u, iota m u = (subdE u < m).
Proof.
move=> m u; elim: m => [|m Hrec] //=; rewrite /= ltnS leq_eqVlt -Hrec.
case: (subdIoptP ordp m) => [v Hm Dv|Hm].
  by rewrite /= mem_add_last /= /setU1 eqd_sym /eqd /= Dv.
by case: (subdE u =P m) => [Dm|_]; first by case (negP Hm); case Dm; case u.
Qed.

Lemma iotaP : forall u, count (set1 u) (iota n) = 1.
Proof.
move=> [p Hp]; rewrite /eqd /= -/(true : nat) -{}Hp {3}/ordp.
elim: {1 3 4}n (leqnn n) => [|m Hrec] Hm //=; rewrite ltnS.
case: (subdIoptP ordp m) => [v _ Dv|Hm']; last by rewrite /ordp Hm in Hm'.
rewrite -cats1 count_cat (Hrec (ltnW Hm)) /seq1 /= Dv.
by rewrite ltn_neqAle leq_eqVlt; case (eqd p m).
Qed.

Definition ordinal := FinSet iotaP.

Lemma ordinal_ltn : forall x : ordinal, subdE x < n.
Proof. by case. Qed.

Lemma card_ordinal : card ordinal = n.
Proof.
rewrite cardA /=; elim: {-2}n (leqnn n) => [|m Hrec] Hm //=.
case: (subdIoptP ordp m) => [v _ _|Hm']; last by rewrite /ordp Hm in Hm'.
exact (etrans (size_add_last _ v) (congr1 S (Hrec (ltnW Hm)))).
Qed.

Definition make_ord : forall m, m < n -> ordinal := @subdI _ ordp.

End Ordinal.

Section SubFinSet.

Variables (d : finSet) (a : set d).

Fixpoint fsub_enum (s : seq d) : seq (subData a) :=
  if s is Adds x s' then
    (if subdIopt a x is Some u then Adds u else id) (fsub_enum s')
  else seq0.

Lemma fsub_enumP : forall u, count (set1 u) (fsub_enum (enum d)) = 1.
Proof.
move=> [x Hx]; rewrite /eqd /= -(count_set1_enum x).
elim: (enum d) => [|y s Hrec] //=; rewrite -{}Hrec.
case: (subdIoptP a y) => [u Hy Du|Hy]; first by rewrite /= Du.
by case: (x =P y) => [Dx|_] //; rewrite -Dx Hx in Hy.
Qed.

Definition subFin := FinSet fsub_enumP.

Lemma card_sub_dom : @card subFin (subData a) = card a.
Proof.
apply: (etrans (cardA _)); rewrite /card /=.
elim: (enum d) => [|x s Hrec] //=.
by case: (subdIoptP a x) => [u Hx _|Hx]; rewrite ?(Hx) /= -Hrec // ?(negbE Hx).
Qed.

End SubFinSet.

Section ProdFinSet.

Variable d1 d2 : finSet.

Notation pd := (prodData d1 d2) (only parsing).

Definition fprod_enum :=
  foldr (fun x1 => cat (maps (proddI x1) (enum d2))) seq0 (enum d1).

Lemma fprod_enumP : forall u, count (set1 u) fprod_enum = 1.
Proof.
move=> [x1 x2]; rewrite -[1]/(d1 x1 : nat) -mem_enum /fprod_enum.
elim: (enum d1) (uniq_enum d1) => [|y1 s1 Hrec] //=; move/andP=> [Hy1 Hs1].
rewrite count_cat {Hrec Hs1}(Hrec Hs1) count_maps /setU1 /comp.
case Hx1: (y1 =d x1) => /=.
  rewrite (eqP Hx1) in Hy1; rewrite (negbE Hy1) (eqP Hx1) /= addn0 -(card1 x2).
  by apply: eq_count => y2; rewrite {1}/eqd /= set11.
rewrite addnC -{2}(addn0 (s1 x1)) -(card0 d2); congr addn.
by apply: eq_count => y; rewrite eqd_sym /eqd /= Hx1.
Qed.

Definition prodFin := FinSet fprod_enumP.

Lemma card_prod_dom : @card prodFin (prodData d1 d2) = card d1 * card d2.
Proof.
apply: (etrans (cardA _)); rewrite /= /fprod_enum !cardA.
by elim: (enum d1) => [|x1 s1 Hrec] //=; rewrite size_cat {}Hrec size_maps.
Qed.

End ProdFinSet.

Section SumFinSet.

Variables (I : finSet) (d : I -> finSet).

Definition sumfin_subdom i : dataSet := d i.
Let fsd : dataSet := sumData sumfin_subdom.

Fixpoint fsum_enum (si : seq I) : seq fsd :=
  if si is Adds i si' then
    cat (maps (fun x => sumdI x : fsd) (enum (d i))) (fsum_enum si')
  else seq0.

Lemma fsum_enumP : forall u, count (set1 u) (fsum_enum (enum I)) = 1.
Proof.
move=> [i x]; rewrite -[1]/(I i : nat) -mem_enum.
elim: (enum I) (uniq_enum I) => [|j s Hrec] //=; case/andP=> [Hj Hs].
rewrite count_cat {Hrec Hs}(Hrec Hs).
rewrite count_filter filter_maps size_maps /= /setU1 -count_filter.
case Hi: (j =d i); rewrite /= /comp.
  rewrite (eqP Hi) in Hj; rewrite (negbE Hj) (eqP Hi) /= addn0 -(card1 x).
  apply: eq_count => y; exact (sumd_eqdr x y).
rewrite addnC -{2}(addn0 (s i)) -(card0 (d j)); congr addn.
apply: eq_count => y; rewrite eqd_sym.
apply/idP => Hy; case/idP: Hi; exact (sumd_eqdl Hy).
Qed.

Definition sumFin := FinSet fsum_enumP.

Lemma card_sum_dom :
  @card sumFin fsd = foldr (fun i => addn (card (d i))) 0 (enum I).
Proof.
apply: (etrans (cardA _)); simpl; elim: (enum I) => [|i s Hrec] //=.
by rewrite /= -Hrec size_cat size_maps Hrec cardA.
Qed.

End SumFinSet.

Section IsoCard.

Lemma monic_card_leq :  forall (d d' : finSet) (f : d -> d') (g : d' -> d),
  monic f g -> card d <= card d'.
Proof.
move=> d d' f g Hfg; rewrite (cardA d') -(size_maps g).
apply: (leq_trans (subset_leq_card _) (card_size _)).
by apply/subsetP => [x _]; apply/mapsP; exists (f x); rewrite ?mem_enum.
Qed.

Lemma iso_eq_card_dom : forall d d' : finSet,
  (exists f : d -> d', iso f) -> card d = card d'.
Proof.
move=> d d' [f [g Hfg Hgf]]; apply: eqP.
by rewrite eqn_leq (monic_card_leq Hfg) (monic_card_leq Hgf).
Qed.

Lemma eq_datum_card : forall d d' : finSet, d = d' :> Set -> card d = card d'.
Proof.
move=> d [[d' eqd' eqd'P] ed' Hed'] Hdd'; simpl in Hdd'.
case: d' / Hdd' in eqd' eqd'P ed' Hed' |- *.
by apply iso_eq_card_dom; do 2 exists (@id d).
Qed.

Lemma iso_eq_card : forall (d d' : finSet) (a : set d) (a' : set d'),
 (exists f : @subd _ a -> @subd _ a', iso f) -> card a = card a'.
Proof.
move=> d d' a a' Haa'; rewrite -(card_sub_dom a) -(card_sub_dom a').
by apply: iso_eq_card_dom.
Qed.

Definition eq_dom_size d1 d2 := size (enum d1) = size (enum d2).

Definition assoc_findom : forall d1 d2, eq_dom_size d1 d2 -> d1 -> d2.
move=> d1 d2 E12 x1; apply (fun y2 => sub y2 (enum d2) (index x1 (enum d1))).
abstract by move: E12; rewrite /eq_dom_size; case: (enum d2) => //;
           case: (enum d1) (mem_enum x1).
Defined.

Lemma assoc_findom_monic : forall d1 d2,
 forall (E12 : eq_dom_size d1 d2) (E21 : eq_dom_size d2 d1),
 monic (assoc_findom E12) (assoc_findom E21).
Proof.
rewrite /eq_dom_size; move=> d1 d2 E12 E21 x.
set y := assoc_findom E12 x; rewrite /assoc_findom {2}/y /assoc_findom.
by rewrite index_uniq ?sub_index ?uniq_enum ?E21 ?index_mem ?mem_enum.
Qed.

Lemma eq_card_iso_dom : forall d1 d2 : finSet,
  card d1 = card d2 -> {f : d1 -> d2 &  {g : d2 -> d1 | monic f g &  monic g f}}.
Proof.
move=> d d'; rewrite !cardA; move=> E12; have E21 := esym E12.
exists (assoc_findom E12); exists (assoc_findom E21); apply assoc_findom_monic.
Qed.

Lemma eq_card_iso : forall (d d' : finSet) (a : set d) (a' : set d'),
 let da := @subd d a in let da' := @subd d' a' in
 card a = card a' -> {f : da -> da' &  {g : da' -> da | monic f g &  monic g f}}.
Proof.
move=> d d' a a' /= Haa'; apply: eq_card_iso_dom (subFin a) (subFin a') _.
by rewrite /= !card_sub_dom.
Qed.

End IsoCard.

Section CardFunImage.

Variables (d d' : finSet) (f : d -> d').

Lemma leq_image_card : forall a, card (image f a) <= card a.
Proof.
move=> a; set p := filter a (enum d).
have Up: (uniq p) by apply: uniq_filter; apply uniq_enum.
rewrite -(eq_card (filter_enum a)) -/p (card_uniqP Up) -(size_maps f).
apply: (leq_trans (subset_leq_card _) (card_size _)); apply/subsetP => u.
case/set0Pn=> x; case/andP; move/eqP=> Du Hx.
by apply/mapsP; exists x; first by rewrite /p filter_enum.
Qed.

Hypothesis Hf : injective f.

Lemma card_image : forall a, card (image f a) = card a.
Proof.
move=> a; apply iso_eq_card.
have Hf1: forall w : @subd _ (image f a), a (iinv (image_codom (subd_mem w))).
  by move=> [x' Hx']; rewrite -image_iinv.
have Hf2: forall w : @subd _ a, image f a (f (subdE w)).
  by move=> [x Hx]; rewrite image_f.
exists (fun w => @subdI d _ _ (Hf1 w)); exists (fun w => @subdI d' _ _ (Hf2 w)).
  by move=> [x Hx]; apply: subdE_inj; rewrite /= f_iinv.
by move=> [x Hx]; apply: subdE_inj; rewrite /= iinv_f.
Qed.

Lemma card_codom : card (codom f) = card d.
Proof.
apply: etrans (card_image d); apply: eq_card => x'.
apply/idPn/idP; last exact: image_codom.
by move=> Hx; rewrite -(f_iinv Hx) image_f.
Qed.

Lemma card_preimage : forall a', card (preimage f a') = card (setI (codom f) a').
Proof.
move=> a'; apply: etrans (esym (card_image _)) (eq_card _) => x'.
by rewrite (image_pre Hf) /setI andbC.
Qed.

End CardFunImage.

Unset Implicit Arguments.


Require Import Metalib.Metatheory.
Require Import Coq.Program.Equality.
Require Import Language LN LibTactics.
Require Import Strings.String.
Require Import Program.Tactics.

Lemma ptype_determinism :
  forall (e : trm) (A B : typ),
    ptype e A -> ptype e B -> A = B.
Proof.
  intros. generalize dependent B.
  dependent induction H; eauto; intros * Hptyp.
  - dependent destruction Hptyp; eauto.
  - dependent destruction Hptyp; eauto.
  - dependent destruction Hptyp; eauto.
  - dependent destruction Hptyp; eauto.
    assert (A = A0); eauto.
    assert (B = B0); eauto.
    congruence.
Qed.

Hint Resolve ptype_determinism : ptype.

Ltac simpl_deter :=
  repeat
    match goal with
    | [H1: ptype ?v ?A1, H2: ptype ?v ?A2 |- _] => (eapply ptype_determinism in H1; eauto; subst)
    end.

Lemma typing_to_ptype :
  forall (A : typ) (v : trm),
    value v ->
    typing nil v A ->
    ptype v A.
Proof.
  introv Hv Htyp.
  generalize dependent A.
  dependent induction Hv; eauto; introv Htyp.
  - dependent destruction Htyp; eauto.
  - dependent destruction Htyp; eauto.
Qed.

Lemma typing_to_ptype_uvalue :
  forall (A : typ) (u : trm),
    uvalue u ->
    typing nil u A ->
    ptype u A.
Proof.
  introv Hu Htyp.
  gen A.
  dependent induction Hu; eauto; intros.
  - dependent destruction Htyp; eauto.
  - dependent destruction Htyp; eauto.
Qed.

Hint Resolve typing_to_ptype : ptype core.
Hint Resolve typing_to_ptype_uvalue : ptype core.

Lemma typing_and_ptype :
  forall A B u,
    value u ->
    ptype u A ->
    typing nil u B ->
    A = B.
Proof.
  introv Hv Hp Htyp.
  eapply typing_to_ptype in Htyp; eauto.
  eapply ptype_determinism; eauto.
Qed.

Hint Resolve typing_and_ptype : ptype.