From Ssreflect
Require Import ssreflect ssrfun ssrbool ssrnat eqtype choice seq fintype.

From MathComp
Require Import bigop  finfun finset generic_quotient perm tuple fingroup.

Require Import finmap finsfun finperm utilitaires.

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

Delimit Scope finperm_scope with fperm.
Local Open Scope finperm_scope.
Local Open Scope fset.
Local Open Scope quotient_scope.

Import Key.Exports.

Definition atom := nat.

Axiom funext : forall {X : Type} {I : finType} (f g : I -> X),
                 f =1 g -> f = g.

Section NominalDef.

Variable A : keyType.

Record perm_setoid_mixin_of (X : Type) (R : X -> X -> Prop) :=
  PermSetoidMixin {
  act_op : {finperm A} -> X -> X;
  _ : forall x, R ((act_op 1) x) x;
  _ : forall π π' x, R (act_op (π * π') x) (act_op π (act_op π' x));
  _ : forall x y π, R x y -> R (act_op π x) (act_op π y)
}.

Record nominal_mixin_of (X : Type) := NominalMixin {
  perm_setoid_mixin :> @perm_setoid_mixin_of X (@eq X);
  support_op : X -> {fset A};
  _ : forall (π : {finperm A}) x,
        (forall a : A, a \in support_op x -> π a = a) ->
        (act_op perm_setoid_mixin π x) = x
}.

Record nominal_class_of (X : Type) := NominalClass {
  nominal_choice_mixin :> @Choice.class_of X;
  nominal_mixin :> @nominal_mixin_of X
}.

Structure nominalType (phA : phant A) := NominalPack {
  nominal_sort :> Type;
  nominal_class : nominal_class_of nominal_sort;
  _ : Type
}.
Local Notation "{nominalType}" := (nominalType (Phant A)).

Variables (T : Type) (cT : {nominalType}).

Definition act := act_op (nominal_class cT).
Definition support := support_op (nominal_class cT).

Definition nominal_pack (phA : phant A) m :=
  fun bT b & phant_id (Choice.class bT) b =>
  @NominalPack phA T (@NominalClass T b m) T.

Definition nominal_clone c of phant_id nominal_class c :=
  @NominalPack (Phant A) T c T.
Let nominal_xT := let: NominalPack T _ _ := cT in T.
Notation nominal_xclass := (@nominal_class (Phant A) cT : nominal_class_of nominal_xT).

Canonical nominal_eqType := @Equality.Pack cT nominal_xclass nominal_xT.
Canonical nominal_choiceType := @Choice.Pack cT nominal_xclass nominal_xT.

End NominalDef.

Coercion nominal_eqType : nominalType >-> Equality.type.
Coercion nominal_choiceType : nominalType >-> Choice.type.

Notation NominalType A T m := (@nominal_pack _ T (Phant A) m _ _ id).
Notation "{nominalType  A }" := (@nominalType _ (Phant A)).

Notation "π \dot x" := (@act _ _ π x)
                         (x at level 60, at level 60).
Notation swap := tfinperm.

Section BasicNominalTheory.

Variables (A : keyType) (W X Y Z : {nominalType A}).
Implicit Types (π : {finperm A}) (x : X).

Local Notation actX := (@act A X).
Definition pfixe (π : {finperm A}) (B : {fset A}) := forall a, a \in B -> π a = a.

Lemma act1 : actX 1 =1 id.
Proof. by case: X => ? [? [[]]]. Qed.

Lemma actM (π1 π2 : {finperm A}) : forall x : X,  (π1 * π2) \dot x = π1 \dot (π2 \dot x).
Proof. by case: X => ? [? [[]]]. Qed.

Lemma act_id : forall π (x : X), pfixe π (support x)
                   -> (act π x) = x.
Proof. by case: X => ? [? []]. Qed.

Lemma actK π : cancel (actX π) (actX π^-1).
Proof. by move => x; rewrite -actM (finperm_invP π) act1. Qed.

Lemma actVK π : cancel (actX π^-1) (actX π).
Proof. by move => x; rewrite -actM (finperm_invVP π) act1. Qed.

Lemma act_inj π : injective (actX π).
Proof. by move => x y /(congr1 (act π^-1)); rewrite !actK. Qed.

Lemma act_conj π a b x : π \dot (swap a b) \dot x = swap (π a) (π b) \dot π \dot x.
Proof. by rewrite -!actM tfinperm_conj. Qed.

Lemma act_conj_imL π a b x : π \dot (swap a (π^-1 b)) \dot x = swap (π a) b \dot π \dot x.
Proof. by rewrite -!actM tfinperm_conj_imL. Qed.

Lemma act_conj_imR π a b x : π \dot (swap (π^-1 a) b) \dot x = swap a (π b) \dot π \dot x.
Proof. by rewrite -!actM tfinperm_conj_imR. Qed.

Lemma pfixeU π B C : pfixe π (B `|` C) -> pfixe π B /\ pfixe π C.
Proof.
move=> fixeBC; split; rewrite/pfixe => a Ha.
all: by apply/fixeBC; rewrite in_fsetU Ha ?orbT.
Qed.

Lemma pfixe1 π a : pfixe π [fset a] -> π a = a.
Proof. apply; exact/fset11. Qed.

Lemma pfixe1U π a B : pfixe π (a |` B) -> π a = a /\ pfixe π B.
Proof.
move => fixeaB; split => [|b Hb] ; first exact/fixeaB/fset1U1.
exact/fixeaB/fset1Ur.
Qed.

End BasicNominalTheory.

Section NominalTrivial.

Variables (A : keyType) (X : choiceType).

Definition trivialact (π : {finperm A}) (x : X) := x.

Lemma trivialact1 : forall x, trivialact 1 x = x.
Proof. by []. Qed.

Lemma trivialactM π π' x : trivialact (π * π') x = trivialact π (trivialact π' x).
Proof. by []. Qed.

Lemma trivialactproper x y π : x = y -> (trivialact π x) = (trivialact π y).
Proof.  by move ->. Qed.

Definition trivial_nominal_setoid_mixin :=
  @PermSetoidMixin A X (@eq X) trivialact trivialact1 trivialactM trivialactproper.

Lemma trivialact_id (π : {finperm A})  x :
  (forall a, a \in fset0 -> π a = a) -> trivialact π x = x.
Proof. by []. Qed.

Definition trivial_nominal_mixin :=
  @NominalMixin A X trivial_nominal_setoid_mixin _ trivialact_id.

Definition trivial_nominal_type :=
  NominalType A X trivial_nominal_mixin.

Lemma trivialactE π x : trivialact π x = x.
Proof. by []. Qed.

End NominalTrivial.

Canonical bool_nominalType (A : keyType) :=
  NominalType A bool (@trivial_nominal_mixin A [choiceType of bool]).

Section NominalOpt.

Variables (A : keyType) (X : {nominalType A}).

Definition optact (π : {finperm A}) (x : option X) := omap (act π) x.

Lemma optact1 x : optact 1 x = x.
Proof. by case: x => //= a; rewrite act1. Qed.

Lemma optactM π π' x : optact (π * π') x = optact π (optact π' x).
Proof. by case: x => //= a; rewrite actM. Qed.

Lemma optactproper x y π : x = y -> (optact π x) = (optact π y).
Proof. by move ->. Qed.

Definition opt_nominal_setoid_mixin :=
  @PermSetoidMixin A (option X) (@eq _) optact optact1 optactM optactproper.

Definition opt_support (o : option X) :=
  if o is Some a then support a else fset0.

Lemma optact_id (π : {finperm A}) x :
  (forall a, a \in opt_support x -> π a = a) -> optact π x = x.
Proof. by case: x => //= a act_pi; rewrite act_id. Qed.

Canonical opt_nominal_mixin :=
  @NominalMixin A (option X) opt_nominal_setoid_mixin _ optact_id.

Canonical opt_nominal_type := NominalType A (option X) opt_nominal_mixin.

Lemma optactE π x : optact π (Some x) = Some (π \dot x).
Proof. by []. Qed.

End NominalOpt.

Section NominalList.

Variables (A : keyType) (X : {nominalType A}).

Definition listact π (l : seq X) := map (act π) l.

Lemma listact1 l : listact 1 l = l.
Proof.
elim: l => //= a l IHl. by rewrite act1 IHl.
Qed.

Lemma listactM π π' l : listact (π * π') l = listact π (listact π' l).
Proof.
elim: l => //= a l IHl. by rewrite actM IHl.
Qed.

Lemma listactproper l1 l2 π : l1 = l2 -> listact π l1 = listact π l2.
Proof. by move ->. Qed.

Definition list_nominal_setoid_mixin :=
  @PermSetoidMixin A (seq X) (@eq (seq X)) listact listact1 listactM listactproper.

Definition list_support (l : seq X) := fsetU_list [seq support x | x <- l].

Lemma listact_id (π : {finperm A}) l :
  (forall a, a \in list_support l -> π a = a) -> listact π l = l.
Proof.
elim: l => //= x l IHl Hal.
rewrite IHl => [|a a_supp_l].
  rewrite act_id //= => a a_supp_x.
  apply Hal. by rewrite /list_support/= in_fsetU a_supp_x.
apply Hal. by rewrite /list_support /= in_fsetU a_supp_l orbT.
Qed.

Definition list_nominal_mixin :=
  @NominalMixin A _ list_nominal_setoid_mixin _ listact_id.

Canonical list_nominal_type := NominalType A (seq X) list_nominal_mixin.

Lemma listactE π (l : seq X) : π \dot l = [seq π \dot x | x <- l].
Proof. by []. Qed.

Lemma cons_support (l : seq X) (x : X) :
  list_support (x :: l) = (support x) `|` (list_support l).
Proof. by []. Qed.

(* Lemma mem_support (l : seq X) (t : X) : *)
(*   t \in l -> support t `<=` support l. *)
(* Proof. *)
(* elim: l => [|u l IHl]. *)
(*   by rewrite in_nil. *)
(* rewrite in_cons => /orP. case. *)
(*   move => /eqP -> /=.  *)

End NominalList.

Section NominalProd.

Variables (A : keyType) (X Y : {nominalType A}).
Implicit Type (x : X * Y).

Definition prodact π x := (π \dot x.1, π \dot x.2).

Lemma prodact1 : forall x, prodact 1 x = x.
Proof. by case => x y; rewrite /prodact !act1. Qed.

Lemma prodactM π π' : forall x, prodact (π * π') x = prodact π (prodact π' x).
Proof. by case => x y /=; rewrite /prodact !actM. Qed.

Lemma prodactproper : forall x y π, x = y -> (prodact π x) = (prodact π y).
Proof. by move => x y π ->. Qed.

Definition prod_nominal_setoid_mixin :=
  @PermSetoidMixin A (X * Y) (@eq (X * Y)) prodact prodact1 prodactM prodactproper.

Lemma prodact_id (π : {finperm A}) x :
     (forall a, a \in (support x.1 `|` support x.2) -> π a = a) -> prodact π x = x.
Proof.
case: x => x y Hsupp. rewrite /prodact !act_id //= => a asupp; apply Hsupp;
rewrite in_fsetU asupp ?orbT //.
Qed.

Definition prod_nominal_mixin :=
  @NominalMixin A _ prod_nominal_setoid_mixin _ prodact_id.

Canonical prod_nominal_type :=
  NominalType A (X * Y) prod_nominal_mixin.

Lemma prodactE π (y : X) (z : Y) : π \dot (y, z) = (π \dot y, π \dot z).
Proof. by []. Qed.

End NominalProd.

(* Lemma strong_prodctsupport π a : *)
(*   atomact π a = a -> (forall b, b \in fset1 a -> atomact π b = b). *)
(* Proof. move => /= πa_eq_a b. by rewrite in_fset1 => /eqP ->. Qed. *)

Section NominalAtoms.

Implicit Types (π : {finperm atom}) (a : atom).

Definition atomact π a := π a.

Lemma atomact1 : forall (a : atom), atomact 1 a = a.
Proof. by move => a /=; rewrite /atomact finsfun1. Qed.

Lemma atomactM : forall π π' a, atomact (π * π') a = atomact π (atomact π' a).
Proof. by move => π π' a /=; rewrite /atomact finsfunM. Qed.

Lemma atomactproper : forall x y π, x = y -> (atomact π x) = (atomact π y).
Proof. by move => x y π ->. Qed.

Definition atom_nominal_setoid_mixin :=
  @PermSetoidMixin _ atom (@eq atom) atomact atomact1 atomactM atomactproper.

Lemma atomact_id π a :
     (forall b, b \in fset1 a -> atomact π b = b) -> atomact π a = a.
Proof. apply. by rewrite in_fset1. Qed.

Lemma strong_atomactsupport π a :
  atomact π a = a -> (forall b, b \in fset1 a -> atomact π b = b).
Proof. move => /= πa_eq_a b. by rewrite in_fset1 => /eqP ->. Qed.

Definition atom_nominal_mixin :=
  @NominalMixin _ atom atom_nominal_setoid_mixin _ atomact_id.

Canonical atom_nominal_type := NominalType atom atom atom_nominal_mixin.

Lemma swapL (a b : atom) : (swap a b) \dot a = b.
Proof. by rewrite /act /= /atomact tfinpermL. Qed.

Lemma swapR (a b : atom) : (swap a b) \dot b = a.
Proof. by rewrite /act /= /atomact tfinpermR. Qed.

Lemma atomactE π a : π \dot a = π a.
Proof. by []. Qed.

End NominalAtoms.

Section NominalAtomSubsets.

Implicit Types (π : {finperm atom}) (A : {fset atom}).

Definition ssatomact π A := im π A.

Lemma ssatomact1 : forall A, ssatomact 1 A = A.
Proof.
move => A /=; rewrite -{2}[A](im_id A). apply im_eq1 => a.
by rewrite finsfun1.
Qed.

Lemma ssatomactM : forall π π' A, ssatomact (π * π') A = ssatomact π (ssatomact π' A).
Proof.
move => π π' A /=; rewrite /ssatomact -imM. apply im_eq1 => a.
by rewrite finsfunM.
Qed.

Lemma ssatomactproper : forall A B π, A = B -> (ssatomact π A) = (ssatomact π B).
Proof. by move => A B π ->. Qed.

Lemma ssatomact_id π A :
  (forall b, b \in A -> π b = b) -> ssatomact π A = A.
Proof.
move => Asupp /=; apply/fsetP => a; apply/imfsetP/idP => [[b bA]->|aA].
  rewrite Asupp; exact: valP.
exists (FSetSub aA) => //. by rewrite Asupp.
Qed.

(* bricolage *)

Definition code (A : {fset atom}) := fset_keys A.
Definition decode (s : seq atom) := seq_fset s.

Lemma fset_codeK : cancel code decode.
Proof.
Admitted.

Definition finSet_ChoiceMixin := CanChoiceMixin fset_codeK.
Canonical finset_choiceType := Eval hnf in ChoiceType {fset atom} finSet_ChoiceMixin.

Definition ssatom_nominal_setoid_mixin :=
  @PermSetoidMixin _ {fset atom} (@eq {fset atom}) ssatomact ssatomact1 ssatomactM ssatomactproper.

Definition ssatom_nominal_mixin :=
  @NominalMixin _ {fset atom} ssatom_nominal_setoid_mixin _ ssatomact_id.

Canonical ssatom_nominal_type :=
  @NominalType atom {fset atom} ssatom_nominal_mixin.

Lemma mem_imperm π A (a : atom) : (π a \in π \dot A) = (a \in A).
Proof. by apply/mem_im/finperm_inj. Qed.

End NominalAtomSubsets.

Section Nominalffun.

(* ATtention, il ne s'agit pas des ffun de ssreflect, mais des
fonctions d'un type fini dans un nominalType *)

Context (X : {nominalType atom}) (I : finType).

Definition ffunact π (f : I -> X) i := π \dot f i.

Lemma ffunact1 : ffunact 1 =1 id.
Proof.
move => f /=.
apply/funext => i.
by rewrite /ffunact act1.
Qed.

Lemma ffunactM : forall π π' f, ffunact (π * π') f = ffunact π (ffunact π' f).
Proof.
move => π π' f /=.
apply/funext => i.
by rewrite /ffunact actM.
Qed.

Lemma ffunactproper : forall f g π, f = g -> (ffunact π f) = (ffunact π g).
Proof. by move => f g π ->. Qed.

Lemma ffunact_id (π : {finperm atom}) f :
  (forall b, b \in (\fbigcup_(i in I) (support (f i))) -> π b = b) -> ffunact π f = f.
Proof.
move => fsupp /=.
apply/funext => i.
rewrite /ffunact. apply/act_id => a a_supp_fi.
apply/fsupp/fbigcupP. by exists i.
Qed.

Definition code_ffun (f : I -> X) : {ffun I -> X} := [ffun x => f x].
Definition decode_ffun (f : {ffun I -> X}) x : X := f x.

Lemma ffun_codeK : cancel code_ffun decode_ffun.
Proof. by move=> f; apply/funext => x; rewrite /decode_ffun ffunE. Qed.

(* rewrite/code_ffun/decode_ffun => f. *)
(* apply/funext => i.  *)
(* exact/ffunE. *)
(* Qed. *)

Definition ffun_EqMixin := CanEqMixin ffun_codeK.
Canonical ffun_eqType := Eval hnf in EqType (I -> X) ffun_EqMixin.

Definition ffun_ChoiceMixin := CanChoiceMixin ffun_codeK.
Canonical ffun_choiceType := Eval hnf in ChoiceType (I -> X) ffun_ChoiceMixin.
(* bizarre : si j'écris ChoiceType ffun_eqType ffun_ChoiceMixin, *)
(* j'ai des problèmes plus loin avec /eqP ... *)

Definition ffun_nominal_setoid_mixin :=
  @PermSetoidMixin _ _ (@eq (I -> X)) ffunact ffunact1 ffunactM ffunactproper.

Definition ffun_nominal_mixin :=
  @NominalMixin _ (I -> X) ffun_nominal_setoid_mixin _ ffunact_id.

Canonical ffun_nominal_type :=
  NominalType atom (I -> X) ffun_nominal_mixin.

Lemma ffunactE π (f : I -> X) i : (π \dot f) i = π \dot f i.
Proof. by []. Qed.

End Nominalffun.

Section Freshness.

Implicit Types (X Y: {nominalType atom}).

Definition max (A : {fset atom}) := \max_(a : A) val a.

Definition fresh_in X (x : X) : atom := (max (support x)).+1.

Definition supports X (A : {fset atom}) (x : X) :=
  forall (π : {finperm atom}), (forall a : atom, a \in A -> π a = a) -> π \dot x = x.

Lemma supportsP (X : {nominalType atom}) (x : X) :
  supports (support x) x.
Proof.
move => π.
exact: act_id.
Qed.

Lemma in_le_max x (A : {fset atom}) : x \in A -> x <= max A.
Proof.
Admitted.

Lemma fresh_notin (A : {fset atom}) : (fresh_in A) \notin A.
Proof.
  rewrite /fresh_in /support /=.
  have bounded: forall x, x \in A -> x != (max A).+1.
  move=> x xinA. rewrite neq_ltn. apply/orP.
  apply: or_introl. by apply: in_le_max.
  apply/memPn; apply: bounded.
Qed.

Lemma fresh_neq_in (A : {fset atom}) a : a \in A -> a != fresh_in A.
Proof. apply contraL => /eqP ->. exact: fresh_notin. Qed.

Lemma fresh_neq (x : atom) : x != fresh_in x.
Proof. rewrite/fresh_in/support/=.
Admitted.

Lemma supports_fsetP (A B  : {fset atom}) : reflect (supports A B) (B `<=` A).
Proof.
apply: (iffP idP) =>[/fsubsetP B_sub_A π fix_A|A_supp_B].
  apply ssatomact_id => b /B_sub_A. exact: (fix_A b).
apply/fsubsetP => a aB.
apply contraT => aNA.
have a_fAB : swap a (fresh_in (A, B)) \dot B = B.
apply A_supp_B => b bA. apply/tfinpermNone/andP. split.
  apply/eqP => H; subst; by rewrite bA in aNA.
  have : b \in A `|` B by rewrite in_fsetU bA.
    exact: fresh_neq_in.
have : fresh_in (A, B) \in A `|` B.
  rewrite in_fsetU; apply /orP; right.
  by rewrite -(tfinpermL a (fresh_in (A, B))) -{2}a_fAB ?mem_imperm.
by move/fresh_neq_in/eqP.
Qed.

Lemma supportsI (X : {nominalType atom}) (A B : {fset atom}) (x : X) :
  supports A x -> supports B x -> supports (A `&` B) x.
Proof.
(* suppose le théorème de décomposition des permutations en
   produit de transpositions *)
Admitted.

Definition fresh X a (x : X) := exists (S : {fset atom}), a \notin S /\ supports S x.

Notation "a # x" := (fresh a x) (x at level 60, at level 60).

Lemma fresh1P X (x : X) : (fresh_in x) # x.
Proof.
exists (support x).
split.
  exact: fresh_notin.
exact: supportsP.
Qed.

Lemma fresh_equiv (X : {nominalType atom}) (x : X) a (π : {finperm atom}) :
  (a # x) <-> (π a) # (π \dot x).
Proof.
wlog suff : x π a / a # x -> (π a) # (π \dot x) => Hsuff.
  split; first by apply Hsuff.
  rewrite -{2}[a](finpermK π) -{2}[x](actK π).
  exact: Hsuff.
move : Hsuff => [S] [aNS supp_S_x].
exists (π \dot S). split; first by rewrite mem_imperm.
move => Ɣ HƔ. apply (@act_inj _ _ π^-1). rewrite actK -2?actM.
apply supp_S_x => b bS. rewrite finsfunM /= finsfunM /= HƔ;
  first exact: finpermK.
by rewrite mem_imperm.
Qed.

Lemma im_fresh (X : {nominalType atom}) (π : {finperm atom}) a (x : X) :
  a # (π^-1 \dot x) -> (π a) # x.
Proof. by rewrite -{2}[x](actVK π); apply fresh_equiv. Qed.

Lemma im_inv_fresh (X : {nominalType atom}) (π : {finperm atom}) a (x : X) :
  a # (π \dot x) -> (π^-1 a) # x.
Proof. rewrite -{2}[x](actK π). by apply fresh_equiv. Qed.

Lemma CFN_principle b {X : {nominalType atom}} {a} {x : X} :
  b # x -> swap a b \dot x = x -> a # x.
Proof.
move => bFx abx_eq_x.
apply (@fresh_equiv _ _ _ (swap a b)).
by rewrite tfinpermL abx_eq_x.
Qed.

Lemma fresh_atomP (x y : atom) : reflect (x # y) (x != y).
Proof.
apply: (iffP idP) => [xNy| [S] [xNS S_supp_y]].
  apply (@CFN_principle (fresh_in y)); first exact: fresh1P.
  apply/tfinpermNone/andP; split; first by rewrite eq_sym.
  exact: fresh_neq.
apply/negP => /eqP x_eq_y.
rewrite -x_eq_y in S_supp_y.
have : forall a, a \notin S -> a = x.
  move => a aNS. rewrite -(tfinpermR a x). apply S_supp_y => b bS.
  apply/tfinpermNone/andP; split; apply/eqP => H; subst.
    by rewrite bS in aNS.
  by rewrite bS in xNS.
have freshxSNS : (fresh_in (x |` S)) \notin S.
  move: (fresh_notin (support x `|` S)).
  by rewrite in_fset1U negb_or => /andP; case.
move/(_ (fresh_in (x |` S))) /(_ freshxSNS).
move: (fresh_neq_in (fset1U1 x S)).
by rewrite eq_sym => /eqP.
Qed.

Lemma fresh_atomC (x y : atom) : x # y <-> y # x.
Proof.
split => hFresh .
all: apply/fresh_atomP.
all: rewrite eq_sym.
all: by apply/fresh_atomP.
Qed.

Lemma fresh_fsetP (A : {fset atom}) x : reflect (x # A) (x \notin A).
Proof.
apply: (iffP idP) => [xNA|[S] [xNS /supports_fsetP /fsubsetP S_supp_A ]].
  exists A. split => //. exact: supportsP.
exact: (contra (S_supp_A x)).
Qed.

Lemma fresh_fsetU1 (A B : {fset atom}) x : x # (A `|` B) -> x # A.
Proof.
move/fresh_fsetP.
rewrite in_fsetU negb_or => /andP [? _].
exact/fresh_fsetP.
Qed.

Lemma fresh_fsetU2 (A B : {fset atom}) x : x # (A `|` B) -> x # B.
Proof.
move/fresh_fsetP.
rewrite in_fsetU negb_or => /andP [_ ?].
exact/fresh_fsetP.
Qed.

Lemma fresh_support X a (x : X) : a \notin (support x) -> a # x.
Proof.
move => aNx. exists (support x).
split => //.
exact: supportsP.
Qed.

Lemma act_fresh {X : {nominalType atom}} (a b : atom) (x : X) :
      a # x -> b # x -> swap a b \dot x = x.
Proof.
move => [Sa [aNSa supp_Sa_x]] [Sb [bNSb supp_Sb_x]].
have supp_SaISb_x : supports (Sa `&` Sb) x by apply: supportsI.
apply supp_SaISb_x => c. rewrite in_fsetI => /andP [cSa cSb].
have aNc : c != a.
  apply/negP => /eqP a_eq_c. move: cSa aNSa.
  by rewrite a_eq_c => ->.
have bNc : c != b.
  apply/negP => /eqP b_eq_c. move: cSb bNSb.
  by rewrite b_eq_c => ->.
apply tfinpermNone.
by rewrite aNc bNc.
Qed.

Lemma fresh_prod X Y a (x : X) (y : Y) : a # (x, y) <-> (a # x) /\ (a # y).
Proof.
split.
  move => [S] [aNS supp_S_xy].
  split; exists S; split => //; move => π /(supp_S_xy π); rewrite prodactE.
    by move/(congr1 fst).
  by move/(congr1 snd).
move => [[Sx] [aNSx supp_Sx_x] [Sy] [aNSy supp_Sy_y]].
exists (Sx `|` Sy); split.
  by rewrite in_fsetU negb_or aNSx aNSy.
move => π H. rewrite prodactE.
have -> : π \dot x = x.
  apply (supp_Sx_x π) => b bSx. apply H.
  by rewrite in_fsetU bSx.
suff : π \dot y = y by move ->.
apply (supp_Sy_y π) => b bSy. apply H.
  by rewrite in_fsetU bSy orbT.
Qed.

Lemma fresh_nil {X} a : a # @nil X.
Proof.
exists fset0. split => //.
by rewrite in_fset0.
Qed.

Lemma supports_cons {X} S (x : X) (l : seq X):
  supports S (x :: l) -> supports S x /\ supports S l.
Proof.
move => S_supp_xl.
split => π HS.
all: move : (S_supp_xl π HS) => /= /eqP.
all: by rewrite !listactE /= eqseq_cons => /andP [/eqP ? /eqP ?].
Qed.

Lemma fresh_cons {X} (l : seq X) a x : a # (x :: l) <-> a # x /\ a # l.
Proof.
split.
  move => [S] [aNS /supports_cons [S_supp_x S_supp_l]].
  split; by exists S; split => //.
move => [[Sa] [aNSa Sa_supp_x] [Sl] [aNSl Sl_supp_l]].
exists (Sa `|` Sl); split.
  by rewrite in_fsetU negb_or aNSa aNSl.
move => π H.
Admitted.

Lemma fresh_list {X} (l : seq X) a : a # l <-> forall x, x \in l -> a # x.
Proof.
elim: l => [|b l IH].
  split => // ?; exact/fresh_nil.
split => [/fresh_cons [aFb aFl] y|Hbl].
   rewrite inE => /orP. case.
    by move /eqP ->.
  exact/(iffLR IH aFl).
apply fresh_cons; split.
  exact/Hbl/mem_head.
apply IH => x xl; apply/Hbl.
by rewrite in_cons xl orbT.
Qed.

Lemma fresh_map {T : finType} {X : {nominalType atom}} (f : T -> X) a :
  a # [seq f i | i : T] -> forall i, a # f i.
Proof.
move/fresh_list => H i.
exact/H/map_f/mem_enum.
Qed.

Lemma fresh_fun {I : finType} {X} (f : I -> X) a i :
  a # f -> a # f i.
Proof.
move => [S] [aNS S_supp_f].
exists S; split => // π H.
have πf_eq_f : π \dot f = f by apply/S_supp_f.
by rewrite -ffunactE πf_eq_f.
Qed.

Lemma fresh_perm (X : {nominalType atom}) (π : {finperm atom}) (x : X) :
  [disjoint (support x) & finsupp π] -> π \dot x = x.
Proof.
move => /fdisjointP disj_x_π.
apply act_id => a /disj_x_π.
exact: finsfun_dflt.
Qed.

Lemma tfinperm_fresh (a b c : atom) : a # c -> b # c -> swap a b c = c.
Proof.
move => aFc bFc.
apply/tfinpermNone/andP; split.
all: exact/fresh_atomP/fresh_atomC.
Qed.

Lemma disjoint_tfsupp a b S :
  a # S -> b # S -> [disjoint finsupp (swap a b) & S].
Proof.
move => aFS bFS. rewrite fdisjoint_sym.
by apply/tfinperm_disj; exact/fresh_fsetP.
Qed.

Lemma disjoint_conj (π π' : {finperm atom}) T :
  [disjoint finsupp π & T] -> [disjoint finsupp π' & T] ->
  [disjoint finsupp (π * π') & T].
Proof.
move => /fdisjointP disj_pi_T /fdisjointP disj_pi'_T.
apply/fdisjointP => a /(fsubsetP (finsupp_conj π' π) a).
by rewrite in_fsetU => /orP [?|?]; auto.
Qed.

Lemma disj_im_fresh (π : {finperm atom}) T x :
  [disjoint finsupp π & T] -> x # T -> π x # T.
Proof.
move => /fdisjointP disj_pi_T xFT.
have [/eqP ->|pix_neq_x] := boolP (π x == x) => //.
have : π (π x) != π x.
  apply/negP => /eqP/finperm_inj.
  by move: pix_neq_x => /eqP.
by rewrite -mem_finsupp => /disj_pi_T /fresh_fsetP.
Qed.

End Freshness.

Notation "a # x" := (fresh a x) (x at level 60, at level 60).

Ltac freshTac :=
  match goal with
    | |- (fresh_in ?x) # ?x => apply fresh1P
    | |- ?a # ?x =>
      try (subst a);
      match goal with
        | |- fresh_in ?y  # ?x => move : (fresh1P y)
      end;
      do ?[case/fresh_prod|move=> ?]
  end.

Ltac freshTacCtxt z :=
  match goal with
      | [ y := fresh_in ?x |- _] => match y with
        | z => move: (fresh1P x); rewrite -/z
                                    end
      | _ => fail "not a fresh variable"
  end;
  do ?[case/fresh_prod|move=> ?].

Ltac freshTacList :=
  match goal with
  | |- ?z # ?t  =>
    match goal with
      | [ H : is_true (t \in ?l) |- _] => apply (@fresh_list _ l) => //
    end
end.

(* fresh_dec (e : list { X : nominalType & X }) nom : is_fresh_dec x y -> is_fresh (fresh_in (interp e x)) (interp e y) *)
(* Hint Extern 0 (@is_fresh _ _ _) => eapply fresh_in_fresh : typeclass_instances. *)
(*Hint Mode is_fresh + - - : typeclass_instances.*)

Section EquivariantFunctions.

Implicit Types (W X Y Z: {nominalType atom}) (π : {finperm atom}).

Definition equivariant1 X Y (f : X -> Y) := forall π x, f (π \dot x) = π \dot (f x).

Definition equivariant2 X Y Z (f : X -> Y -> Z) :=
  forall π x y,  f (π \dot x) (π \dot y) = π \dot (f x y).

Definition equivariant3 X Y Z W (f :  X -> Y -> Z -> W) :=
  forall π x y z, f (π \dot x) (π \dot y) (π \dot z) = π \dot (f x y z).

Definition equivariant_prop X Y (R : X -> Y -> Prop) :=
  forall π x y, R (π \dot x) (π \dot y) <-> R x y.

Lemma all2_equivariant {A : {nominalType atom}} (s1 s2 : seq A) (p : A -> A -> bool) π :
  equivariant2 p ->
  all2 p (π \dot s1) (π \dot s2) = all2 p s1 s2.
Proof.
move => p_equi.
rewrite all2_map. apply all2_eq => x y.
exact/p_equi.
Qed.

Lemma map_equivariant {A B : {nominalType atom}} (f : A -> B) l π :
  (forall x, x \in l -> π \dot f x = f (π \dot x)) ->
   π \dot (map f l) = map f (π \dot l).
Proof.
move => f_equiv.
rewrite listactE -!map_comp.
apply/eq_in_map => t tl /=.
exact/f_equiv.
Qed.

Lemma if_equivariant {X : {nominalType atom}} (u v : X) b π :
  π \dot (if b then u else v) = if b then (π \dot u) else π \dot v.
Proof. by case: b. Qed.

Lemma equi_funprop X Y Z (f : X -> Y -> Z) (R : Z -> Z -> Prop) :
  equivariant2 f -> equivariant_prop R ->
  equivariant_prop (fun (x : X) (y : Y * Y) => R (f x y.1) (f x y.2)).
Proof.
move => equi_f equi_R π x; case => y y' /=.
by rewrite !equi_f equi_R.
Qed.

Lemma swap_equiv X :
  equivariant2 (fun (a : atom) (z : atom * X) => swap z.1 a \dot z.2).
Proof.
move => π a; case => b x /=. by rewrite -!actM tfinperm_conj.
Qed.

End EquivariantFunctions.

(* Section FinitelySupportedFunctions. *)

(* Implicit Types (V W X Y Z : nominalType atom) (π : {finperm atom}) (S : {fset atom}). *)

(* Definition fsupports1 {X Y} (f : X -> Y) S := *)
(*   forall a b x, (swap a b) \dot (f x) = f (swap a b \dot x). *)

(* Definition finitely_supported1 X Y (f : X -> Y) := *)
(*   exists S, fsupports1 f S. *)

(* Definition fsupports2 X Y Z (f : X -> Y -> Z) S := *)
(*    forall a b x y, swap a b \dot (f x y) = *)
(*                    f (swap a b \dot x) (swap a b \dot y). *)

(* Definition finitely_supported2 X Y Z (f : X -> Y -> Z) := *)
(*   exists S, fsupports2 f S. *)

(* Definition fsupports *)

(* Definition function_support *)

(* End FinitelySupportedFunctions. *)

(* Section StrongSupport. *)

(* Variables (X : nominalType) (S : {fset atom}). *)
(* Implicit Types (x : X). *)

(* (* (* hypothèse qui implique que S est le plus petit support de x *) *) *)
(* (* Hypothesis strong_support :  *) *)
(* (*   forall x π, π \dot x = x -> (forall a : atom, a \in (support x) -> π a == a). *) *)

(* (* Lemma equi_support : equivariant1 (@support X). *) *)
(* (* Proof. *) *)
(* (* move => π x. *) *)
(* (* wlog suff : x π / im π (support x) `<=` support (π \dot x). *) *)
(* (*   move => Hsuff; apply/eqP; rewrite eqEfsubset; apply/andP; split; last by apply Hsuff. *) *)
(* (*   rewrite -(actVK π (support (π \dot x))) -{2}[x](actK π x); *) *)
(* (*   exact/im_subset/Hsuff. *) *)
(* (* apply/fsubsetP => a /imfsetP [b bx] ->. apply contraT => πbNπx. *) *)
(* (* set c := fresh_in (val b, im π^-1 (support (π \dot x))). *) *)
(* (* have : swap (val b) c \dot x = x. *) *)
(* (*   apply (@act_inj _ π). rewrite -actM tfinperm_conj actM act_fresh //. *) *)
(* (*     exact: fresh_support πbNπx. *) *)
(* (*   exists (support (π \dot x)). *) *)
(* (*   split; last exact: supportsP. *) *)
(* (*   rewrite -(actVK π (support (π \dot x))) mem_im. *) *)
(* (*     by admit.   *) *)
(* (*   exact: finperm_inj. *) *)
(* (* have {bx} bx : val b \in support x. by apply valP. *) *)
(* (* move/strong_support => H. move: (H (val b) bx). *) *)
(* (* rewrite tfinpermL => /eqP cvalb.  *) *)
(* (* Admitted. *) *)

(* End StrongSupport. *)

Section SomeAny.

Implicit Type (X : {nominalType atom}).

Definition new (P : atom -> Prop) :=
  exists A : {fset atom}, forall a, a # A -> P a.

Notation "\new a , P" := (new (fun a : nat => P))
   (format "\new  a ,  P", at level 10).
Notation "a # x" := (fresh a x) (x at level 60, at level 60).

Theorem some_any X (R : atom -> X -> Prop) :
  equivariant_prop R ->
  forall x : X, [/\
      (forall a : atom , a # x -> R a x) -> (\new a, (R a x)),
      (\new a, (R a x)) ->  R (fresh_in (support x)) x,
      R (fresh_in (support x)) x -> (exists2 a, a # x & R a x) &
      (exists2 a, a # x & R a x)
      -> (forall a, a # x -> R a x)
    ].
Proof.
move => Requi; split.
  - exists (support x) => a /fresh_fsetP/fresh_support. exact: (H a).
  - move => [S aNSR].
    apply/(Requi (swap (fresh_in x) (fresh_in (x,S)))).
    rewrite swapL [_ \dot x]act_fresh; try (by freshTac).
    apply/aNSR. by freshTac.
  - move => Rfresh. exists (fresh_in x) => //. exact: fresh1P.
  - move => [a a_fresh_x rax] a' a'_fresh_x.
    rewrite -[a'](tfinpermL a a') -[x](@act_fresh _ a a') //.
    by apply/Requi.
Qed.

Lemma new_forall X (R : atom -> X -> Prop) :
  equivariant_prop R ->
  forall x : X, ((\new a, (R a x)) <-> (forall a, a # x -> R a x)).
Proof.
move=> Requi x. have [? ne ef] := some_any Requi x.
by split => // /ne /ef.
Qed.

Lemma new_exists X (R : atom -> X -> Prop) :
  equivariant_prop R ->
  forall x : X, ((\new a, (R a x)) <-> (exists2 a, a # x & R a x)).
Proof.
move=> Requi x; have [fn nf nh ef] := some_any Requi x.
by split => [/nf/nh|/ef].
Qed.

Lemma fresh_new X (R : atom -> X -> Prop) :
  equivariant_prop R ->
  forall x: X, R (fresh_in x) x <-> \new a, (R a x).
Proof.
move=> Requi x. have [fn nf nh ef] := some_any Requi x.
by split => [/nh/ef/fn | /nf].
Qed.

Lemma some_fresh_new X (R : atom -> X -> Prop) :
  equivariant_prop R ->
  forall (y : atom) (x : X), y # x -> (R y x) <-> \new a, (R a x).
Proof.
move => Requi y x yFx.
split => [Ryx|/(new_forall Requi) new_Rax].
  apply new_exists => //.
  by exists y.
exact/new_Rax.
Qed.

Lemma new_eq P1 P2 :
 (forall z, P1 z <-> P2 z) -> (\new z, (P1 z)) <-> (\new z, (P2 z)).
Proof.
move => P1_eq_P2.
split.
all: move => [S] HS; exists S => a aFS.
all: exact/P1_eq_P2/(HS _ aFS).
Qed.

Lemma new_all {Y : finType} (P : Y -> atom -> Prop) :
  \new z, (forall y, P y z) <-> forall y, \new z, (P y z).
Proof.
split.
  move => [S] HS y.
  exists S => a aFS.
  exact/HS.
move/fin_all_exists => [Supp] HSupp.
exists (\fbigcup_(y in Y) (Supp y)) => a aFSuppy y.
apply HSupp.
Admitted.

Lemma new_and P1 P2 :
  \new z, (P1 z /\ P2 z) <-> (\new z, (P1 z) /\ \new z, (P2 z)).
Proof.
split.
  move => [S] HS; split;
  exists S => a aFS.
    exact: (proj1 (HS _ aFS)).
  exact: (proj2 (HS _ aFS)).
move => [[S1] HS1 [S2] HS2].
exists (S1 `|` S2) => a aFS1S2; split.
  exact/(HS1 a)/(fresh_fsetU1 aFS1S2).
exact/(HS2 a)/(fresh_fsetU2 aFS1S2).
Qed.

Lemma new_andb P1 P2 :
  \new z, (P1 z && P2 z) <-> (\new z, (P1 z) /\ \new z, (P2 z)).
Proof.
have andb_eq_and : \new z, (P1 z && P2 z) <-> \new z, (P1 z /\ P2 z).
  apply new_eq; split => [/andP|? ] //; exact/andP.
split.
  move/andb_eq_and. by apply new_and.
move => ?. exact/andb_eq_and/new_and.
Qed.

Lemma new_all2 {A : eqType} {p : atom -> A -> A -> bool} {l1 l2 : seq A} :
  (\new z, (all2 (p z) l1 l2)) <-> (all2_prop (fun t1 t2 => \new z, (p z t1 t2)) l1 l2).
Proof.
elim: l1 l2 => /=.
  move => [|a l2]; split => //.
    by move => _; exists fset0 => //.
  by move => [S] /(_ _ (fresh1P S)).
move => a1 l1 IHl1 [|a2 l2].
  split => //. by move => [S] /(_ _ (fresh1P S)).
split.
  move/new_andb => [? ?]; split => //.
  by apply/IHl1.
move => [? ?]; apply/new_andb; split => //.
by apply/IHl1.
Qed.

End SomeAny.

Notation "\new a , P" := (new (fun a : nat => P))
   (format "\new  a ,  P", at level 10).
Notation "a # x" := (fresh a x) (x at level 60, at level 60).


Require Import Recdef.
Require Import NArith.
Require Import GeoCoq.Utils.sets.

Module SSPWP := WPropertiesOn SetOfSetsOfPairsOfPositiveOrderedType SSP.

Module SSPWEqP := WEqPropertiesOn SetOfSetsOfPairsOfPositiveOrderedType SSP.

Lemma proper_0 : Proper (SP.Equal ==> eq) (fun s => negb (SP.is_empty s)).
Proof.
intros x y Hxy.
f_equal.
apply SPWP.Dec.F.is_empty_m.
assumption.
Qed.

Lemma proper_1 : forall s1,
  Proper (SP.Equal ==> eq)
  (fun s2 : SSP.elt => negb (SP.is_empty (SP.inter s1 s2))).
Proof.
intros s1 x y HXY.
assert (HEqI : SP.Equal (SP.inter s1 x) (SP.inter s1 y))
  by (apply SPWP.inter_equal_2; assumption).
apply proper_0; auto.
Qed.

Definition exists_witness (f : SSP.elt -> bool) (s : SSP.t) : option SSP.elt :=
  SSP.choose (SSP.filter f s).

Lemma exists_witness_ok : forall e f s,
  Proper (SP.Equal ==> eq) f ->
  exists_witness f s = Some e -> SSP.In e s.
Proof.
intros e f s HP H.
unfold exists_witness in H.
apply SSPWEqP.MP.Dec.F.mem_2.
apply SSPWEqP.choose_mem_1 in H.
rewrite SSPWEqP.filter_mem in H; try assumption.
apply andb_true_iff in H.
induction H.
assumption.
Qed.

Definition pick_lengths_aux (s1 : SSP.elt) (ss : SSP.t) : (option (SSP.elt * SSP.elt)) :=
  match (exists_witness (fun s2 => negb (SP.is_empty (SP.inter s1 s2))) ss) with
    | None => None
    | Some s2 => Some(s1,s2)
  end.

Definition pick_lengths (ss : SSP.t) : (option (SSP.elt * SSP.elt)) :=
  match (exists_witness (fun s =>
                           match (pick_lengths_aux s (SSP.remove s ss)) with
                             | None => false
                             | _ => true
                           end) ss) with
    | None => None
    | Some s1 => pick_lengths_aux s1 (SSP.remove s1 ss)
  end.

Definition eqop (p1 p2 : option SSP.elt) :=
  match p1,p2 with
    | None, None => True
    | Some s1, Some s2 => True
    | _, _ => False
  end.

Lemma proper_2_aux : Proper (SSP.Equal ==> eqop) SSP.choose.
Proof.
intros x y H.
unfold eqop.
case_eq (SSP.choose x); case_eq (SSP.choose y).

  intuition.

  intros HCN e HCS.
  apply SSP.choose_spec1 in HCS.
  apply SSP.choose_spec2 in HCN.
  rewrite H in HCS.
  apply SSPWEqP.MP.empty_is_empty_1 in HCN.
  rewrite HCN in HCS.
  apply SSPWEqP.MP.Dec.F.empty_iff in HCS.
  assumption.

  intros e HCS HCN.
  apply SSP.choose_spec1 in HCS.
  apply SSP.choose_spec2 in HCN.
  rewrite H in HCN.
  apply SSPWEqP.MP.empty_is_empty_1 in HCN.
  rewrite HCN in HCS.
  apply SSPWEqP.MP.Dec.F.empty_iff in HCS.
  assumption.

  intuition.
Qed.

Lemma proper_2 : forall (f1 f2 : SSP.elt -> bool) (s1 s2 : SSP.t),
  Proper (SP.Equal ==> eq) f1 ->
  (forall x, f1 x = f2 x) ->
  SSP.Equal s1 s2 ->
  eqop (exists_witness f1 s1) (exists_witness f2 s2).
Proof.
intros.
apply proper_2_aux.
apply SSPWEqP.MP.Dec.F.filter_ext; assumption.
Qed.

Definition eqopp (p1 p2 : option (SSP.elt * SSP.elt)) :=
  match p1,p2 with
    | None, None => True
    | Some s1, Some s2 => True
    | _, _ => False
  end.

Lemma proper_3 : Proper (SP.Equal ==> SSP.Equal ==> eqopp) pick_lengths_aux.
Proof.
intros x1 y1 HXY1.
intros x2 y2 HXY2.
unfold pick_lengths_aux.
assert (H : eqop (exists_witness (fun s2 : SSP.elt => negb (SP.is_empty (SP.inter x1 s2))) x2)
             (exists_witness (fun s2 : SSP.elt => negb (SP.is_empty (SP.inter y1 s2))) y2)).

  apply proper_2.

    apply proper_1.

    intro; apply proper_0.

      apply SPWP.inter_equal_1; assumption.

      assumption.

case_eq (exists_witness (fun s2 : SSP.elt => negb (SP.is_empty (SP.inter y1 s2))) y2);
case_eq (exists_witness (fun s2 : SSP.elt => negb (SP.is_empty (SP.inter x1 s2))) x2).

  simpl; intuition.

  intros HCN e HCS.
  simpl.
  rewrite HCS in H; rewrite HCN in H.
  simpl in H.
  assumption.

  intros e HCS HCN.
  simpl.
  rewrite HCS in H; rewrite HCN in H.
  simpl in H.
  assumption.

  intuition.
Qed.

Lemma pick_lengths_ok_1 : forall s1 s2 ss,
  pick_lengths ss = Some(s1,s2) ->
  SSP.In s1 ss.
Proof.
intros s1 s2 ss H.
unfold pick_lengths in H.
case_eq (exists_witness (fun s : SSP.elt => match pick_lengths_aux s (SSP.remove s ss) with
                          | Some _ => true | None => false end) ss).

  intros e1 HEW1.
  rewrite HEW1 in H.
  unfold pick_lengths_aux in H.
  case_eq (exists_witness (fun s2 : SSP.elt => negb (SP.is_empty (SP.inter e1 s2))) (SSP.remove e1 ss)).

    intros e2 HEW2.
    rewrite HEW2 in H.
    assert (HEq1 : e1 = s1) by (injection H; intros; assumption).
    rewrite HEq1 in *.
    assert (HEq2 : e2 = s2) by (injection H; intros; assumption).
    rewrite HEq2 in *.
    eapply exists_witness_ok; [|exact HEW1].
    intros x y HXY.
    assert (SSP.Equal (SSP.remove x ss) (SSP.remove y ss))
      by (apply SSPWP.Dec.F.remove_m; try assumption; reflexivity).
    assert (eqopp (pick_lengths_aux x (SSP.remove x ss)) (pick_lengths_aux y (SSP.remove y ss))).
    apply proper_3; auto.
    case_eq (pick_lengths_aux x (SSP.remove x ss));
      intros;
      case_eq (pick_lengths_aux y (SSP.remove y ss));
      intros.

      reflexivity.

      rewrite H2 in H1; rewrite H3 in H1.
      unfold eqop in H1; simpl in H1.
      contradiction.

      rewrite H2 in H1; rewrite H3 in H1.
      unfold eqop in H1; simpl in H1.
      contradiction.

      reflexivity.

    intro HEW2.
    rewrite HEW2 in H.
    discriminate H.

  intro HEW.
  rewrite HEW in H.
  discriminate H.
Qed.

Lemma pick_lengths_ok_2 : forall s1 s2 ss,
  pick_lengths ss = Some(s1,s2) ->
  SSP.In s2 (SSP.remove s1 ss).
Proof.
intros s1 s2 ss H.
unfold pick_lengths in H.
case_eq (exists_witness (fun s : SSP.elt => match pick_lengths_aux s (SSP.remove s ss) with
                          | Some _ => true | None => false end) ss).

  intros e1 HEW1.
  rewrite HEW1 in H.
  unfold pick_lengths_aux in H.
  case_eq (exists_witness (fun s2 : SSP.elt => negb (SP.is_empty (SP.inter e1 s2))) (SSP.remove e1 ss)).

    intros e2 HEW2.
    rewrite HEW2 in H.
    assert (HEq1 : e1 = s1) by (injection H; intros; assumption).
    rewrite HEq1 in *.
    assert (HEq2 : e2 = s2) by (injection H; intros; assumption).
    rewrite HEq2 in *.
    apply exists_witness_ok with (fun s2 : SSP.elt => negb (SP.is_empty (SP.inter s1 s2))).
    apply proper_1.
    assumption.

    intro HEW2.
    rewrite HEW2 in H.
    discriminate H.

  intro HEW.
  rewrite HEW in H.
  discriminate H.
Qed.

Function identify_lengths (ss : SSP.t) {measure SSP.cardinal ss}
                        : SSP.t :=
  let lengths := pick_lengths ss in
    match lengths with
      |None => ss
      |Some (s1,s2) => let auxsetofsets := SSP.remove s2 (SSP.remove s1 ss) in
                       let auxset := SP.union s1 s2 in
                       let newss := SSP.add auxset auxsetofsets in
                         identify_lengths newss
    end.
Proof.
intros.
assert (S(SSP.cardinal (SSP.remove s1 ss)) = SSP.cardinal ss).
apply SSPWP.remove_cardinal_1.
apply pick_lengths_ok_1 with s2.
assumption.
assert (S(S(SSP.cardinal (SSP.remove s2 (SSP.remove s1 ss)))) = S(SSP.cardinal (SSP.remove s1 ss))).
apply eq_S.
apply SSPWP.remove_cardinal_1.
apply pick_lengths_ok_2.
assumption.
assert (HR1 : S(S(SSP.cardinal (SSP.remove s2 (SSP.remove s1 ss)))) = SSP.cardinal ss).
transitivity (S(SSP.cardinal (SSP.remove s1 ss))); assumption.
elim (SSPWP.In_dec (SP.union s1 s2) (SSP.remove s2 (SSP.remove s1 ss))); intro HDec.

  assert (HR2 : SSP.cardinal (SSP.add (SP.union s1 s2) (SSP.remove s2 (SSP.remove s1 ss))) = SSP.cardinal (SSP.remove s2 (SSP.remove s1 ss))).
  apply SSPWP.add_cardinal_1; assumption.
  rewrite HR2.
  rewrite <- HR1.
  apply le_S, le_n.

  assert (HR2 : SSP.cardinal (SSP.add (SP.union s1 s2) (SSP.remove s2 (SSP.remove s1 ss))) = S(SSP.cardinal (SSP.remove s2 (SSP.remove s1 ss)))).
  apply SSPWP.add_cardinal_2; assumption.
  rewrite HR2.
  rewrite <- HR1.
  apply le_n.
Defined.

Definition test_cong (ss : SSP.t) p1 p2 p3 p4 : bool :=
  let newss := identify_lengths ss in
    SSP.exists_ (fun s => SP.mem (p1,p2) s && SP.mem (p3,p4) s) newss.

Section Cong_refl.

Context `{CT:Cong_theory}.

Lemma CTcong_right_comm : forall A B C D, CTCong A B C D -> CTCong A B D C.
Proof.
intros.
apply CTcong_sym, CTcong_left_comm, CTcong_sym.
assumption.
Qed.

Lemma CTcong_comm : forall A B C D, CTCong A B C D -> CTCong B A D C.
Proof.
intros.
apply CTcong_left_comm, CTcong_right_comm.
assumption.
Qed.

Lemma CTcong_pseudo_refl : forall A B, CTCong A B B A.
Proof.
intros.
apply CTcong_left_comm, CTcong_refl.
Qed.

Definition ss_ok (ss : SSP.t) (interp: positive -> CONGpoint) :=
  forall s, SSP.mem s ss = true ->
  forall p1 p2 p3 p4, SP.mem (p1,p2) s && SP.mem (p3,p4) s = true ->
    CTCong (interp p1) (interp p2) (interp p3) (interp p4).

Lemma identify_lengths_ok : forall ss interp,
  ss_ok ss interp -> ss_ok (identify_lengths ss) interp.
Proof.
intros ss interp HSS.
apply (let P ss newss :=
       ss_ok ss interp -> ss_ok newss interp in
         identify_lengths_ind P); try assumption.

  intros.
  assumption.

  clear HSS ss.
  intros ss suitablepairofsets s1 s2 Hs1s2 auxsetofsets auxset newss H HSS.
  assert (Hs1 := Hs1s2).
  assert (Hs2 := Hs1s2).
  apply pick_lengths_ok_1 in Hs1.
  apply pick_lengths_ok_2 in Hs2.
  apply SSPWEqP.MP.Dec.F.remove_3 in Hs2.
  apply H; clear H.
  intros s Hmem p1 p2 p3 p4 Hmemp.
  unfold newss in Hmem; clear newss.
  elim (SSP.E.eq_dec auxset s); intro HEq.

    rewrite <- HEq in *; clear HEq Hmem s.
    unfold suitablepairofsets in Hs1s2; clear suitablepairofsets.
    unfold pick_lengths in Hs1s2.
    case_eq (exists_witness
            (fun s : SSP.elt =>
             match pick_lengths_aux s (SSP.remove s ss) with
             | Some _ => true
             | None => false
             end) ss); [|intro HEW; rewrite HEW in Hs1s2; discriminate Hs1s2].
    intros e1 HEW; rewrite HEW in *; clear HEW.
    unfold pick_lengths_aux in *.
    case_eq (exists_witness
            (fun s2 : SSP.elt => negb (SP.is_empty (SP.inter e1 s2)))
            (SSP.remove e1 ss)); [|intro HEW; rewrite HEW in Hs1s2; discriminate Hs1s2].
    intros e2 HEW; rewrite HEW in *.
    injection Hs1s2; intros He2s2 He1s1.
    rewrite He2s2, He1s1 in *; clear He2s2 He1s1 Hs1s2 e2 e1.
    apply SSP.choose_spec1, SSPWEqP.MP.Dec.F.filter_2 in HEW; [|apply proper_1].
    apply eq_sym, negb_sym, not_true_iff_false in HEW.
    rewrite SP.is_empty_spec, SPWP.cardinal_Empty in HEW.
    apply SPWP.cardinal_inv_2b in HEW.
    destruct HEW as [(e1,e2) He].
    apply SP.inter_spec in He.
    destruct He as [Hes1 Hes2].
    rewrite andb_true_iff in Hmemp.
    destruct Hmemp as [Hmemp1 Hmemp2].
    cut (forall p q, SP.mem (p, q) auxset = true ->
              CTCong (interp e1) (interp e2) (interp p) (interp q)).

      intro Haux.
      apply CTcong_trans with (interp e1) (interp e2); [apply CTcong_sym|]; apply Haux; assumption.

    intros p q Hmemp.
    apply SPWP.Dec.F.mem_2, SPWP.Dec.F.union_1 in Hmemp.
    rewrite SSPWP.Dec.F.mem_iff in *.
    rewrite 2 SPWP.Dec.F.mem_iff in *.
    destruct Hmemp; [apply (HSS s1 Hs1)|apply (HSS s2 Hs2)]; apply andb_true_iff; split; assumption.

    rewrite SSPWP.Dec.F.add_neq_b in Hmem; [|assumption].
    apply SSPWEqP.MP.Dec.F.mem_2 in Hmem.
    do 2 (apply SSPWEqP.MP.Dec.F.remove_3 in Hmem).
    apply SSPWEqP.MP.Dec.F.mem_1 in Hmem.
    apply (HSS s); assumption.
Qed.

Lemma test_cong_ok : forall ss interp p1 p2 p3 p4,
  ss_ok ss interp ->
  test_cong ss p1 p2 p3 p4 = true ->
  CTCong (interp p1) (interp p2) (interp p3) (interp p4).
Proof.
intros ss interp p1 p2 p3 p4 HSS HTC.
unfold test_cong in HTC.
assert (HSS2 : ss_ok (identify_lengths ss) interp)
  by (apply identify_lengths_ok; assumption).

unfold ss_ok in HSS2.
apply SSPWEqP.MP.Dec.F.exists_2 in HTC.
unfold SSP.Exists in HTC.
destruct HTC as [s [HIn Hmem]].
apply HSS2 with s.
apply SSPWEqP.MP.Dec.F.mem_1.
assumption.
assumption.

intros x y Hxy.
assert (HmemEq : forall p q, SP.mem (p,q) x = SP.mem (p,q) y)
  by (intros; apply SPWP.Dec.F.mem_m; [unfold Pos.eq|]; auto).
rewrite 2 HmemEq; reflexivity.
Qed.

Lemma ss_ok_empty : forall interp,
  ss_ok SSP.empty interp.
Proof.
intros interp ss Hmem1.
rewrite SSPWEqP.MP.Dec.F.empty_b in Hmem1.
discriminate.
Qed.

Lemma eq_le2__eq2 : forall p1 p2 p3 p4, Pos.le p1 p2 -> Pos.le p3 p4 ->
  (Pos.eq (fstpp (p1, p2)) (fstpp (p3, p4)) /\ Pos.eq (sndpp (p1, p2)) (sndpp (p3, p4))) ->
  (p1 = p3 /\ p2 = p4).
Proof.
intros p1 p2 p3 p4 Hle Hle'.
unfold fstpp, sndpp, Pos.eq.
rewrite 2 Pos.min_l; [rewrite 2 Pos.max_r|..]; trivial.
Qed.

Lemma eq_pseudo_refl : forall p q,
  Pos.eq (fstpp (p, q)) (fstpp (q, p)) /\ Pos.eq (sndpp (p, q)) (sndpp (q, p)).
Proof.
cut (forall p q, Pos.le p q ->
  Pos.eq (fstpp (p, q)) (fstpp (q, p)) /\ Pos.eq (sndpp (p, q)) (sndpp (q, p))).

  intros Haux p q.
  case_eq (Pos.leb p q); intro Hpq.

    apply Haux, Pos.leb_le, Hpq.

    apply SP.Raw.MX.eq_sym, Haux, Pos.lt_le_incl, Pos.leb_gt, Hpq.

intros p q Hle.
unfold fstpp, sndpp.
rewrite Pos.min_l; trivial.
rewrite Pos.min_r; trivial.
rewrite Pos.max_r; trivial.
rewrite Pos.max_l; trivial.
split; reflexivity.
Qed.

Lemma collect_congs :
  forall (A B C D : CONGpoint) (HCong : CTCong A B C D) pa pb pc pd ss (interp :  positive -> CONGpoint),
  interp pa = A ->
  interp pb = B ->
  interp pc = C ->
  interp pd = D ->
  ss_ok ss interp -> ss_ok (SSP.add (SP.add (pa,pb) (SP.add (pc,pd) SP.empty)) ss) interp.
Proof.
intros A B C D HCong pa pb pc pd ss interp HA HB HC HD HSS.
revert A B C D pa pb pc pd HA HB HC HD HCong.
cut (forall A B C D pa pb pc pd, interp pa = A -> interp pb = B -> interp pc = C -> interp pd = D ->
      CTCong A B C D -> Pos.le pa pb -> Pos.le pc pd ->
      ss_ok (SSP.add (SP.add (pa, pb) (SP.add (pc, pd) SP.empty)) ss) interp).

  intros Haux A B C D pa pb pc pd HA HB HC HD HCong.
  revert C D pc pd HC HD HCong.
  cut (forall C D pc pd, interp pc = C -> interp pd = D -> CTCong A B C D -> Pos.le pc pd ->
      ss_ok (SSP.add (SP.add (pa, pb) (SP.add (pc, pd) SP.empty)) ss) interp).

    intros Haux' C D pc pd HC HD HCong.
    case_eq (Pos.leb pc pd); intro Hpcpd.

      apply Pos.leb_le in Hpcpd.
      apply Haux' with C D; assumption.

      apply Pos.leb_gt, Pos.lt_le_incl in Hpcpd.
      assert (Heq : SP.Equal (SP.add (pc, pd) SP.empty) (SP.add (pd, pc) SP.empty))
        by (apply SPWP.Dec.F.add_m; [apply eq_pseudo_refl|apply SPWP.equal_refl]).
      intro s.
      rewrite Heq.
      apply Haux' with D C; trivial.
      apply CTcong_right_comm, HCong.

  intros C D pc pd HC HD HCong Hpcpd.
  case_eq (Pos.leb pa pb); intro Hpapb.

    apply Pos.leb_le in Hpapb.
    apply Haux with A B C D; assumption.

    apply Pos.leb_gt, Pos.lt_le_incl in Hpapb.
    assert (Heq : SP.Equal (SP.add (pa, pb) (SP.add (pc, pd) SP.empty))
                           (SP.add (pb, pa) (SP.add (pc, pd) SP.empty)))
      by (apply SPWP.Dec.F.add_m; [apply eq_pseudo_refl|apply SPWP.equal_refl]).
    intro s.
    rewrite Heq.
    apply Haux with B A C D; trivial.
    apply CTcong_left_comm, HCong.

intros A B C D pa pb pc pd HA HB HC HD HCong Hpapb Hpcpd s Hs.
cut (forall p1 p2 p3 p4, SP.mem (p1, p2) s && SP.mem (p3, p4) s = true ->
      Pos.le p1 p2 -> Pos.le p3 p4 -> CTCong (interp p1) (interp p2) (interp p3) (interp p4)).

  intros Haux p1 p2.
  cut (forall p3 p4, SP.mem (p1, p2) s && SP.mem (p3, p4) s = true ->
        Pos.le p3 p4 -> CTCong (interp p1) (interp p2) (interp p3) (interp p4)).

    intros Haux' p3 p4 Hmem.
    case_eq (Pos.leb p3 p4); intro Hp3p4.

      apply Pos.leb_le in Hp3p4.
      apply Haux'; assumption.

      apply Pos.leb_gt, Pos.lt_le_incl in Hp3p4.
      apply CTcong_right_comm, Haux'; trivial.
      assert (Heq : SP.mem (p4, p3) s = SP.mem (p3, p4) s)
        by (apply SPWP.Dec.F.mem_m; [apply eq_pseudo_refl|apply SPWP.equal_refl]).
      rewrite Heq.
      assumption.

  intros p3 p4 Hmem Hp3p4.
  case_eq (Pos.leb p1 p2); intro Hp1p2.

    apply Pos.leb_le in Hp1p2.
    apply Haux; assumption.

    apply Pos.leb_gt, Pos.lt_le_incl in Hp1p2.
    apply CTcong_left_comm, Haux; trivial.
    assert (Heq : SP.mem (p2, p1) s = SP.mem (p1, p2) s)
      by (apply SPWP.Dec.F.mem_m; [apply eq_pseudo_refl|apply SPWP.equal_refl]).
    rewrite Heq.
    assumption.

intros p1 p2 p3 p4 Hmem Hp1p2 Hp3p4.
elim (SPWP.Dec.F.eq_dec (p1,p2) (p3,p4)); intro Hp1p3.

  apply eq_le2__eq2 in Hp1p3; trivial.
  destruct Hp1p3.
  subst.
  apply CTcong_refl.

  apply SSPWEqP.MP.Dec.F.mem_2 in Hs.
  apply SSPWEqP.MP.Dec.F.add_iff in Hs.
  rewrite andb_true_iff in Hmem.
  destruct Hmem as [Hmem1 Hmem2].
  elim Hs; intro HsE.

    assert (HmemR : forall p q, SP.mem (p,q) (SP.add (pa, pb) (SP.add (pc, pd) SP.empty)) = SP.mem (p,q) s)
      by (intros; apply SPWP.Dec.F.mem_m; [unfold Pos.eq|]; auto).
    rewrite <- HmemR in Hmem1.
    rewrite <- HmemR in Hmem2.
    clear HmemR.
    elim (SPWP.Dec.F.eq_dec (pa,pb) (p1,p2)); intro Hpap1.

      apply eq_le2__eq2 in Hpap1; trivial.
      destruct Hpap1 as [Hpap1 Hpbp2].
      rewrite Hpap1, Hpbp2 in *.
      rewrite SPWP.Dec.F.add_neq_b in Hmem2; trivial.
      rewrite <- SPWP.singleton_equal_add in Hmem2.
      apply SPWP.Dec.F.mem_iff in Hmem2.
      apply SPWP.Dec.F.singleton_1 in Hmem2.
      apply eq_le2__eq2 in Hmem2; trivial.
      destruct Hmem2 as [Hpcp3 Hpdp4].
      rewrite Hpcp3, Hpdp4 in *; rewrite HA, HB, HC, HD.
      assumption.

    rewrite SPWP.Dec.F.add_neq_b in Hmem1; trivial.
    rewrite <- SPWP.singleton_equal_add in Hmem1.
    apply SPWP.Dec.F.mem_iff in Hmem1.
    apply SPWP.Dec.F.singleton_1 in Hmem1.
    apply eq_le2__eq2 in Hmem1; trivial.
    destruct Hmem1 as [Hpcp1 Hpdp2].
    rewrite Hpcp1, Hpdp2 in *.
    rewrite SPWP.add_add in Hmem2.
    rewrite SPWP.Dec.F.add_neq_b in Hmem2; trivial.
    rewrite <- SPWP.singleton_equal_add in Hmem2.
    apply SPWP.Dec.F.mem_iff in Hmem2.
    apply SPWP.Dec.F.singleton_1 in Hmem2.
    apply eq_le2__eq2 in Hmem2; trivial.
    destruct Hmem2 as [Hpap3 Hpbp4].
    rewrite Hpap3, Hpbp4 in *; rewrite HA, HB, HC, HD.
    apply CTcong_sym, HCong.

  apply HSS with s.
  apply SSPWEqP.MP.Dec.F.mem_1.
  assumption.
  rewrite Hmem1; rewrite Hmem2; reflexivity.
Qed.

Definition list_assoc_inv :=
  (fix list_assoc_inv_rec (A:Type) (B:Set)
                          (eq_dec:forall e1 e2:B, {e1 = e2} + {e1 <> e2})
                          (lst : list (prodT A B)) {struct lst} : B -> A -> A :=
  fun (key:B) (default:A) =>
    match lst with
      | nil => default
      | cons (pairT v e) l =>
        match eq_dec e key with
          | left _ => v
          | right _ => list_assoc_inv_rec A B eq_dec l key default
        end
    end).

Lemma positive_dec : forall (p1 p2:positive), {p1=p2}+{~p1=p2}.
Proof.
decide equality.
Defined.

Definition interp (lvar : list (CONGpoint * positive)) (Default : CONGpoint) : positive -> CONGpoint :=
  fun p => list_assoc_inv CONGpoint positive positive_dec lvar p Default.

End Cong_refl.


From cgraphs.locks.lambdalock Require Export langdef.

(* In this file we demonstrate how typed macros work. *)
(* We define a macro for let in terms of function application and lambda. *)

Definition Let x e1 e2 := App (Fun x e2) e1.

(* Check Let. *)
(* Check Fun. *)

(* We can now prove a typing rule for Let *)

Lemma Let_typed Γ Γ1 Γ1' Γ2 x e1 e2 t1 t2 :
  env_split Γ Γ1 Γ2 ->
  env_bind Γ1' x t1 Γ1 ->
  typed Γ1' e2 t2 ->
  typed Γ2  e1 t1 ->
  typed Γ (Let x e1 e2) t2.
Proof.
  intros Hs Hb H1 H2.
  unfold Let.
  eapply App_typed; eauto.
  eapply (Fun_typed _ _ _ _ _ _ Lin); eauto.
  intros [=].
Qed.

(* Check Let_typed. *)
(* Check Fun_typed. *)

(* We now have a lemma that lets us type check our Let construct using the
   usual typing rule for let. From the outside, this gives the same interface
   as if we had added Let as a primitive expression and added a typing rule
   to our language: *)

(*
Inductive typed : env -> expr -> type -> Prop :=
  | ...
  | Let_typed Γ Γ1 Γ1' Γ2 x e1 e2 t1 t2 :
    env_split Γ Γ1 Γ2 ->
    env_bind Γ1' x t1 Γ1 ->
    typed Γ1' e2 t2 ->
    typed Γ2  e1 t1 ->
    typed Γ (Let x e1 e2) t2
  | ...
*)


(** Bug #2281

In the code below, coq is confused by an equality unless it is first 'subst'ed
away, yet http://coq.inria.fr/stdlib/Coq.FSets.FSetDecide.html says

    fsetdec will first perform any necessary zeta and beta reductions and will
invoke subst to eliminate any Coq equalities between finite sets or their
elements.

I have coq r12851.

*)

Require Import Arith.
Require Import FSets.
Require Import FSetWeakList.

Module DecidableNat.
Definition t := nat.
Definition eq := @eq nat.
Definition eq_refl := @refl_equal nat.
Definition eq_sym := @sym_eq nat.
Definition eq_trans := @trans_eq nat.
Definition eq_dec := eq_nat_dec.
End DecidableNat.

Module NatSet := Make(DecidableNat).

Module Export NameSetDec := WDecide (NatSet).

Lemma ThisLemmaWorks : forall ( s1 s2 : NatSet.t )
                              ( H : s1 = s2 ),
                       NatSet.Equal s1 s2.
Proof.
intros.
subst.
fsetdec.
Qed.

Import FSetDecideAuxiliary.

Lemma ThisLemmaWasFailing : forall ( s1 s2 : NatSet.t )
                              ( H : s1 = s2 ),
                       NatSet.Equal s1 s2.
Proof.
intros.
fsetdec.
(* Error: Tactic failure: because the goal is beyond the scope of this tactic.
*)
Qed.


(* 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 Lesser 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                                                     *)

(**********************************************************************
    Proof of Huffman algorithm: PBTree2BTree.v

    Definition of translation from partial trees to binary trees

    Definition: to_btree

                                    Laurent.Thery@inria.fr (2003)
 **********************************************************************)

From Huffman Require Export Aux.
From Huffman Require Export Code.
From Huffman Require Export Build.
From Huffman Require Export ISort.
Require Export Compare_dec.
From Huffman Require Export Permutation.
From Huffman Require Export UniqueKey.
From Huffman Require Export PBTree.
From Huffman Require Export BTree.

Section PBTREE2BTREE.
Variable A : Type.
Variable eqA_dec : forall a b : A, {a = b} + {a <> b}.
Variable empty : A.

(* Turn a partial tree into a binary tree *)
Fixpoint to_btree (a : pbtree A) : btree A :=
  match a with
  | pbleaf b => leaf b
  | pbleft l1 => to_btree l1
  | pbright l1 => to_btree l1
  | pbnode l1 l2 => node (to_btree l1) (to_btree l2)
  end.

(* Computing the binary tree preserves the leaves*)
Theorem to_btree_inb :
 forall a b, inpb (pbleaf a) b -> inb (leaf a) (to_btree b).
Proof using.
intros a b; generalize a; elim b; clear a b; simpl in |- *; auto.
intros a a0 H; inversion H; auto.
intros p H a H0; apply H; auto; inversion H0; auto.
intros p H a H0; apply H; auto; inversion H0; auto.
intros p H p0 H0 a H1; inversion H1; auto.
Qed.

(* Leaves do not change *)
Theorem to_btree_inpb :
 forall a b, inb (leaf a) (to_btree b) -> inpb (pbleaf a) b.
Proof using.
intros a b; generalize a; elim b; clear a b; simpl in |- *; auto.
intros a a0 H; inversion H; auto.
intros p H p0 H0 a H1.
inversion H1; auto.
Qed.

(* The list of all leaves does not change *)
Theorem to_btree_all_leaves :
 forall t, all_leaves (to_btree t) = all_pbleaves t.
Proof using.
intros t; elim t; simpl in |- *; auto.
intros p H p0 H0; apply f_equal2 with (f := app (A:=A)); auto.
Qed.

(* Computing the btree preserves the property of having distinct leaves *)
Theorem to_btree_distinct_leaves :
 forall a : pbtree A, distinct_pbleaves a -> distinct_leaves (to_btree a).
Proof using.
intros a H.
apply all_leaves_unique.
rewrite to_btree_all_leaves.
apply all_pbleaves_ulist; auto.
Qed.

(* The transformation perserves distinct leaves *)
Theorem to_btree_distinct_pbleaves :
 forall a : pbtree A, distinct_leaves (to_btree a) -> distinct_pbleaves a.
Proof using.
intros a H.
apply all_pbleaves_unique.
rewrite <- to_btree_all_leaves.
apply all_leaves_ulist; auto.
Qed.

(* For each key, the resulting code of the computed tree is always smaller *)
Theorem to_btree_smaller :
 forall t a,
 length (find_code eqA_dec a (compute_code (to_btree t))) <=
 length (find_code eqA_dec a (compute_pbcode t)).
Proof using.
intros t; elim t; simpl in |- *; auto.
intros p H a.
apply le_trans with (1 := H a); auto.
case (inpb_dec eqA_dec (pbleaf a) p); intros H1.
case inpb_compute_ex with (1 := H1).
intros x Hx; rewrite in_find_map with (l := x); simpl in |- *; auto.
rewrite not_in_find_map; simpl in |- *; auto.
rewrite not_in_find_code; simpl in |- *; auto.
intros p1; Contradict H1; auto.
apply in_pbcompute_inpb with (1 := H1).
intros p1; Contradict H1; auto.
apply in_pbcompute_inpb with (1 := H1).
intros p H a.
apply le_trans with (1 := H a); auto.
case (inpb_dec eqA_dec (pbleaf a) p); intros H1.
case inpb_compute_ex with (1 := H1).
intros x Hx; rewrite in_find_map with (l := x); simpl in |- *; auto.
rewrite not_in_find_map; simpl in |- *; auto.
rewrite not_in_find_code; simpl in |- *; auto.
intros p1; Contradict H1; auto.
apply in_pbcompute_inpb with (1 := H1).
intros p1; Contradict H1; auto.
apply in_pbcompute_inpb with (1 := H1).
intros p H p0 H0 a.
simpl in |- *; repeat rewrite find_code_app; auto.
case (inpb_dec eqA_dec (pbleaf a) p); intros H1.
case inpb_compute_ex with (1 := H1).
intros x Hx; repeat rewrite in_find_map with (1 := Hx); simpl in |- *;
 auto with arith.
case inb_compute_ex with (a := a) (p := to_btree p); auto.
apply to_btree_inb; auto.
intros x1 Hx1; repeat rewrite in_find_map with (1 := Hx1); simpl in |- *;
 auto with arith.
rewrite not_in_find_map with (p := compute_code (to_btree p)); simpl in |- *;
 auto with arith.
rewrite not_in_find_map with (p := compute_pbcode p); simpl in |- *;
 auto with arith.
case (inpb_dec eqA_dec (pbleaf a) p0); intros H2.
case inpb_compute_ex with (1 := H2).
intros x Hx; repeat rewrite in_find_map with (1 := Hx); simpl in |- *;
 auto with arith.
case inb_compute_ex with (a := a) (p := to_btree p0); auto.
apply to_btree_inb; auto.
intros x1 Hx1; repeat rewrite in_find_map with (1 := Hx1); simpl in |- *;
 auto with arith.
rewrite not_in_find_map with (p := compute_pbcode p0); simpl in |- *;
 auto with arith.
rewrite not_in_find_map with (p := compute_code (to_btree p0)); simpl in |- *;
 auto with arith.
intros l; Contradict H2; apply to_btree_inpb;
 apply inCompute_inb with (1 := H2); auto.
intros l; Contradict H2; apply in_pbcompute_inpb with (1 := H2).
intros l; Contradict H1; apply in_pbcompute_inpb with (1 := H1).
intros l; Contradict H1; apply to_btree_inpb;
 apply inCompute_inb with (1 := H1); auto.
Qed.

End PBTREE2BTREE.
Arguments to_btree [A].


(* -*- coding: utf-8 -*- *)
(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)

(** * Euclidean Division *)

(** Initial Contribution by Claude Marché and Xavier Urbain *)

Require Export ZArith_base.
Require Import Zbool Omega ZArithRing Zcomplements Setoid Morphisms.
Local Open Scope Z_scope.

(** The definition of the division is now in [BinIntDef], the initial
    specifications and properties are in [BinInt]. *)

Notation Zdiv_eucl_POS := Z.pos_div_eucl (only parsing).
Notation Zdiv_eucl := Z.div_eucl (compat "8.6").
Notation Zdiv := Z.div (compat "8.6").
Notation Zmod := Z.modulo (only parsing).

Notation Zdiv_eucl_eq := Z.div_eucl_eq (compat "8.6").
Notation Z_div_mod_eq_full := Z.div_mod (only parsing).
Notation Zmod_POS_bound := Z.pos_div_eucl_bound (only parsing).
Notation Zmod_pos_bound := Z.mod_pos_bound (only parsing).
Notation Zmod_neg_bound := Z.mod_neg_bound (only parsing).

(** * Main division theorems *)

(** NB: many things are stated twice for compatibility reasons *)

Lemma Z_div_mod_POS :
  forall b:Z,
    b > 0 ->
    forall a:positive,
      let (q, r) := Z.pos_div_eucl a b in Zpos a = b * q + r /\ 0 <= r < b.
Proof.
 intros b Hb a. Z.swap_greater.
 generalize (Z.pos_div_eucl_eq a b Hb) (Z.pos_div_eucl_bound a b Hb).
 destruct Z.pos_div_eucl. rewrite Z.mul_comm. auto.
Qed.

Theorem Z_div_mod a b :
  b > 0 ->
  let (q, r) := Z.div_eucl a b in a = b * q + r /\ 0 <= r < b.
Proof.
 Z.swap_greater. intros Hb.
 assert (Hb' : b<>0) by (now destruct b).
 generalize (Z.div_eucl_eq a b Hb') (Z.mod_pos_bound a b Hb).
 unfold Z.modulo. destruct Z.div_eucl. auto.
Qed.

(** For stating the fully general result, let's give a short name
    to the condition on the remainder. *)

Definition Remainder r b :=  0 <= r < b \/ b < r <= 0.

(** Another equivalent formulation: *)

Definition Remainder_alt r b :=  Z.abs r < Z.abs b /\ Z.sgn r <> - Z.sgn b.

(* In the last formulation, [ Z.sgn r <> - Z.sgn b ] is less nice than saying
    [ Z.sgn r = Z.sgn b ], but at least it works even when [r] is null. *)

Lemma Remainder_equiv : forall r b, Remainder r b <-> Remainder_alt r b.
Proof.
 intros; unfold Remainder, Remainder_alt; omega with *.
Qed.

Hint Unfold Remainder.

(** Now comes the fully general result about Euclidean division. *)

Theorem Z_div_mod_full a b :
  b <> 0 ->
  let (q, r) := Z.div_eucl a b in a = b * q + r /\ Remainder r b.
Proof.
 intros Hb.
 generalize (Z.div_eucl_eq a b Hb)
  (Z.mod_pos_bound a b) (Z.mod_neg_bound a b).
 unfold Z.modulo. destruct Z.div_eucl as (q,r).
 intros EQ POS NEG.
 split; auto.
 red; destruct b.
  now destruct Hb. left; now apply POS. right; now apply NEG.
Qed.

(** The same results as before, stated separately in terms of Z.div and Z.modulo *)

Lemma Z_mod_remainder a b : b<>0 -> Remainder (a mod b) b.
Proof.
  unfold Z.modulo; intros Hb; generalize (Z_div_mod_full a b Hb); auto.
  destruct Z.div_eucl; tauto.
Qed.

Lemma Z_mod_lt a b : b > 0 -> 0 <= a mod b < b.
Proof (fun Hb => Z.mod_pos_bound a b (Z.gt_lt _ _ Hb)).

Lemma Z_mod_neg a b : b < 0 -> b < a mod b <= 0.
Proof (Z.mod_neg_bound a b).

Lemma Z_div_mod_eq a b : b > 0 -> a = b*(a/b) + (a mod b).
Proof.
  intros Hb; apply Z.div_mod; auto with zarith.
Qed.

Lemma Zmod_eq_full a b : b<>0 -> a mod b = a - (a/b)*b.
Proof. intros. rewrite Z.mul_comm. now apply Z.mod_eq. Qed.

Lemma Zmod_eq a b : b>0 -> a mod b = a - (a/b)*b.
Proof. intros. apply Zmod_eq_full. now destruct b. Qed.

(** Existence theorem *)

Theorem Zdiv_eucl_exist : forall (b:Z)(Hb:b>0)(a:Z),
 {qr : Z * Z | let (q, r) := qr in a = b * q + r /\ 0 <= r < b}.
Proof.
  intros b Hb a.
  exists (Z.div_eucl a b).
  exact (Z_div_mod a b Hb).
Qed.

Arguments Zdiv_eucl_exist : default implicits.

(** Uniqueness theorems *)

Theorem Zdiv_mod_unique b q1 q2 r1 r2 :
  0 <= r1 < Z.abs b -> 0 <= r2 < Z.abs b ->
  b*q1+r1 = b*q2+r2 -> q1=q2 /\ r1=r2.
Proof.
intros Hr1 Hr2 H. rewrite <- (Z.abs_sgn b), <- !Z.mul_assoc in H.
destruct (Z.div_mod_unique (Z.abs b) (Z.sgn b * q1) (Z.sgn b * q2) r1 r2); auto.
split; trivial.
apply Z.mul_cancel_l with (Z.sgn b); trivial.
rewrite Z.sgn_null_iff, <- Z.abs_0_iff. destruct Hr1; Z.order.
Qed.

Theorem Zdiv_mod_unique_2 :
 forall b q1 q2 r1 r2:Z,
  Remainder r1 b -> Remainder r2 b ->
  b*q1+r1 = b*q2+r2 -> q1=q2 /\ r1=r2.
Proof Z.div_mod_unique.

Theorem Zdiv_unique_full:
 forall a b q r, Remainder r b ->
   a = b*q + r -> q = a/b.
Proof Z.div_unique.

Theorem Zdiv_unique:
 forall a b q r, 0 <= r < b ->
   a = b*q + r -> q = a/b.
Proof. intros; eapply Zdiv_unique_full; eauto. Qed.

Theorem Zmod_unique_full:
 forall a b q r, Remainder r b ->
  a = b*q + r ->  r = a mod b.
Proof Z.mod_unique.

Theorem Zmod_unique:
 forall a b q r, 0 <= r < b ->
  a = b*q + r -> r = a mod b.
Proof. intros; eapply Zmod_unique_full; eauto. Qed.

(** * Basic values of divisions and modulo. *)

Lemma Zmod_0_l: forall a, 0 mod a = 0.
Proof.
  destruct a; simpl; auto.
Qed.

Lemma Zmod_0_r: forall a, a mod 0 = 0.
Proof.
  destruct a; simpl; auto.
Qed.

Lemma Zdiv_0_l: forall a, 0/a = 0.
Proof.
  destruct a; simpl; auto.
Qed.

Lemma Zdiv_0_r: forall a, a/0 = 0.
Proof.
  destruct a; simpl; auto.
Qed.

Ltac zero_or_not a :=
  destruct (Z.eq_dec a 0);
  [subst; rewrite ?Zmod_0_l, ?Zdiv_0_l, ?Zmod_0_r, ?Zdiv_0_r;
   auto with zarith|].

Lemma Zmod_1_r: forall a, a mod 1 = 0.
Proof. intros. zero_or_not a. apply Z.mod_1_r. Qed.

Lemma Zdiv_1_r: forall a, a/1 = a.
Proof. intros. zero_or_not a. apply Z.div_1_r. Qed.

Hint Resolve Zmod_0_l Zmod_0_r Zdiv_0_l Zdiv_0_r Zdiv_1_r Zmod_1_r
 : zarith.

Lemma Zdiv_1_l: forall a, 1 < a -> 1/a = 0.
Proof Z.div_1_l.

Lemma Zmod_1_l: forall a, 1 < a ->  1 mod a = 1.
Proof Z.mod_1_l.

Lemma Z_div_same_full : forall a:Z, a<>0 -> a/a = 1.
Proof Z.div_same.

Lemma Z_mod_same_full : forall a, a mod a = 0.
Proof. intros. zero_or_not a. apply Z.mod_same; auto. Qed.

Lemma Z_mod_mult : forall a b, (a*b) mod b = 0.
Proof. intros. zero_or_not b. apply Z.mod_mul. auto. Qed.

Lemma Z_div_mult_full : forall a b:Z, b <> 0 -> (a*b)/b = a.
Proof Z.div_mul.

(** * Order results about Z.modulo and Z.div *)

(* Division of positive numbers is positive. *)

Lemma Z_div_pos: forall a b, b > 0 -> 0 <= a -> 0 <= a/b.
Proof. intros. apply Z.div_pos; auto with zarith. Qed.

Lemma Z_div_ge0: forall a b, b > 0 -> a >= 0 -> a/b >=0.
Proof.
  intros; generalize (Z_div_pos a b H); auto with zarith.
Qed.

(** As soon as the divisor is greater or equal than 2,
    the division is strictly decreasing. *)

Lemma Z_div_lt : forall a b:Z, b >= 2 -> a > 0 -> a/b < a.
Proof. intros. apply Z.div_lt; auto with zarith. Qed.

(** A division of a small number by a bigger one yields zero. *)

Theorem Zdiv_small: forall a b, 0 <= a < b -> a/b = 0.
Proof Z.div_small.

(** Same situation, in term of modulo: *)

Theorem Zmod_small: forall a n, 0 <= a < n -> a mod n = a.
Proof Z.mod_small.

(** [Z.ge] is compatible with a positive division. *)

Lemma Z_div_ge : forall a b c:Z, c > 0 -> a >= b -> a/c >= b/c.
Proof. intros. apply Z.le_ge. apply Z.div_le_mono; auto with zarith. Qed.

(** Same, with [Z.le]. *)

Lemma Z_div_le : forall a b c:Z, c > 0 -> a <= b -> a/c <= b/c.
Proof. intros. apply Z.div_le_mono; auto with zarith. Qed.

(** With our choice of division, rounding of (a/b) is always done toward bottom: *)

Lemma Z_mult_div_ge : forall a b:Z, b > 0 -> b*(a/b) <= a.
Proof. intros. apply Z.mul_div_le; auto with zarith. Qed.

Lemma Z_mult_div_ge_neg : forall a b:Z, b < 0 -> b*(a/b) >= a.
Proof. intros. apply Z.le_ge. apply Z.mul_div_ge; auto with zarith. Qed.

(** The previous inequalities are exact iff the modulo is zero. *)

Lemma Z_div_exact_full_1 : forall a b:Z, a = b*(a/b) -> a mod b = 0.
Proof. intros a b. zero_or_not b. rewrite Z.div_exact; auto. Qed.

Lemma Z_div_exact_full_2 : forall a b:Z, b <> 0 -> a mod b = 0 -> a = b*(a/b).
Proof. intros; rewrite Z.div_exact; auto. Qed.

(** A modulo cannot grow beyond its starting point. *)

Theorem Zmod_le: forall a b, 0 < b -> 0 <= a -> a mod b <= a.
Proof. intros. apply Z.mod_le; auto. Qed.

(** Some additional inequalities about Z.div. *)

Theorem Zdiv_lt_upper_bound:
  forall a b q, 0 < b -> a < q*b -> a/b < q.
Proof. intros a b q; rewrite Z.mul_comm; apply Z.div_lt_upper_bound. Qed.

Theorem Zdiv_le_upper_bound:
  forall a b q, 0 < b -> a <= q*b -> a/b <= q.
Proof. intros a b q; rewrite Z.mul_comm; apply Z.div_le_upper_bound. Qed.

Theorem Zdiv_le_lower_bound:
  forall a b q, 0 < b -> q*b <= a -> q <= a/b.
Proof. intros a b q; rewrite Z.mul_comm; apply Z.div_le_lower_bound. Qed.

(** A division of respect opposite monotonicity for the divisor *)

Lemma Zdiv_le_compat_l: forall p q r, 0 <= p -> 0 < q < r ->
    p / r <= p / q.
Proof. intros; apply Z.div_le_compat_l; auto with zarith. Qed.

Theorem Zdiv_sgn: forall a b,
  0 <= Z.sgn (a/b) * Z.sgn a * Z.sgn b.
Proof.
  destruct a as [ |a|a]; destruct b as [ |b|b]; simpl; auto with zarith;
  generalize (Z.div_pos (Zpos a) (Zpos b)); unfold Z.div, Z.div_eucl;
  destruct Z.pos_div_eucl as (q,r); destruct r; omega with *.
Qed.

(** * Relations between usual operations and Z.modulo and Z.div *)

Lemma Z_mod_plus_full : forall a b c:Z, (a + b * c) mod c = a mod c.
Proof. intros. zero_or_not c. apply Z.mod_add; auto. Qed.

Lemma Z_div_plus_full : forall a b c:Z, c <> 0 -> (a + b * c) / c = a / c + b.
Proof Z.div_add.

Theorem Z_div_plus_full_l: forall a b c : Z, b <> 0 -> (a * b + c) / b = a + c / b.
Proof Z.div_add_l.

(** [Z.opp] and [Z.div], [Z.modulo].
    Due to the choice of convention for our Euclidean division,
    some of the relations about [Z.opp] and divisions are rather complex. *)

Lemma Zdiv_opp_opp : forall a b:Z, (-a)/(-b) = a/b.
Proof. intros. zero_or_not b. apply Z.div_opp_opp; auto. Qed.

Lemma Zmod_opp_opp : forall a b:Z, (-a) mod (-b) = - (a mod b).
Proof. intros. zero_or_not b. apply Z.mod_opp_opp; auto. Qed.

Lemma Z_mod_zero_opp_full : forall a b:Z, a mod b = 0 -> (-a) mod b = 0.
Proof. intros. zero_or_not b. apply Z.mod_opp_l_z; auto. Qed.

Lemma Z_mod_nz_opp_full : forall a b:Z, a mod b <> 0 ->
 (-a) mod b = b - (a mod b).
Proof. intros. zero_or_not b. apply Z.mod_opp_l_nz; auto. Qed.

Lemma Z_mod_zero_opp_r : forall a b:Z, a mod b = 0 -> a mod (-b) = 0.
Proof. intros. zero_or_not b. apply Z.mod_opp_r_z; auto. Qed.

Lemma Z_mod_nz_opp_r : forall a b:Z, a mod b <> 0 ->
 a mod (-b) = (a mod b) - b.
Proof. intros. zero_or_not b. apply Z.mod_opp_r_nz; auto. Qed.

Lemma Z_div_zero_opp_full : forall a b:Z, a mod b = 0 -> (-a)/b = -(a/b).
Proof. intros. zero_or_not b. apply Z.div_opp_l_z; auto. Qed.

Lemma Z_div_nz_opp_full : forall a b:Z, a mod b <> 0 ->
 (-a)/b = -(a/b)-1.
Proof. intros a b. zero_or_not b. intros; rewrite Z.div_opp_l_nz; auto. Qed.

Lemma Z_div_zero_opp_r : forall a b:Z, a mod b = 0 -> a/(-b) = -(a/b).
Proof. intros. zero_or_not b. apply Z.div_opp_r_z; auto. Qed.

Lemma Z_div_nz_opp_r : forall a b:Z, a mod b <> 0 ->
 a/(-b) = -(a/b)-1.
Proof. intros a b. zero_or_not b. intros; rewrite Z.div_opp_r_nz; auto. Qed.

(** Cancellations. *)

Lemma  Zdiv_mult_cancel_r : forall a b c:Z,
 c <> 0 -> (a*c)/(b*c) = a/b.
Proof. intros. zero_or_not b. apply Z.div_mul_cancel_r; auto. Qed.

Lemma Zdiv_mult_cancel_l : forall a b c:Z,
 c<>0 -> (c*a)/(c*b) = a/b.
Proof.
 intros. rewrite (Z.mul_comm c b); zero_or_not b.
 rewrite (Z.mul_comm b c). apply Z.div_mul_cancel_l; auto.
Qed.

Lemma Zmult_mod_distr_l: forall a b c,
  (c*a) mod (c*b) = c * (a mod b).
Proof.
 intros. zero_or_not c. rewrite (Z.mul_comm c b); zero_or_not b.
 rewrite (Z.mul_comm b c). apply Z.mul_mod_distr_l; auto.
Qed.

Lemma Zmult_mod_distr_r: forall a b c,
  (a*c) mod (b*c) = (a mod b) * c.
Proof.
 intros. zero_or_not b. rewrite (Z.mul_comm b c); zero_or_not c.
 rewrite (Z.mul_comm c b). apply Z.mul_mod_distr_r; auto.
Qed.

(** Operations modulo. *)

Theorem Zmod_mod: forall a n, (a mod n) mod n = a mod n.
Proof. intros. zero_or_not n. apply Z.mod_mod; auto. Qed.

Theorem Zmult_mod: forall a b n,
 (a * b) mod n = ((a mod n) * (b mod n)) mod n.
Proof. intros. zero_or_not n. apply Z.mul_mod; auto. Qed.

Theorem Zplus_mod: forall a b n,
 (a + b) mod n = (a mod n + b mod n) mod n.
Proof. intros. zero_or_not n. apply Z.add_mod; auto. Qed.

Theorem Zminus_mod: forall a b n,
 (a - b) mod n = (a mod n - b mod n) mod n.
Proof.
  intros.
  replace (a - b) with (a + (-1) * b); auto with zarith.
  replace (a mod n - b mod n) with (a mod n + (-1) * (b mod n)); auto with zarith.
  rewrite Zplus_mod.
  rewrite Zmult_mod.
  rewrite Zplus_mod with (b:=(-1) * (b mod n)).
  rewrite Zmult_mod.
  rewrite Zmult_mod with (b:= b mod n).
  repeat rewrite Zmod_mod; auto.
Qed.

Lemma Zplus_mod_idemp_l: forall a b n, (a mod n + b) mod n = (a + b) mod n.
Proof.
  intros; rewrite Zplus_mod, Zmod_mod, <- Zplus_mod; auto.
Qed.

Lemma Zplus_mod_idemp_r: forall a b n, (b + a mod n) mod n = (b + a) mod n.
Proof.
  intros; rewrite Zplus_mod, Zmod_mod, <- Zplus_mod; auto.
Qed.

Lemma Zminus_mod_idemp_l: forall a b n, (a mod n - b) mod n = (a - b) mod n.
Proof.
  intros; rewrite Zminus_mod, Zmod_mod, <- Zminus_mod; auto.
Qed.

Lemma Zminus_mod_idemp_r: forall a b n, (a - b mod n) mod n = (a - b) mod n.
Proof.
  intros; rewrite Zminus_mod, Zmod_mod, <- Zminus_mod; auto.
Qed.

Lemma Zmult_mod_idemp_l: forall a b n, (a mod n * b) mod n = (a * b) mod n.
Proof.
  intros; rewrite Zmult_mod, Zmod_mod, <- Zmult_mod; auto.
Qed.

Lemma Zmult_mod_idemp_r: forall a b n, (b * (a mod n)) mod n = (b * a) mod n.
Proof.
  intros; rewrite Zmult_mod, Zmod_mod, <- Zmult_mod; auto.
Qed.

(** For a specific number N, equality modulo N is hence a nice setoid
   equivalence, compatible with [+], [-] and [*]. *)

Section EqualityModulo.
Variable N:Z.

Definition eqm a b := (a mod N = b mod N).
Infix "==" := eqm (at level 70).

Lemma eqm_refl : forall a, a == a.
Proof. unfold eqm; auto. Qed.

Lemma eqm_sym : forall a b, a == b -> b == a.
Proof. unfold eqm; auto. Qed.

Lemma eqm_trans : forall a b c,
  a == b -> b == c -> a == c.
Proof. unfold eqm; eauto with *. Qed.

Instance eqm_setoid : Equivalence eqm.
Proof.
 constructor; [exact eqm_refl | exact eqm_sym | exact eqm_trans].
Qed.

Instance Zplus_eqm : Proper (eqm ==> eqm ==> eqm) Z.add.
Proof.
  unfold eqm; repeat red; intros. rewrite Zplus_mod, H, H0, <- Zplus_mod; auto.
Qed.

Instance Zminus_eqm : Proper (eqm ==> eqm ==> eqm) Z.sub.
Proof.
  unfold eqm; repeat red; intros. rewrite Zminus_mod, H, H0, <- Zminus_mod; auto.
Qed.

Instance Zmult_eqm : Proper (eqm ==> eqm ==> eqm) Z.mul.
Proof.
  unfold eqm; repeat red; intros. rewrite Zmult_mod, H, H0, <- Zmult_mod; auto.
Qed.

Instance Zopp_eqm : Proper (eqm ==> eqm) Z.opp.
Proof.
  intros x y H. change ((-x)==(-y)) with ((0-x)==(0-y)). now rewrite H.
Qed.

Lemma Zmod_eqm : forall a, (a mod N) == a.
Proof.
  intros; exact (Zmod_mod a N).
Qed.

(* NB: Z.modulo and Z.div are not morphisms with respect to eqm.
    For instance, let (==) be (eqm 2). Then we have (3 == 1) but:
    ~ (3 mod 3 == 1 mod 3)
    ~ (1 mod 3 == 1 mod 1)
    ~ (3/3 == 1/3)
    ~ (1/3 == 1/1)
*)

End EqualityModulo.

Lemma Zdiv_Zdiv : forall a b c, 0<=b -> 0<=c -> (a/b)/c = a/(b*c).
Proof.
 intros. zero_or_not b. rewrite Z.mul_comm. zero_or_not c.
 rewrite Z.mul_comm. apply Z.div_div; auto with zarith.
Qed.

(** Unfortunately, the previous result isn't always true on negative numbers.
    For instance: 3/(-2)/(-2) = 1 <> 0 = 3 / (-2*-2) *)

Lemma Zmod_div : forall a b, a mod b / b = 0.
Proof.
 intros a b.
 zero_or_not b.
 auto using Z.mod_div.
Qed.

(** A last inequality: *)

Theorem Zdiv_mult_le:
 forall a b c, 0<=a -> 0<=b -> 0<=c -> c*(a/b) <= (c*a)/b.
Proof.
 intros. zero_or_not b. apply Z.div_mul_le; auto with zarith. Qed.

(** Z.modulo is related to divisibility (see more in Znumtheory) *)

Lemma Zmod_divides : forall a b, b<>0 ->
 (a mod b = 0 <-> exists c, a = b*c).
Proof.
 intros. rewrite Z.mod_divide; trivial.
 split; intros (c,Hc); exists c; subst; auto with zarith.
Qed.

(** Particular case : dividing by 2 is related with parity *)

Lemma Zdiv2_div : forall a, Z.div2 a = a/2.
Proof Z.div2_div.

Lemma Zmod_odd : forall a, a mod 2 = if Z.odd a then 1 else 0.
Proof.
 intros a. now rewrite <- Z.bit0_odd, <- Z.bit0_mod.
Qed.

Lemma Zmod_even : forall a, a mod 2 = if Z.even a then 0 else 1.
Proof.
 intros a. rewrite Zmod_odd, Zodd_even_bool. now destruct Z.even.
Qed.

Lemma Zodd_mod : forall a, Z.odd a = Zeq_bool (a mod 2) 1.
Proof.
 intros a. rewrite Zmod_odd. now destruct Z.odd.
Qed.

Lemma Zeven_mod : forall a, Z.even a = Zeq_bool (a mod 2) 0.
Proof.
 intros a. rewrite Zmod_even. now destruct Z.even.
Qed.

(** * Compatibility *)

(** Weaker results kept only for compatibility *)

Lemma Z_mod_same : forall a, a > 0 -> a mod a = 0.
Proof.
  intros; apply Z_mod_same_full.
Qed.

Lemma Z_div_same : forall a, a > 0 -> a/a = 1.
Proof.
  intros; apply Z_div_same_full; auto with zarith.
Qed.

Lemma Z_div_plus : forall a b c:Z, c > 0 -> (a + b * c) / c = a / c + b.
Proof.
  intros; apply Z_div_plus_full; auto with zarith.
Qed.

Lemma Z_div_mult : forall a b:Z, b > 0 -> (a*b)/b = a.
Proof.
  intros; apply Z_div_mult_full; auto with zarith.
Qed.

Lemma Z_mod_plus : forall a b c:Z, c > 0 -> (a + b * c) mod c = a mod c.
Proof.
  intros; apply Z_mod_plus_full; auto with zarith.
Qed.

Lemma Z_div_exact_1 : forall a b:Z, b > 0 -> a = b*(a/b) -> a mod b = 0.
Proof.
  intros; apply Z_div_exact_full_1; auto with zarith.
Qed.

Lemma Z_div_exact_2 : forall a b:Z, b > 0 -> a mod b = 0 -> a = b*(a/b).
Proof.
  intros; apply Z_div_exact_full_2; auto with zarith.
Qed.

Lemma Z_mod_zero_opp : forall a b:Z, b > 0 -> a mod b = 0 -> (-a) mod b = 0.
Proof.
  intros; apply Z_mod_zero_opp_full; auto with zarith.
Qed.

(** * A direct way to compute Z.modulo *)

Fixpoint Zmod_POS (a : positive) (b : Z) : Z  :=
  match a with
   | xI a' =>
      let r := Zmod_POS a' b in
      let r' := (2 * r + 1) in
      if r' <? b then r' else (r' - b)
   | xO a' =>
      let r := Zmod_POS a' b in
      let r' := (2 * r) in
      if r' <? b then r' else (r' - b)
   | xH => if 2 <=? b then 1 else 0
  end.

Definition Zmod' a b :=
  match a with
   | Z0 => 0
   | Zpos a' =>
      match b with
       | Z0 => 0
       | Zpos _ => Zmod_POS a' b
       | Zneg b' =>
          let r := Zmod_POS a' (Zpos b') in
          match r  with Z0 =>  0 |  _  =>   b + r end
      end
   | Zneg a' =>
      match b with
       | Z0 => 0
       | Zpos _ =>
          let r := Zmod_POS a' b in
          match r with Z0 =>  0 | _  =>  b - r end
       | Zneg b' => - (Zmod_POS a' (Zpos b'))
      end
  end.

Theorem Zmod_POS_correct a b : Zmod_POS a b = snd (Z.pos_div_eucl a b).
Proof.
  induction a as [a IH|a IH| ]; simpl; rewrite ?IH.
  destruct (Z.pos_div_eucl a b) as (p,q); simpl;
   case Z.ltb_spec; reflexivity.
  destruct (Z.pos_div_eucl a b) as (p,q); simpl;
   case Z.ltb_spec; reflexivity.
  case Z.leb_spec; trivial.
Qed.

Theorem Zmod'_correct: forall a b, Zmod' a b = a mod b.
Proof.
  intros a b; unfold Z.modulo; case a; simpl; auto.
  intros p; case b; simpl; auto.
  intros p1; refine (Zmod_POS_correct _ _); auto.
  intros p1; rewrite Zmod_POS_correct; auto.
  case (Z.pos_div_eucl p (Zpos p1)); simpl; intros z1 z2; case z2; auto.
  intros p; case b; simpl; auto.
  intros p1; rewrite Zmod_POS_correct; auto.
  case (Z.pos_div_eucl p (Zpos p1)); simpl; intros z1 z2; case z2; auto.
  intros p1; rewrite Zmod_POS_correct; simpl; auto.
  case (Z.pos_div_eucl p (Zpos p1)); auto.
Qed.

(** Another convention is possible for division by negative numbers:
    * quotient is always the biggest integer smaller than or equal to a/b
    * remainder is hence always positive or null. *)

Theorem Zdiv_eucl_extended :
  forall b:Z,
    b <> 0 ->
    forall a:Z,
      {qr : Z * Z | let (q, r) := qr in a = b * q + r /\ 0 <= r < Z.abs b}.
Proof.
  intros b Hb a.
  destruct (Z_le_gt_dec 0 b) as [Hb'|Hb'].
  - assert (Hb'' : b > 0) by omega.
    rewrite Z.abs_eq; [ apply Zdiv_eucl_exist; assumption | assumption ].
  - assert (Hb'' : - b > 0) by omega.
    destruct (Zdiv_eucl_exist Hb'' a) as ((q,r),[]).
    exists (- q, r).
    split.
    + rewrite <- Z.mul_opp_comm; assumption.
    + rewrite Z.abs_neq; [ assumption | omega ].
Qed.

Arguments Zdiv_eucl_extended : default implicits.

(** * Division and modulo in Z agree with same in nat: *)

Require Import PeanoNat.

Lemma div_Zdiv (n m: nat): m <> O ->
  Z.of_nat (n / m) = Z.of_nat n / Z.of_nat m.
Proof.
 intros.
 apply (Zdiv_unique _ _ _ (Z.of_nat (n mod m))).
  split. auto with zarith.
  now apply inj_lt, Nat.mod_upper_bound.
 rewrite <- Nat2Z.inj_mul, <- Nat2Z.inj_add.
 now apply inj_eq, Nat.div_mod.
Qed.

Lemma mod_Zmod (n m: nat): m <> O ->
  Z.of_nat (n mod m) = (Z.of_nat n) mod (Z.of_nat m).
Proof.
 intros.
 apply (Zmod_unique _ _ (Z.of_nat n / Z.of_nat m)).
  split. auto with zarith.
  now apply inj_lt, Nat.mod_upper_bound.
 rewrite <- div_Zdiv, <- Nat2Z.inj_mul, <- Nat2Z.inj_add by trivial.
 now apply inj_eq, Nat.div_mod.
Qed.


Require Import ExtLib.Structures.Applicative.

Set Implicit Arguments.
Set Strict Implicit.

Definition lift1 {T U : Type} {F : Type -> Type}
           {Ap : Applicative.Applicative F}
(f : T -> U) (x : F T) : F U :=
  Applicative.ap (Applicative.pure f) x.

Definition lift2 {T U V : Type} {F : Type -> Type}
           {Ap : Applicative.Applicative F}
(f : T -> U -> V) (x : F T) (y : F U) : F V :=
  Applicative.ap (lift1 (F:=F) f x) y.


Unset Strict Universe Declaration.
Notation idmap := (fun x => x).
Inductive paths {A : Type} (a : A) : A -> Type := idpath : paths a a.
Arguments idpath {A a} , [A] a.
Notation "x = y :> A" := (@paths A x y) : type_scope.
Notation "x = y" := (x = y :>_) : type_scope.
Delimit Scope path_scope with path.
Definition concat {A : Type} {x y z : A} (p : x = y) (q : y = z) : x = z := match p, q with idpath, idpath => idpath end.
Definition inverse {A : Type} {x y : A} (p : x = y) : y = x := match p with idpath => idpath end.
Notation "p @ q" := (concat p q) (at level 20) : path_scope.
Notation "p ^" := (inverse p) (at level 3, format "p '^'") : path_scope.
Class IsEquiv {A B : Type} (f : A -> B) := {}.
Axiom path_universe : forall {A B : Type} (f : A -> B) {feq : IsEquiv f}, (A = B).

Definition Lift : Type@{i} -> Type@{j}
  := Eval hnf in let lt := Type@{i} : Type@{j} in fun T => T.

Definition lift {T} : T -> Lift T := fun x => x.

Goal forall x y : Type, x = y.
  intros.
  pose proof ((fun H0 : idmap _ => (@path_universe _ _ (@lift x) (H0 x) @
                                                   (@path_universe _ _ (@lift x) (H0 x))^)))%path as H''.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas32_2e389m21_16limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition add :
  { add : feBW_tight -> feBW_tight -> feBW_loose
  | forall a b, phiBW_loose (add a b) = F.add (phiBW_tight a) (phiBW_tight b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_add ().
  Show Ltac Profile.
Time Defined.

Print Assumptions add.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas32_2e383m31_16limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition add :
  { add : feBW_tight -> feBW_tight -> feBW_loose
  | forall a b, phiBW_loose (add a b) = F.add (phiBW_tight a) (phiBW_tight b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_add ().
  Show Ltac Profile.
Time Defined.

Print Assumptions add.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas32_2e256m2e32m977_13limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition add :
  { add : feBW_tight -> feBW_tight -> feBW_loose
  | forall a b, phiBW_loose (add a b) = F.add (phiBW_tight a) (phiBW_tight b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_add ().
  Show Ltac Profile.
Time Defined.

Print Assumptions add.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall A B C O Cprime : Universe, ((wd_ A B /\ (wd_ B C /\ (wd_ A C /\ (wd_ O B /\ (wd_ O C /\ (wd_ A O /\ (wd_ Cprime A /\ (wd_ Cprime B /\ (col_ A B C /\ (col_ O B C /\ col_ Cprime A B)))))))))) -> col_ A O B)).
Proof.
  time tac.
Qed.

End FOFProblem.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall A B C M Cprime : Universe, ((wd_ A B /\ (wd_ B C /\ (wd_ A C /\ (wd_ M A /\ (wd_ M B /\ (wd_ M C /\ (wd_ C Cprime /\ (wd_ M Cprime /\ (wd_ B Cprime /\ (wd_ A Cprime /\ (col_ A C Cprime /\ (col_ M A B /\ col_ M C Cprime)))))))))))) -> col_ A B C)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e322m2e161m1_7limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition add :
  { add : feBW_tight -> feBW_tight -> feBW_loose
  | forall a b, phiBW_loose (add a b) = F.add (phiBW_tight a) (phiBW_tight b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_add ().
  Show Ltac Profile.
Time Defined.

Print Assumptions add.