(*************************************************************************)
(* Copyright (C) 2013 - 2015                                             *)
(* Author C. Cohen                                                       *)
(* DRAFT - PLEASE USE WITH CAUTION                                       *)
(* License CeCILL-B                                                      *)
(*************************************************************************)

From mathcomp
Require Import ssreflect ssrbool ssrnat eqtype ssrfun seq.
From mathcomp
Require Import choice path finset finfun fintype bigop.
Require Import finmap.

(*****************************************************************************)
(* This file provides a representation of multisets based on fsfun           *)
(*   {mset T} == the type of multisets on a choiceType T                     *)
(* The following notations are in the %mset scope                            *)
(*             mset0 == the empty multiset                                   *)
(*          mset n a == the multiset with n times element a                  *)
(*          [mset a] == the singleton multiset {k} := mset 1 a               *)
(* [mset a1; ..; an] == the multiset obtained from the elements a1,..,an     *)
(*           A `&` B == the intersection of A and B (the min of each)        *)
(*           A `|` B == the union of A and B (the max of each)               *)
(*           A `+` B == the sum of A and B                                   *)
(*            a |` B == the union of singleton a and B                       *)
(*            a +` B == the addition of singleton a to B                     *)
(*           A `\` B == the difference A minus B                             *)
(*            A `\ b == A without one b                                      *)
(*           A `*` B == the product of A and B                               *)
(*  [disjoint A & B] := A `&` B == 0                                         *)
(*          A `<=` B == A is a sub-multiset of B                             *)
(*           A `<` B == A is a proper sub-multiset of B                      *)
(*****************************************************************************)

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

Lemma sumn_map I (f : I -> nat) s :
   sumn [seq f i | i <- s] = \sum_(i <- s) f i.
Proof. by elim: s => [|i s IHs] in f *; rewrite ?(big_nil, big_cons) //= IHs. Qed.

Lemma sumn_filter s P : sumn [seq i <- s | P i] = \sum_(i <- s | P i) i.
Proof. by rewrite -big_filter -sumn_map map_id. Qed.

Lemma sumn_map_filter I s (f : I -> nat) P :
   sumn [seq f i | i <- s & P i] = \sum_(i <- s | P i) f i.
Proof. by rewrite sumn_map big_filter. Qed.

Delimit Scope mset_scope with mset.
Local Open Scope fset_scope.
Local Open Scope fmap_scope.
Local Open Scope mset_scope.
Local Open Scope nat_scope.

Definition multiset (T : choiceType) := {fsfun T -> nat with 0}.
Definition multiset_of (T : choiceType) of phant T := @multiset T.
Notation "'{mset' T }" := (@multiset_of _ (Phant T))
  (format "'{mset'  T }") : mset_scope.

Notation "[ 'mset[' key ] x 'in' aT => F ]" := ([fsfun[key] x in aT => F] : {mset _})
  (at level 0, x ident, only parsing) : mset_scope.
Notation "[ 'mset' x 'in' aT => F ]" := ([fsfun x in aT => F] : {mset _})
  (at level 0, x ident, only parsing) : mset_scope.
Notation "[ 'm' 'set' x 'in' aT => F ]" := ([fsfun[_] x in aT => F] : {mset _})
  (at level 0, x ident, format "[ 'm' 'set'  x  'in'  aT  =>  F ]") : mset_scope.

Identity Coercion multiset_multiset_of : multiset_of >-> multiset.

Notation enum_mset_def A :=
  (flatten [seq nseq (A%mset x) x | x <- finsupp A%mset]).

Module Type EnumMsetSig.
Axiom f : forall K, multiset K -> seq K.
Axiom E : f = (fun K (A : multiset K) => enum_mset_def A).
End EnumMsetSig.
Module EnumMset : EnumMsetSig.
Definition f K (A : multiset K) := enum_mset_def A.
Definition E := (erefl f).
End EnumMset.
Notation enum_mset := EnumMset.f.
Coercion enum_mset : multiset >-> seq.
Canonical enum_mset_unlock := Unlockable EnumMset.E.

Canonical multiset_predType (K : choiceType) :=
   Eval hnf in mkPredType (fun (A : multiset K) a => a \in enum_mset A).
Canonical mset_finpredType (T: choiceType) :=
  mkFinPredType (multiset T) (fun A => undup (enum_mset A))
                (fun _ => undup_uniq _) (fun _ _ => mem_undup _ _).

Section MultisetOps.

Context {K : choiceType}.
Implicit Types (a b c : K) (A B C D : {mset K}) (s : seq K).

Definition mset0 : {mset K} := [fsfun].

Fact msetn_key : unit. Proof. exact: tt. Qed.
Definition msetn n a := [mset[msetn_key] x in [fset a] => n].

Fact seq_mset_key : unit. Proof. exact: tt. Qed.
Definition seq_mset (s : seq K) :=
  [mset[seq_mset_key] x in [fset x in s] => count (pred1 x) s].

Fact msetU_key : unit. Proof. exact: tt. Qed.
Definition msetU A B :=
  [mset[msetU_key] x in finsupp A `|` finsupp B => maxn (A x) (B x)].

Fact msetI_key : unit. Proof. exact: tt. Qed.
Definition msetI A B :=
  [mset[msetI_key] x in finsupp A `|` finsupp B => minn (A x) (B x)].

Fact msetD_key : unit. Proof. exact: tt. Qed.
Definition msetD A B :=
  [mset[msetD_key] x in finsupp A `|` finsupp B => A x + B x].

Fact msetB_key : unit. Proof. exact: tt. Qed.
Definition msetB A B :=
  [mset[msetB_key] x in finsupp A `|` finsupp B => A x - B x].

Fact msetM_key : unit. Proof. exact: tt. Qed.
Definition msetM A B :=
  [mset[msetM_key] x in finsupp A `*` finsupp B => A x.1 * B x.2].

Definition msubset A B := [forall x : finsupp A, A (val x) <= B (val x)].

Definition mproper A B := msubset A B && ~~ msubset B A.

Definition mdisjoint A B := (msetI A B == mset0).

End MultisetOps.

Notation "[ 'mset' a ]" := (msetn 1 a)
  (at level 0, a at level 99, format "[ 'mset'  a ]") : mset_scope.
Notation "[ 'mset' a : T ]" := [mset (a : T)]
  (at level 0, a at level 99, format "[ 'mset'  a   :  T ]") : mset_scope.
Notation "A `|` B" := (msetU A B) : mset_scope.
Notation "A `+` B" := (msetD A B) : mset_scope.
Notation "A `\` B" := (msetB A B) : mset_scope.
Notation "A `\ a" := (A `\` [mset a]) : mset_scope.
Notation "a |` A" := ([mset (a)] `|` A) : mset_scope.
Notation "a +` A" := ([mset (a)] `+` A) : mset_scope.
Notation "A `*` B" := (msetM A B) : mset_scope.

Notation "A `<=` B" := (msubset A B)
  (at level 70, no associativity) : mset_scope.

Notation "A `<` B" := (mproper A B)
  (at level 70, no associativity) : mset_scope.

(* This is left-associative due to historical limitations of the .. Notation. *)
Notation "[ 'mset' a1 ; a2 ; .. ; an ]" :=
  (msetD .. (a1 +` (msetn 1 a2)) .. (msetn 1 an))
  (at level 0, a1 at level 99,
   format "[ 'mset'  a1 ;  a2 ;  .. ;  an ]") : mset_scope.
Notation "A `&` B" := (msetI A B) : mset_scope.

Section MSupp.

Context {K : choiceType}.
Implicit Types (a b c : K) (A B C D : {mset K}) (s : seq K).

Lemma enum_msetE a A :
   (a \in A) = (a \in flatten [seq nseq (A x) x | x <- finsupp A]).
Proof. by transitivity (a \in enum_mset A); rewrite // unlock. Qed.

Lemma msuppE a A : (a \in finsupp A) = (a \in A).
Proof.
rewrite enum_msetE.
apply/idP/flattenP => [aA|/=[_ /mapP[x xA -> /nseqP[->//]]]].
exists (nseq (A a) a); first by apply/mapP; exists a.
by apply/nseqP; split=> //; rewrite lt0n -mem_finsupp.
Qed.

End MSupp.

Section MSetTheory.

Context {K : choiceType}.
Implicit Types (a b c : K) (A B C D : {mset K}) (s : seq K).

Lemma msetP {A B} : A =1 B <-> A = B.
Proof. exact: fsfunP. Qed.

Lemma mset_neq0 a A : (A a != 0) = (a \in A).
Proof. by rewrite -msuppE mem_finsupp. Qed.

Lemma in_mset a A : (a \in A) = (A a > 0).
Proof. by rewrite -mset_neq0 lt0n. Qed.

Lemma mset_eq0 a A : (A a == 0) = (a \notin A).
Proof. by rewrite -mset_neq0 negbK. Qed.

Lemma mset_eq0P {a A} : reflect (A a = 0) (a \notin A).
Proof. by rewrite -mset_eq0; apply: eqP. Qed.

Lemma mset_gt0 a A : (A a > 0) = (a \in A).
Proof. by rewrite -in_mset. Qed.

Lemma mset_eqP {A B} : reflect (A =1 B) (A == B).
Proof. exact: (equivP eqP (iff_sym msetP)). Qed.

Lemma mset0E a : mset0 a = 0.
Proof. by rewrite /mset0 fsfunE. Qed.

Lemma msetnE n a b : (msetn n a) b = if b == a then n else 0.
Proof. by rewrite fsfunE inE. Qed.

Lemma msetnxx n a : (msetn n a) a = n. Proof. by rewrite msetnE eqxx. Qed.

Lemma msetE2 A B a :
 ((A `+` B) a = A a + B a) * ((A `|` B) a = maxn (A a) (B a))
* ((A `&` B) a = minn (A a) (B a)) * ((A `\` B) a = (A a) - (B a)).
Proof.
rewrite !fsfunE !inE !msuppE -!mset_neq0; case: ifPn => //.
by rewrite negb_or !negbK => /andP [/eqP-> /eqP->].
Qed.

Lemma count_mem_mset a A : count_mem a A = A a.
Proof.
rewrite unlock count_flatten sumn_map big_map.
rewrite (eq_bigr _ (fun _ _ => esym (sum1_count _ _))) /=.
rewrite (eq_bigr _ (fun _ _ => big_nseq_cond _ _ _ _ _ _)) /= -big_mkcond /=.
have [aNA|aA] := finsuppP.
  by rewrite big1_fset // => i iA /eqP eq_ia; rewrite -eq_ia iA in aNA.
rewrite big_fset_condE/= (big_fsetD1 a) ?inE ?eqxx ?andbT //= iter_addn mul1n.
rewrite (_ : (_ `\ _)%fset = fset0) ?big_seq_fset0 ?addn0//.
by apply/fsetP=> i; rewrite !inE; case: (i == a); rewrite ?(andbF, andbT).
Qed.

Lemma perm_undup_mset A : perm_eq (undup A) (finsupp A).
Proof.
apply: uniq_perm_eq; rewrite ?undup_uniq // => a.
by rewrite mem_undup msuppE.
Qed.

Section big_com.
Variables (R : Type) (idx : R) (op : Monoid.com_law idx).
Implicit Types (X : {mset K}) (P : pred K) (F : K -> R).

Lemma big_mset X P F :
  \big[op/idx]_(i <- X | P i) F i =
  \big[op/idx]_(i <- finsupp X | P i) iterop (X i) op (F i) idx.
Proof.
rewrite [in RHS](eq_big_perm (undup X)) 1?perm_eq_sym ?perm_undup_mset//.
rewrite -[in LHS]big_undup_iterop_count; apply: eq_bigr => i _.
by rewrite count_mem_mset.
Qed.

End big_com.

Lemma sum_mset (X : {mset K}) (P : pred K) (F : K -> nat) :
  \sum_(i <- X | P i) F i = \sum_(i <- finsupp X | P i) X i * F i.
Proof.
rewrite big_mset; apply: eq_bigr => i _ //.
by rewrite Monoid.iteropE iter_addn addn0 mulnC.
Qed.

Lemma prod_mset (X : {mset K}) (P : pred K) (F : K -> nat) :
  \prod_(i <- X | P i) F i = \prod_(i <- finsupp X | P i) F i ^ X i.
Proof. by rewrite big_mset. Qed.

Lemma mset_seqE s a : (seq_mset s) a = count_mem a s.
Proof. by rewrite fsfunE inE/=; case: ifPn => // /count_memPn ->. Qed.

Lemma perm_eq_seq_mset s : perm_eq (seq_mset s) s.
Proof. by apply/allP => a _ /=; rewrite count_mem_mset mset_seqE. Qed.

Lemma seq_mset_id A : seq_mset A = A.
Proof. by apply/msetP=> a; rewrite mset_seqE count_mem_mset. Qed.

Lemma eq_seq_msetP s s' : reflect (seq_mset s = seq_mset s') (perm_eq s s').
Proof.
apply: (iffP idP) => [/perm_eqP perm_ss'|eq_ss'].
  by apply/msetP => a; rewrite !mset_seqE perm_ss'.
by apply/allP => a _ /=; rewrite -!mset_seqE eq_ss'.
Qed.

Lemma msetME A B (u : K * K) : (A `*` B) u = A u.1 * B u.2.
Proof.
rewrite !fsfunE inE; case: ifPn => //=.
by rewrite negb_and !memNfinsupp => /orP [] /eqP->; rewrite ?muln0.
Qed.

Lemma mset1DE a A b : (a +` A) b = (b == a) + A b.
Proof. by rewrite msetE2 msetnE; case: (b == a). Qed.

Lemma mset1UE a A b : (a |` A) b = maxn (b == a) (A b).
Proof. by rewrite msetE2 msetnE; case: (b == a). Qed.

Lemma msetB1E a A b : (A `\ a) b = (A b) - (b == a).
Proof. by rewrite msetE2 msetnE; case: (b == a). Qed.

Let msetE := (mset0E, msetE2, msetnE, msetnxx,
              mset1DE, mset1UE, msetB1E,
              mset_seqE, msetME).

Lemma in_mset0 a : a \in mset0 = false.
Proof. by rewrite in_mset !msetE. Qed.

Lemma in_msetn n a' a : a \in msetn n a' = (n > 0) && (a == a').
Proof. by rewrite in_mset msetE; case: (a == a'); rewrite ?andbT ?andbF. Qed.

Lemma in_mset1 a' a : a \in [mset a'] = (a == a').
Proof. by rewrite in_msetn. Qed.

Lemma in_msetD A B a : (a \in A `+` B) = (a \in A) || (a \in B).
Proof. by rewrite !in_mset !msetE addn_gt0. Qed.

Lemma in_msetU A B a : (a \in A `|` B) = (a \in A) || (a \in B).
Proof. by rewrite !in_mset !msetE leq_max. Qed.

Lemma in_msetDU A B a : (a \in A `+` B) = (a \in A `|` B).
Proof. by rewrite in_msetU in_msetD. Qed.

Lemma in_msetI A B a : (a \in A `&` B) = (a \in A) && (a \in B).
Proof. by rewrite !in_mset msetE leq_min. Qed.

Lemma in_msetB A B a : (a \in A `\` B) = (B a < A a).
Proof. by rewrite -mset_neq0 msetE subn_eq0 ltnNge. Qed.

Lemma in_mset1U a' A a : (a \in a' |` A) = (a == a') || (a \in A).
Proof. by rewrite in_msetU in_mset msetE; case: (_ == _). Qed.

Lemma in_mset1D a' A a : (a \in a' +` A) = (a == a') || (a \in A).
Proof. by rewrite in_msetDU in_mset1U. Qed.

Lemma in_msetB1 A b a : (a \in A `\ b) = ((a == b) ==> (A a > 1)) && (a \in A).
Proof.
by rewrite in_msetB msetE in_mset; case: (_ == _); rewrite -?geq_max.
Qed.

Lemma in_msetM A B (u : K * K) : (u \in A `*` B) = (u.1 \in A) && (u.2 \in B).
Proof. by rewrite -!msuppE !mem_finsupp msetE muln_eq0 negb_or. Qed.

Definition in_msetE := (in_mset0, in_msetn,
                        in_msetB1, in_msetU, in_msetI, in_msetD, in_msetM).

Let inE := (inE, in_msetE, (@msuppE K)).

Lemma enum_mset0 : mset0 = [::] :> seq K.
Proof. by rewrite unlock finsupp0. Qed.

Lemma msetn0 (a : K) : msetn 0 a = mset0.
Proof. by apply/msetP=> i; rewrite !msetE if_same. Qed.

Lemma finsupp_msetn n a : finsupp (msetn n a) = if n > 0 then [fset a] else fset0.
Proof.  by apply/fsetP => i; rewrite !inE; case: ifP => //=; rewrite inE. Qed.

Lemma enum_msetn n a : msetn n a = nseq n a :> seq K.
Proof.
case: n => [|n]; first by rewrite msetn0 /= enum_mset0.
rewrite unlock finsupp_msetn /= enum_fsetE /= enum_fset1 /= cats0.
by rewrite msetE eqxx.
Qed.

Section big.
Variables (R : Type) (idx : R) (op : Monoid.law idx).
Implicit Types (X : {mset K}) (P : pred K) (F : K -> R).

Lemma big_mset0 P F : \big[op/idx]_(i <- mset0 | P i) F i = idx.
Proof. by rewrite enum_mset0 big_nil. Qed.

Lemma big_msetn n a P F :
   \big[op/idx]_(i <- msetn n a | P i) F i =
   if P a then iterop n op (F a) idx else idx.
Proof. by rewrite enum_msetn big_nseq_cond Monoid.iteropE. Qed.
End big.

Lemma msetDC (A B : {mset K}) : A `+` B = B `+` A.
Proof. by apply/msetP=> a; rewrite !msetE addnC. Qed.

Lemma msetIC (A B : {mset K}) : A `&` B = B `&` A.
Proof. by apply/msetP=> a; rewrite !msetE minnC. Qed.

Lemma msetUC (A B : {mset K}) : A `|` B = B `|` A.
Proof. by apply/msetP => a; rewrite !msetE maxnC. Qed.

(* intersection *)

Lemma mset0I A : mset0 `&` A = mset0.
Proof. by apply/msetP => x; rewrite !msetE min0n. Qed.

Lemma msetI0 A : A `&` mset0 = mset0.
Proof. by rewrite msetIC mset0I. Qed.

Lemma msetIA A B C : A `&` (B `&` C) = A `&` B `&` C.
Proof. by apply/msetP=> x; rewrite !msetE minnA. Qed.

Lemma msetICA A B C : A `&` (B `&` C) = B `&` (A `&` C).
Proof. by rewrite !msetIA (msetIC A). Qed.

Lemma msetIAC A B C : A `&` B `&` C = A `&` C `&` B.
Proof. by rewrite -!msetIA (msetIC B). Qed.

Lemma msetIACA A B C D : (A `&` B) `&` (C `&` D) = (A `&` C) `&` (B `&` D).
Proof. by rewrite -!msetIA (msetICA B). Qed.

Lemma msetIid A : A `&` A = A.
Proof. by apply/msetP=> x; rewrite !msetE minnn. Qed.

Lemma msetIIl A B C : A `&` B `&` C = (A `&` C) `&` (B `&` C).
Proof. by rewrite msetIA !(msetIAC _ C) -(msetIA _ C) msetIid. Qed.

Lemma msetIIr A B C : A `&` (B `&` C) = (A `&` B) `&` (A `&` C).
Proof. by rewrite !(msetIC A) msetIIl. Qed.

(* union *)

Lemma mset0U A : mset0 `|` A = A.
Proof. by apply/msetP => x; rewrite !msetE max0n. Qed.

Lemma msetU0 A : A `|` mset0 = A.
Proof. by rewrite msetUC mset0U. Qed.

Lemma msetUA A B C : A `|` (B `|` C) = A `|` B `|` C.
Proof. by apply/msetP=> x; rewrite !msetE maxnA. Qed.

Lemma msetUCA A B C : A `|` (B `|` C) = B `|` (A `|` C).
Proof. by rewrite !msetUA (msetUC B). Qed.

Lemma msetUAC A B C : A `|` B `|` C = A `|` C `|` B.
Proof. by rewrite -!msetUA (msetUC B). Qed.

Lemma msetUACA A B C D : (A `|` B) `|` (C `|` D) = (A `|` C) `|` (B `|` D).
Proof. by rewrite -!msetUA (msetUCA B). Qed.

Lemma msetUid A : A `|` A = A.
Proof. by apply/msetP=> x; rewrite !msetE maxnn. Qed.

Lemma msetUUl A B C : A `|` B `|` C = (A `|` C) `|` (B `|` C).
Proof. by rewrite msetUA !(msetUAC _ C) -(msetUA _ C) msetUid. Qed.

Lemma msetUUr A B C : A `|` (B `|` C) = (A `|` B) `|` (A `|` C).
Proof. by rewrite !(msetUC A) msetUUl. Qed.

(* adjunction *)

Lemma mset0D A : mset0 `+` A = A.
Proof. by apply/msetP => x; rewrite !msetE add0n. Qed.

Lemma msetD0 A : A `+` mset0 = A.
Proof. by rewrite msetDC mset0D. Qed.

Lemma msetDA A B C : A `+` (B `+` C) = A `+` B `+` C.
Proof. by apply/msetP=> x; rewrite !msetE addnA. Qed.

Lemma msetDCA A B C : A `+` (B `+` C) = B `+` (A `+` C).
Proof. by rewrite !msetDA (msetDC B). Qed.

Lemma msetDAC A B C : A `+` B `+` C = A `+` C `+` B.
Proof. by rewrite -!msetDA (msetDC B). Qed.

Lemma msetDACA A B C D : (A `+` B) `+` (C `+` D) = (A `+` C) `+` (B `+` D).
Proof. by rewrite -!msetDA (msetDCA B). Qed.

(* adjunction, union and difference with one element *)

Lemma msetU1l x A B : x \in A -> x \in A `|` B.
Proof. by move=> Ax /=; rewrite inE Ax. Qed.

Lemma msetU1r A b : b \in A `|` [mset b].
Proof. by rewrite !inE eqxx orbT. Qed.

Lemma msetB1P x A b : reflect ((x = b -> A x > 1) /\ x \in A) (x \in A `\ b).
Proof.
rewrite !inE. apply: (iffP andP); first by move=> [/implyP Ax ->]; split => // /eqP.
by move=> [Ax ->]; split => //; apply/implyP => /eqP.
Qed.

Lemma msetB11 b A : (b \in A `\ b) = (A b > 1).
Proof. by rewrite inE eqxx /= in_mset -geq_max. Qed.

Lemma msetB1K a A : a \in A -> a +` (A `\ a) = A.
Proof.
move=> aA; apply/msetP=> x; rewrite !msetE subnKC //=.
by have [->|//] := altP eqP; rewrite mset_gt0.
Qed.

Lemma msetD1K a B : (a +` B) `\ a = B.
Proof. by apply/msetP => x; rewrite !msetE addKn. Qed.

Lemma msetU1K a B : a \notin B -> (a |` B) `\ a = B.
Proof.
move=> aB; apply/msetP=> x; rewrite !msetE.
have [->|] := altP eqP; first by rewrite (mset_eq0P _).
by rewrite max0n subn0.
Qed.

Lemma mset1U1 x B : x \in x |` B. Proof. by rewrite !inE eqxx. Qed.
Lemma mset1D1 x B : x \in x +` B. Proof. by rewrite !inE eqxx. Qed.

Lemma mset1Ur x a B : x \in B -> x \in a |` B.
Proof. by move=> Bx; rewrite !inE predU1r. Qed.
Lemma mset1Dr x a B : x \in B -> x \in a +` B.
Proof. by move=> Bx; rewrite !inE predU1r. Qed.

Lemma mset2P x a b : reflect (x = a \/ x = b) (x \in [mset a; b]).
Proof. by rewrite !inE; apply: (iffP orP) => [] [] /eqP; intuition. Qed.

Lemma in_mset2 x a b : (x \in [mset a; b]) = (x == a) || (x == b).
Proof. by rewrite !inE. Qed.

Lemma mset21 a b : a \in [mset a; b]. Proof. by rewrite mset1D1. Qed.

Lemma mset22 a b : b \in [mset a; b]. Proof. by rewrite in_mset2 eqxx orbT. Qed.

Lemma msetUP x A B : reflect (x \in A \/ x \in B) (x \in A `|` B).
Proof. by rewrite !inE; exact: orP. Qed.

Lemma msetDP x A B : reflect (x \in A \/ x \in B) (x \in A `+` B).
Proof. by rewrite !inE; exact: orP. Qed.

Lemma msetULVR x A B : x \in A `|` B -> (x \in A) + (x \in B).
Proof. by rewrite inE; case: (x \in A); [left|right]. Qed.

Lemma msetDLVR x A B : x \in A `+` B -> (x \in A) + (x \in B).
Proof. by rewrite inE; case: (x \in A); [left|right]. Qed.

(* distribute /cancel *)

Lemma msetIUr A B C : A `&` (B `|` C) = (A `&` B) `|` (A `&` C).
Proof. by apply/msetP=> x; rewrite !msetE minn_maxr. Qed.

Lemma msetIUl A B C : (A `|` B) `&` C = (A `&` C) `|` (B `&` C).
Proof. by apply/msetP=> x; rewrite !msetE minn_maxl. Qed.

Lemma msetUIr A B C : A `|` (B `&` C) = (A `|` B) `&` (A `|` C).
Proof. by apply/msetP=> x; rewrite !msetE maxn_minr. Qed.

Lemma msetUIl A B C : (A `&` B) `|` C = (A `|` C) `&` (B `|` C).
Proof. by apply/msetP=> x; rewrite !msetE maxn_minl. Qed.

Lemma msetUKC A B : (A `|` B) `&` A = A.
Proof. by apply/msetP=> x; rewrite !msetE maxnK. Qed.

Lemma msetUK A B : (B `|` A) `&` A = A.
Proof. by rewrite msetUC msetUKC. Qed.

Lemma msetKUC A B : A `&` (B `|` A) = A.
Proof. by rewrite msetIC msetUK. Qed.

Lemma msetKU A B : A `&` (A `|` B) = A.
Proof. by rewrite msetIC msetUKC. Qed.

Lemma msetIKC A B : (A `&` B) `|` A = A.
Proof. by apply/msetP=> x; rewrite !msetE minnK. Qed.

Lemma msetIK A B : (B `&` A) `|` A = A.
Proof. by rewrite msetIC msetIKC. Qed.

Lemma msetKIC A B : A `|` (B `&` A) = A.
Proof. by rewrite msetUC msetIK. Qed.

Lemma msetKI A B : A `|` (A `&` B) = A.
Proof. by rewrite msetIC msetKIC. Qed.

Lemma msetUKid A B : B `|` A `|` A = B `|` A.
Proof. by rewrite -msetUA msetUid. Qed.

Lemma msetUKidC A B : A `|` B `|` A = A `|` B.
Proof. by rewrite msetUAC msetUid. Qed.

Lemma msetKUid A B : A `|` (A `|` B) = A `|` B.
Proof. by rewrite msetUA msetUid. Qed.

Lemma msetKUidC A B : A `|` (B `|` A) = B `|` A.
Proof. by rewrite msetUCA msetUid. Qed.

Lemma msetIKid A B : B `&` A `&` A = B `&` A.
Proof. by rewrite -msetIA msetIid. Qed.

Lemma msetIKidC A B : A `&` B `&` A = A `&` B.
Proof. by rewrite msetIAC msetIid. Qed.

Lemma msetKIid A B : A `&` (A `&` B) = A `&` B.
Proof. by rewrite msetIA msetIid. Qed.

Lemma msetKIidC A B : A `&` (B `&` A) = B `&` A.
Proof. by rewrite msetICA msetIid. Qed.

Lemma msetDIr A B C : A `+` (B `&` C) = (A `+` B) `&` (A `+` C).
Proof. by apply/msetP=> x; rewrite !msetE addn_minr. Qed.

Lemma msetDIl A B C : (A `&` B) `+` C = (A `+` C) `&` (B `+` C).
Proof. by apply/msetP=> x; rewrite !msetE addn_minl. Qed.

Lemma msetDKIC A B : (A `+` B) `&` A = A.
Proof. by apply/msetP=> x; rewrite !msetE (minn_idPr _) // leq_addr. Qed.

Lemma msetDKI A B : (B `+` A) `&` A = A.
Proof. by rewrite msetDC msetDKIC. Qed.

Lemma msetKDIC A B : A `&` (B `+` A) = A.
Proof. by rewrite msetIC msetDKI. Qed.

Lemma msetKDI A B : A `&` (A `+` B) = A.
Proof. by rewrite msetDC msetKDIC. Qed.

(* adjunction / subtraction *)

Lemma msetDKB A : cancel (msetD A) (msetB^~ A).
Proof. by move=> B; apply/msetP => a; rewrite !msetE addKn. Qed.

Lemma msetDKBC A : cancel (msetD^~ A) (msetB^~ A).
Proof. by move=> B; rewrite msetDC msetDKB. Qed.

Lemma msetBSKl A B a : ((a +` A) `\` B) `\ a = A `\` B.
Proof.
apply/msetP=> b; rewrite !msetE; case: ifPn; rewrite ?add0n ?subn0 //.
by rewrite add1n subn1 subSKn.
Qed.

Lemma msetBDl C A B : (C `+` A) `\` (C `+` B) = A `\` B.
Proof. by apply/msetP=> a; rewrite !msetE subnDl. Qed.

Lemma msetBDr C A B : (A `+` C) `\` (B `+` C) = A `\` B.
Proof. by apply/msetP=> a; rewrite !msetE subnDr. Qed.

Lemma msetBDA A B C : B `\` (A `+` C) = B `\` A `\` C.
Proof. by apply/msetP=> a; rewrite !msetE subnDA. Qed.

Lemma msetUE A B C : msetU A B = A `+` (B `\` A).
Proof. by apply/msetP=> a; rewrite !msetE maxnE. Qed.

(* subset *)

Lemma msubsetP {A B} : reflect (forall x, A x <= B x) (A `<=` B).
Proof.
apply: (iffP forallP)=> // ? x; case: (in_fsetP (finsupp A) x) => //.
by rewrite msuppE => /mset_eq0P->.
Qed.

Lemma msubset_subset {A B} : A `<=` B -> {subset A <= B}.
Proof.
by move=> /msubsetP AB x; rewrite !in_mset => ?; exact: (leq_trans _ (AB _)).
Qed.

Lemma msetB_eq0 (A B : {mset K}) : (A `\` B == mset0) = (A `<=` B).
Proof.
apply/mset_eqP/msubsetP => AB a;
by have := AB a; rewrite !msetE -subn_eq0 => /eqP.
Qed.

Lemma msubset_refl A : A `<=` A. Proof. exact/msubsetP. Qed.
Hint Resolve msubset_refl.

Lemma msubset_trans : transitive (@msubset K).
Proof.
move=> y x z /msubsetP xy /msubsetP yz ; apply/msubsetP => a.
by apply: (leq_trans (xy _)).
Qed.
Arguments msubset_trans {C A B} _ _ : rename.

Lemma msetUS C A B : A `<=` B -> C `|` A `<=` C `|` B.
Proof.
move=> sAB; apply/msubsetP=> x; rewrite !msetE.
by rewrite geq_max !leq_max leqnn (msubsetP sAB) orbT.
Qed.

Lemma msetDS C A B : A `<=` B -> C `+` A `<=` C `+` B.
Proof.
by move=> /msubsetP sAB; apply/msubsetP=> x; rewrite !msetE leq_add2l.
Qed.

Lemma msetSU C A B : A `<=` B -> A `|` C `<=` B `|` C.
Proof. by move=> sAB; rewrite -!(msetUC C) msetUS. Qed.

Lemma msetSD C A B : A `<=` B -> A `+` C `<=` B `+` C.
Proof. by move=> sAB; rewrite -!(msetDC C) msetDS. Qed.

Lemma msetUSS A B C D : A `<=` C -> B `<=` D -> A `|` B `<=` C `|` D.
Proof. by move=> /(msetSU B) /msubset_trans sAC /(msetUS C)/sAC. Qed.

Lemma msetDSS A B C D : A `<=` C -> B `<=` D -> A `+` B `<=` C `+` D.
Proof. by move=> /(msetSD B) /msubset_trans sAC /(msetDS C)/sAC. Qed.

Lemma msetIidPl {A B} : reflect (A `&` B = A) (A `<=` B).
Proof.
apply: (iffP msubsetP) => [?|<- a]; last by rewrite !msetE geq_min leqnn orbT.
by apply/msetP => a; rewrite !msetE (minn_idPl _).
Qed.

Lemma msetIidPr {A B} : reflect (A `&` B = B) (B `<=` A).
Proof. by rewrite msetIC; apply: msetIidPl. Qed.

Lemma msubsetIidl A B : (A `<=` A `&` B) = (A `<=` B).
Proof.
apply/msubsetP/msubsetP=> sAB a; have := sAB a; rewrite !msetE.
  by rewrite leq_min leqnn.
by move/minn_idPl->.
Qed.

Lemma msubsetIidr A B : (B `<=` A `&` B) = (B `<=` A).
Proof. by rewrite msetIC msubsetIidl. Qed.

Lemma msetUidPr A B : reflect (A `|` B = B) (A `<=` B).
Proof.
apply: (iffP msubsetP) => [AB|<- a]; last by rewrite !msetE leq_max leqnn.
by apply/msetP=> a; rewrite !msetE (maxn_idPr _).
Qed.

Lemma msetUidPl A B : reflect (A `|` B = A) (B `<=` A).
Proof. by rewrite msetUC; apply/msetUidPr. Qed.

Lemma msubsetUl A B : A `<=` A `|` B.
Proof. by apply/msubsetP=> a; rewrite !msetE leq_maxl. Qed.
Hint Resolve msubsetUl.

Lemma msubsetUr A B : B `<=` (A `|` B).
Proof. by rewrite msetUC. Qed.
Hint Resolve msubsetUr.

Lemma msubsetU1 x A : A `<=` (x |` A).
Proof. by rewrite msubsetUr. Qed.
Hint Resolve msubsetU1.

Lemma msubsetU A B C : (A `<=` B) || (A `<=` C) -> A `<=` (B `|` C).
Proof. by move=> /orP [] /msubset_trans ->. Qed.

Lemma eqEmsubset A B : (A == B) = (A `<=` B) && (B `<=` A).
Proof.
apply/eqP/andP => [<-|[/msubsetP AB /msubsetP BA]]; first by split.
by apply/msetP=> a; apply/eqP; rewrite eqn_leq AB BA.
Qed.

Lemma msubEproper A B : A `<=` B = (A == B) || (A `<` B).
Proof. by rewrite eqEmsubset -andb_orr orbN andbT. Qed.

Lemma mproper_sub A B : A `<` B -> A `<=` B.
Proof. by rewrite msubEproper orbC => ->. Qed.

Lemma eqVmproper A B : A `<=` B -> A = B \/ A `<` B.
Proof. by rewrite msubEproper => /predU1P. Qed.

Lemma mproperEneq A B : A `<` B = (A != B) && (A `<=` B).
Proof. by rewrite andbC eqEmsubset negb_and andb_orr andbN. Qed.

Lemma mproper_neq A B : A `<` B -> A != B.
Proof. by rewrite mproperEneq; case/andP. Qed.

Lemma eqEmproper A B : (A == B) = (A `<=` B) && ~~ (A `<` B).
Proof. by rewrite negb_and negbK andb_orr andbN eqEmsubset. Qed.

Lemma msub0set A : msubset mset0 A.
Proof. by apply/msubsetP=> x; rewrite msetE. Qed.
Hint Resolve msub0set.

Lemma msubset0 A : (A `<=` mset0) = (A == mset0).
Proof. by rewrite eqEmsubset msub0set andbT. Qed.

Lemma mproper0 A : (mproper mset0 A) = (A != mset0).
Proof. by rewrite /mproper msub0set msubset0. Qed.

Lemma mproperE A B : (A `<` B) = (A `<=` B) && ~~ (msubset B A).
Proof. by []. Qed.

Lemma mproper_sub_trans B A C : A `<` B -> B `<=` C -> A `<` C.
Proof.
move=> /andP [AB NBA] BC; rewrite /mproper (msubset_trans AB) //=.
by apply: contra NBA=> /(msubset_trans _)->.
Qed.

Lemma msub_proper_trans B A C :
  A `<=` B -> B `<` C -> A `<` C.
Proof.
move=> AB /andP [CB NCB]; rewrite /mproper (msubset_trans AB) //=.
by apply: contra NCB=> /msubset_trans->.
Qed.

Lemma msubset_neq0 A B : A `<=` B -> A != mset0 -> B != mset0.
Proof. by rewrite -!mproper0 => sAB /mproper_sub_trans->. Qed.

(* msub is a morphism *)

Lemma msetBDKC A B : A `<=` B -> A `+` (B `\` A) = B.
Proof. by move=> /msubsetP AB; apply/msetP=> a; rewrite !msetE subnKC. Qed.

Lemma msetBDK A B : A `<=` B -> B `\` A `+` A = B.
Proof. by move=> /msubsetP AB; apply/msetP => a; rewrite !msetE subnK. Qed.

Lemma msetBBK A B : A `<=` B -> B `\` (B `\` A) = A.
Proof. by move=> /msubsetP AB; apply/msetP => a; rewrite !msetE subKn. Qed.

Lemma msetBD1K A B a : A `<=` B -> A a < B a -> a +` (B `\` (a +` A)) = B `\` A.
Proof.
move=> /msubsetP AB ABa; apply/msetP => b; rewrite !msetE.
by case: ifP => //= /eqP->; rewrite !add1n subnSK.
Qed.

Lemma subset_msetBLR A B C : (msubset (A `\` B) C) = (A `<=` B `+` C).
Proof.
apply/msubsetP/msubsetP => [] sABC a;
by have := sABC a; rewrite !msetE ?leq_subLR.
Qed.

Lemma msetnP n x a : reflect (0 < n /\ x = a) (x \in msetn n a).
Proof. by do [apply: (iffP idP); rewrite !inE] => [/andP[]|[]] -> /eqP. Qed.

Lemma gt0_msetnP n x a : 0 < n -> reflect (x = a) (x \in msetn n a).
Proof. by move=> n_gt0; rewrite inE n_gt0 /=; exact: eqP. Qed.

Lemma msetn1 n a : a \in msetn n a = (n > 0).
Proof. by rewrite inE eqxx andbT. Qed.

Lemma mset1P x a : reflect (x = a) (x \in [mset a]).
Proof. by rewrite inE; exact: eqP. Qed.

Lemma mset11 a : a \in [mset a]. Proof. by rewrite inE /=. Qed.

Lemma msetn_inj n : n > 0 -> injective (@msetn K n).
Proof.
move=> n_gt0 a b eqsab; apply/(gt0_msetnP _ _ n_gt0).
by rewrite -eqsab inE n_gt0 eqxx.
Qed.

Lemma mset1UP x a B : reflect (x = a \/ x \in B) (x \in a |` B).
Proof. by rewrite !inE; exact: predU1P. Qed.

Lemma mset_cons a s : seq_mset (a :: s) = a +` (seq_mset s).
Proof. by apply/msetP=> x; rewrite !msetE /= eq_sym. Qed.

(* intersection *)

Lemma msetIP x A B : reflect (x \in A /\ x \in B) (x \in A `&` B).
Proof. by rewrite inE; apply: andP. Qed.

Lemma msetIS C A B : A `<=` B -> C `&` A `<=` C `&` B.
Proof.
move=> sAB; apply/msubsetP=> x; rewrite !msetE.
by rewrite leq_min !geq_min leqnn (msubsetP sAB) orbT.
Qed.

Lemma msetSI C A B : A `<=` B -> A `&` C `<=` B `&` C.
Proof. by move=> sAB; rewrite -!(msetIC C) msetIS. Qed.

Lemma msetISS A B C D : A `<=` C -> B `<=` D -> A `&` B `<=` C `&` D.
Proof. by move=> /(msetSI B) /msubset_trans sAC /(msetIS C) /sAC. Qed.

(* difference *)

Lemma msetSB C A B : A `<=` B -> A `\` C `<=` B `\` C.
Proof.
by move=> /msubsetP sAB; apply/msubsetP=> x; rewrite !msetE leq_sub2r.
Qed.

Lemma msetBS C A B : A `<=` B -> C `\` B `<=` C `\` A.
Proof.
by move=> /msubsetP sAB; apply/msubsetP=> x; rewrite !msetE leq_sub2l.
Qed.

Lemma msetBSS A B C D : A `<=` C -> D `<=` B -> A `\` B `<=` C `\` D.
Proof. by move=> /(msetSB B) /msubset_trans sAC /(msetBS C) /sAC. Qed.

Lemma msetB0 A : A `\` mset0 = A.
Proof. by apply/msetP=> x; rewrite !msetE subn0. Qed.

Lemma mset0B A : mset0 `\` A = mset0.
Proof. by apply/msetP=> x; rewrite !msetE sub0n. Qed.

Lemma msetBxx A : A `\` A = mset0.
Proof. by apply/msetP=> x; rewrite !msetE subnn. Qed.

(* other inclusions *)

Lemma msubsetIl A B : A `&` B `<=` A.
Proof. by apply/msubsetP=> x; rewrite msetE geq_minl. Qed.

Lemma msubsetIr A B : A `&` B `<=` B.
Proof. by apply/msubsetP=> x; rewrite msetE geq_minr. Qed.

Lemma msubsetDl A B : A `\` B `<=` A.
Proof. by apply/msubsetP=> x; rewrite msetE leq_subLR leq_addl. Qed.

Lemma msubD1set A x : A `\ x `<=` A.
Proof. by rewrite msubsetDl. Qed.

Hint Resolve msubsetIl msubsetIr msubsetDl msubD1set.

(* cardinal lemmas for msets *)

Lemma mem_mset1U a A : a \in A -> a |` A = A.
Proof.
rewrite in_mset => aA; apply/msetP => x; rewrite !msetE (maxn_idPr _) //.
by have [->|//] := altP eqP; rewrite (leq_trans _ aA).
Qed.

Lemma mem_msetD1 a A : a \notin A -> A `\ a = A.
Proof.
move=> /mset_eq0P aA; apply/msetP => x; rewrite !msetE.
by have [->|] := altP eqP; rewrite ?aA ?subn0.
Qed.

Lemma msetIn a A n : A `&` msetn n a = msetn (minn (A a) n) a.
Proof.
by apply/msetP => x; rewrite !msetE; have [->|] := altP eqP; rewrite ?minn0.
Qed.

Lemma msubIset A B C : (B `<=` A) || (C `<=` A) -> (B `&` C `<=` A).
Proof. by case/orP; apply: msubset_trans; rewrite (msubsetIl, msubsetIr). Qed.

Lemma msubsetI A B C : (A `<=` B `&` C) = (A `<=` B) && (A `<=` C).
Proof.
rewrite !(sameP msetIidPl eqP) msetIA; have [-> //| ] := altP (A `&` B =P A).
by apply: contraNF => /eqP <-; rewrite -msetIA -msetIIl msetIAC.
Qed.

Lemma msubsetIP A B C : reflect (A `<=` B /\ A `<=` C) (A `<=` B `&` C).
Proof. by rewrite msubsetI; exact: andP. Qed.

Lemma msubUset A B C : (B `|` C `<=` A) = (B `<=` A) && (C `<=` A).
Proof.
apply/idP/idP => [subA|/andP [AB CA]]; last by rewrite -[A]msetUid msetUSS.
by rewrite !(msubset_trans _ subA).
Qed.

Lemma msubUsetP A B C : reflect (A `<=` C /\ B `<=` C) (A `|` B `<=` C).
Proof. by rewrite msubUset; exact: andP. Qed.

Lemma msetU_eq0 A B : (A `|` B == mset0) = (A == mset0) && (B == mset0).
Proof. by rewrite -!msubset0 msubUset. Qed.

Lemma setD_eq0 A B : (A `\` B == mset0) = (A `<=` B).
Proof. by rewrite -msubset0 subset_msetBLR msetD0. Qed.

Lemma msub1set A a : ([mset a] `<=` A) = (a \in A).
Proof.
apply/msubsetP/idP; first by move/(_ a); rewrite msetnxx in_mset.
by move=> ainA b; rewrite msetnE; case: eqP => // ->; rewrite -in_mset.
Qed.

Lemma msetDBA A B C : C `<=` B -> A `+` B `\` C = (A `+` B) `\` C.
Proof.
by move=> /msubsetP CB; apply/msetP=> a; rewrite !msetE2 addnBA.
Qed.

Lemma mset_0Vmem A : (A = mset0) + {x : K | x \in A}.
Proof.
have [/fsetP Aisfset0 | [a ainA]] := fset_0Vmem (finsupp A); last first.
  by right; exists a; rewrite -msuppE.
left; apply/msetP => a; rewrite mset0E; apply/mset_eq0P.
by rewrite -msuppE Aisfset0 inE.
Qed.

Definition size_mset A : size A = \sum_(a <- finsupp A) A a.
Proof. by rewrite -sum1_size sum_mset; apply: eq_bigr => i; rewrite muln1. Qed.

Lemma size_mset0 : size (mset0 : {mset K}) = 0.
Proof. by rewrite -sum1_size big_mset0. Qed.

From mathcomp Require Import tuple.

Lemma sum_nat_seq_eq0 (I : eqType) r (P : pred I) (E : I -> nat) :
   (\sum_(i <- r | P i) E i == 0) = all [pred i | P i ==> (E i == 0)] r.
Proof.
rewrite big_tnth sum_nat_eq0; apply/forallP/allP => /= HE x.
  by move=> /seq_tnthP[i ->]; apply: HE.
by apply: HE; rewrite mem_tnth.
Qed.

Lemma size_mset_eq0 A : (size A == 0) = (A == mset0).
Proof.
apply/idP/eqP => [|->]; last by rewrite size_mset0.
rewrite size_mset sum_nat_seq_eq0 => /allP AP.
apply/msetP => a /=; rewrite msetE.
by have /= := AP a; case: finsuppP => // _ /(_ _)/eqP->.
Qed.

End MSetTheory.


From mathcomp Require Import all_ssreflect.
Require Import Labyrinth.

Module ExtractedLabyrinthOCaml.
  Require Import Coq.extraction.ExtrOcamlBasic.
  Require Import Coq.extraction.ExtrOcamlNatInt.
  Extract Inductive simpl_fun => "(->)" ["(fun f -> f)"].
  Extract Constant simpl_pred "'a" => "'a -> bool".
  Extract Inlined Constant fun_of_simpl => "(fun f -> f)".
  Extract Inlined Constant pred_of_simpl => "(fun f -> f)".
  Extract Inlined Constant predT => "(fun x -> true)".

  Example small_grammar := (result_grammar small_free small_goal small_start).
  Example small_upto10 := (result_terms_mapped small_free small_goal small_start 10).

  Example big_grammar (x: unit) := (result_grammar big_free big_goal big_start).
  Example big_upto10 (x: unit) := (result_terms_mapped big_free big_goal big_start 10).
End ExtractedLabyrinthOCaml.

Extraction Language OCaml.
Extraction "extracted/ExtractedLabyrinth.ml" ExtractedLabyrinthOCaml.


From Undecidability.L Require Import Tactics.LTactics Datatypes.LNat Datatypes.LTerm.

Class decodable X `{encodable X}: Type :=
  {
    decode : term -> option X;
    decode_correct : forall (x:X), decode (enc x) = Some x;
    decode_correct2 : forall (t : term) (x : X), decode t = Some x -> enc x = t
  }.

Arguments decodable : clear implicits.
Arguments decode    : clear implicits.

Arguments decodable _ {_}.
Arguments decode _ {_} {_} _ : simpl never.

Instance decode_nat : decodable nat.
Proof.
  exists nat_unenc. all:eauto using LNat.unenc_correct, LNat.unenc_correct2.
Defined. (* because instance *)

Import L_Notations.

Fixpoint term_decode (s : term) :=
  match s with
  | lam (lam (lam (app 2 n))) =>
    match decode nat n with
      Some n => Some (var n)
    | _ => None
    end
  |  lam (lam (lam (app (app 1 s1) s2))) =>
     match term_decode s1,term_decode s2 with
       Some s1, Some s2 => Some (s1 s2)
     | _,_ => None
     end
  | lam (lam (lam (app O s))) =>
    match term_decode s with
      Some s => Some (lam s)
    | _ => None  end
  | _ => None
  end.

Instance decode_term : decodable term.
Proof.
  exists term_decode.
  -unfold enc at 1;cbn. induction x;cbn.
   +rewrite (decode_correct n). congruence.
   +now rewrite IHx1,IHx2.
   +now rewrite IHx.  all:eauto using LNat.unenc_correct, LNat.unenc_correct2.
  -apply (size_induction (f := size) (p := (fun t => forall x : term, term_decode t = Some x -> enc x = t))). intros t IHt s.
   destruct t eqn:eq. all:cbn.
   all:repeat let eq := fresh in destruct _ eqn:eq. all:try congruence.
   all:intros [= <-].
   +unfold enc;cbn. erewrite IHt.
    *reflexivity.
    *cbn;lia.
    *easy.
   +unfold enc;cbn. erewrite decode_correct2. 2:eassumption.  reflexivity.
   +unfold enc;cbn. erewrite !IHt. reflexivity.
    1,3:cbn;lia.
    all:eassumption.
Defined. (* because instance *)

From Undecidability.L Require Import Datatypes.Lists.
Import L.
Definition list_decode X `{decodable X} :=
  fix list_decode (s : term) : option (list X) :=
    match s with
    | lam (lam 1) => Some []
    | lam (lam (L.app (L.app O x) xs)) =>
      match decode X x,list_decode xs with
        Some x, Some xs => Some (x::xs)
      | _,_ => None
      end
    | _ => None
    end.

Arguments list_decode : clear implicits.
Arguments list_decode _ {_ _} _.

Instance decode_list X `{encodable X} {Hdec:decodable X}: decodable (list X).
Proof.
  exists (list_decode X).
  -unfold enc;cbn. induction x;cbn.
   +easy.
   +setoid_rewrite decode_correct. now rewrite IHx.
  -apply (size_induction (f := size) (p := (fun t => forall x, list_decode X t = Some x -> enc x = t))). intros t IHt s.
   destruct t eqn:eq. all:cbn.
   all:repeat let eq := fresh in destruct _ eqn:eq. all:try congruence.
   all:intros [= <-].
   +easy.
   +unfold enc;cbn. erewrite decode_correct2. 2:easy.
    erewrite IHt.
    *reflexivity.
    *cbn;lia.
    *easy.
Defined. (* because instance *)

From Undecidability.L Require Import Datatypes.LProd.

Definition prod_decode X Y `{decodable X} `{decodable Y} (s : term) : option (X*Y) :=
    match s with
    | lam (app (app 0 x) y) =>
      match decode X x,decode Y y with
        Some x, Some y => Some (x,y)
      | _,_ => None
      end
    | _ => None
    end.

Arguments prod_decode : clear implicits.
Arguments prod_decode _ _ {_ _ _ _}.

Instance decode_prod X Y `{decodable X} `{decodable Y}: decodable (X*Y).
Proof.
  exists (prod_decode X Y).
  all:unfold enc at 1. all:cbn.
  -intros [];cbn.
   +repeat setoid_rewrite decode_correct. easy.
  -destruct t eqn:eq. all:cbn.
   all:repeat let eq := fresh in destruct _ eqn:eq. all:try congruence.
   all:intros ? [= <-]. cbn.
   setoid_rewrite decode_correct2;[|eassumption..]. easy.
Defined. (* because instance *)

From Undecidability.L Require Import Datatypes.LSum.
Definition sum_decode X Y `{decodable X} `{decodable Y} (s : term) : option (X + Y) :=
  match s with
  | lam (lam (app 1 x)) =>
      match decode X x with
      | Some x => Some (inl x)
      | _ => None
      end
  | lam (lam (app 0 y)) =>
      match decode Y y with
      | Some y => Some (inr y)
      | _ => None
      end
  | _ => None
  end.

Arguments sum_decode : clear implicits.
Arguments sum_decode _ _ {_ _ _ _}.

Instance decode_sum X Y `{decodable X} `{decodable Y} : decodable (X + Y).
Proof.
  exists (sum_decode X Y).
  all:unfold enc at 1; cbn.
  -intros [];cbn; repeat setoid_rewrite decode_correct; easy.
  -destruct t eqn:eq. all:cbn.
   all:repeat let eq := fresh in destruct _ eqn:eq. all:try congruence.
   all:intros ? [= <-]; cbn.
   all: setoid_rewrite decode_correct2;[|eassumption..]; easy.
Defined. (* because instance *)

From Undecidability.L Require Import Datatypes.LOptions.

Definition option_decode X `{decodable X} (s : term) : option (option X) :=
  match s with
  | lam (lam (app 1 x)) =>
    match decode X x with
      Some x => Some (Some x)
    | _ => None
    end
  | lam (lam 0) => Some None
  | _ => None
  end.

Arguments option_decode : clear implicits.
Arguments option_decode _ {_ _} _.

Instance decode_option X `{encodable X} {Hdec:decodable X}: decodable (option X).
Proof.
  exists (option_decode X).
  -unfold enc;cbn. intros[];cbn. 2:easy. setoid_rewrite decode_correct. easy.
  -destruct t eqn:eq. all:cbn.
   all:repeat let eq := fresh in destruct _ eqn:eq. all:try congruence.
   all:intros ? [= <-].
   +easy.
   +unfold enc;cbn. erewrite decode_correct2. all:easy.
Defined.  (* because instance *)

From Undecidability.L Require Import Datatypes.LBool.

Definition bool_decode (s : term) : option bool:=
  match s with
  | lam (lam 1) => Some true
  | lam (lam 0) => Some false
  | _ => None
  end.

Instance decode_bool: decodable (bool).
Proof.
  exists (bool_decode).
  all:unfold enc at 1. all:cbn.
  -intros[];cbn. all:easy.
  -destruct t eqn:eq. all:cbn.
   all:repeat let eq := fresh in destruct _ eqn:eq. all:try congruence.
   all:intros ? [= <-]. all:easy.
Defined. (* because instance *)

From Undecidability.L Require Import Datatypes.LUnit.

Definition unit_decode (s : term) : option unit :=
  match s with
  | lam 0 => Some tt
  | _ => None
  end.

Instance decode_unit : decodable unit.
Proof.
  exists unit_decode.
  - intros []. cbn. easy.
  - destruct t eqn:Heq; cbn.
    all:repeat let eq := fresh in destruct _ eqn:eq. all:try congruence.
    intros ? [= <-]. easy.
Defined. (* because instance *)


Generalizable All Variables.
Set Implicit Arguments.

Require Import
        Coq.Lists.List
        Coq.Strings.String
        Coq.Arith.Arith
        Fiat.Common.ilist
        Fiat.Common.ilist2.

Section i2list2.

(* Lists of elements whose types depend on a pairs of indexing set
     (CPDT's hlists). *)

  Variable A : Type. (* The indexing type. *)
  Variable B B' : A -> Type. (* The type of indexed elements. *)
  Variable C : forall a, B a -> B' a -> Type. (* The type of doubly-indexed elements. *)

  Record prim_prod_3 A B C :=
    { prim_3_fst : A;
      prim_3_snd : B;
      prim_3_thd : C }.

  Import Vectors.VectorDef.VectorNotations.

  Fixpoint i2list2 {n}
           (l : Vector.t A n)
           (il1 : ilist (B := B) l)
           (il2 : ilist (B := B') l) : Type :=
    match l return ilist (B := B) l
                   -> ilist (B := B') l
                   -> Type with
    | Vector.nil =>
      fun il1 il2 => unit
    | Vector.cons a n' l =>
      fun il1 il2 =>
        @prim_prod (C (prim_fst il1) (prim_fst il2))
                   (i2list2 l (prim_snd il1) (prim_snd il2))
    end il1 il2.

  Definition i2cons2
             {a : A}
             {n}
             {l : Vector.t A n}
             (b1 : B a)
             (il1 : ilist (B := B) l)
             (b2 : B' a)
             (il2 : ilist (B := B') l)
             (c : C b1 b2)
             (i2l' : i2list2 l il1 il2)
  : i2list2 (a :: l) (icons b1 il1) (icons b2 il2)
    := {| prim_fst := c; prim_snd := i2l' |}.

  Definition inil : i2list2 [] inil inil := tt.

  (* Get the car of an i2list2. *)

  Definition i2list2_hd {n} {As : Vector.t A n}
             {il1 : ilist (B := B) As}
             {il2 : ilist (B := B') As}
             (i2l : i2list2 As il1 il2) :
    match As return
          forall
            (il1 : ilist (B := B) As)
            (il2 : ilist (B := B') As),
            i2list2 As il1 il2 -> Type with
    | Vector.cons a _ As' =>
      fun Bs Bs' i2l => C (ilist_hd Bs) (ilist_hd Bs')
    | Vector.nil => fun _ _ _ => unit
    end il1 il2 i2l :=
    match As return
          forall il1 il2 i2l,
            match As return
                  forall
                    (il1 : ilist (B := B) As)
                    (il2 : ilist (B := B') As),
                    i2list2 As il1 il2 -> Type with
            | Vector.cons a _ As' =>
              fun Bs Bs' i2l => C (ilist_hd Bs) (ilist_hd Bs')
          | Vector.nil => fun _ _ _ => unit
            end il1 il2 i2l
    with
    | Vector.cons a _ As' =>
      fun il1 il2 i2l => prim_fst i2l
    | Vector.nil => fun _ _ _ => tt
    end il1 il2 i2l.

  (* Get the cdr of an i2list2. *)
  Definition i2list2_tl {n}
             {As : Vector.t A n}
             {il1 : ilist (B := B) As}
             {il2 : ilist (B := B') As}
             (i2l : i2list2 As il1 il2) :
    match As return
          forall
            (il1 : ilist (B := B) As)
            (il2 : ilist (B := B') As),
            i2list2 As il1 il2 -> Type with
    | Vector.cons a _ As' =>
      fun Bs Bs' i2l => i2list2 _ (ilist_tl Bs) (ilist_tl Bs')
    | Vector.nil => fun _ _ _ => unit
    end il1 il2 i2l :=
    match As return
          forall il1 il2 i2l,
            match As return
                  forall
                    (il1 : ilist (B := B) As)
                    (il2 : ilist (B := B') As),
                    i2list2 As il1 il2 -> Type with
            | Vector.cons a _ As' =>
              fun Bs Bs' i2l => i2list2 _ (ilist_tl Bs) (ilist_tl Bs')
          | Vector.nil => fun _ _ _ => unit
            end il1 il2 i2l
    with
    | Vector.cons a _ As' =>
      fun il1 il2 i2l => prim_snd i2l
    | Vector.nil => fun _ _ _ => tt
    end il1 il2 i2l.

  Fixpoint i2th2
             {m : nat}
             {As : Vector.t A m}
             (il1 : ilist (B := B) As)
             (il2 : ilist (B := B') As)
             (i2l : i2list2 As il1 il2)
             (n : Fin.t m)
  : C (ith il1 n) (ith il2 n) :=
    match n in Fin.t m return
          forall (As : Vector.t A m)
                 (il1 : ilist (B := B) As)
                 (il2 : ilist (B := B') As),
            i2list2 _ il1 il2
            -> C (ith il1 n) (ith il2 n) with
      | Fin.F1 k =>
        fun As =>
          Vector.caseS (fun n As =>
                          forall (il1 : ilist (B := B) As)
                                 (il2 : ilist (B := B') As),
                            i2list2 As il1 il2
                            -> C (ith il1 (@Fin.F1 n))
                              (ith il2 (@Fin.F1 n)))
                       (fun h n t il1 il2 i2l => i2list2_hd i2l) As
      | Fin.FS k n' =>
        fun As =>
          Vector_caseS' Fin.t
                        (fun n As n' =>
                           forall (il1 : ilist (B := B) As)
                                  (il2 : ilist (B := B') As),
                             i2list2 As il1 il2
                             -> C (ith il1 (@Fin.FS n n'))
                               (ith il2 (@Fin.FS n n')))
                        (fun h n t m il1 il2 i2l =>
                           i2th2 (ilist_tl il1)
                                 (ilist_tl il2)
                                 (i2list2_tl i2l) m)
                        As n'
    end As il1 il2 i2l.

  (*
  (* Membership in a doubly-indexed list. *)
  Inductive i2list2_In
  : forall {a : A} {b : B a} {b' : B' a}
           (c : C b b') (As : list A)
           (il : ilist B As)
           (il' : ilist B' As)
           (i2l : i2list2 il il'), Prop :=
  | In2_hd : forall a' As
                    (Bs : ilist B (a' :: As))
                    (Bs' : ilist B' (a' :: As))
                    (i2l : i2list2 (ilist_tl Bs) (ilist_tl Bs')) c,
               i2list2_In c (i2cons2 Bs Bs' c i2l)
  | In2_tl : forall a a' As
                    (Bs : ilist B (a' :: As))
                    (Bs' : ilist B' (a' :: As))
                    (b : B a) (b' : B' a) c'
                    (i2l : i2list2 (ilist_tl Bs) (ilist_tl Bs'))
                    (c : C b b'),
               i2list2_In c i2l ->
               i2list2_In c (i2cons2 Bs Bs' c' i2l).

  (* Looking up the ith value, returning None for indices not in the list *)
  (* A doubly-dependent option. *)

  Fixpoint i2th_error2'
          (As : list A)
          (Bs : ilist B As)
          (Bs' : ilist B' As)
          (i2l : i2list2 Bs Bs')
          (n : nat)
          {struct n}
  : Dep_Option_elim_T2 C (ith_error Bs n) (ith_error Bs' n) :=
    match n as n' return
          forall (Bs : ilist B As)
                 (Bs' : ilist B' As),
            i2list2 Bs Bs'
            -> Dep_Option_elim_T2 C (ith_error Bs n') (ith_error Bs' n')
    with
      | 0 =>
        fun Bs Bs' i2l =>
          match i2l as i2l' in i2list2 Bss Bss' return
                Dep_Option_elim_T2 C (ith_error Bss 0) (ith_error Bss' 0) with
            | i2nil2 _ _ => tt
            | i2cons2 a As' Bss Bss' c i2l' => c
          end
      | S n => fun Bs Bs' i2l =>
                 match i2l as i2l' in i2list2 Bss Bss' return
                       Dep_Option_elim_T2 C (ith_error Bss (S n))
                                          (ith_error Bss' (S n)) with
                   | i2nil2 _ _ => tt
                   | i2cons2 a As' Bss Bss' c i2l' => i2th_error2' i2l' n
                 end
    end Bs Bs' i2l.

  (* Looking up the ith value, returning a default value
     for indices not in the list.
  Fixpoint i2th_default2
          (default_A : A)
          (default_B : B default_A)
          (default_C : C default_B)
          (As : list A)
          (Bs : ilist B As)
          (i2l : i2list2 Bs)
          (n : nat)
          {struct As}
  : C (ith2_default default_A default_B Bs n) :=
    match As as As', n as n' return
          forall (Bs' : ilist B As'),
            i2list2 Bs'
            -> C (ith2_default default_A default_B Bs' n') with
      | a :: As', 0    => @i2list2_hd (a :: As')
      | a :: As', S n' => fun il i2l => i2th_default2 default_C (i2list2_tl i2l) n'
      | nil      , 0    => fun il i2l => default_C
      | nil      , S n' => fun il i2l => default_C
    end Bs i2l.

  Lemma i2list2_invert (As : list A) (Bs : ilist B As) (Cs : i2list2 Bs):
    match Bs as Bs' return i2list2 Bs' -> Prop with
      | icons2 a As b Bs' => fun Cs =>
                           exists (c : C b) (Cs' : i2list2 Bs'),
                             Cs = i2cons2 (icons2 a b Bs') c Cs'
      | inil2 => fun Cs => Cs = i2nil2 (inil2 _)
    end Cs.
  Proof.
    destruct Cs.
    - destruct (ilist_invert Bs) as [b [Bs' Bs'_eq]]; subst.
      eexists; eauto.
    - pose (ilist_invert Bs) as Bs_eq; simpl in Bs_eq; subst; eauto.
  Qed.

  Lemma i2th_default2_In :
    forall (n : nat)
           (As : list A)
           (Bs : ilist B As)
           (Cs : i2list2 Bs)
           (default_A : A)
           (default_B : B default_A)
           (default_C : C default_B),
      n < List.length As ->
      i2list2_In (i2th_default2 default_C Cs n) Cs.
  Proof.
    ith2_induction n As; simpl;
    destruct (i2list2_invert Cs) as [c [Cs' Cs_eq]]; subst; simpl;
    [apply (In2_hd (icons2 a b il) Cs' c) |  constructor 2];
    eauto with arith.
  Qed.

  Lemma i2th_default2_indep :
    forall (n : nat)
           (As : list A)
           (Bs : ilist B As)
           (Cs : i2list2 Bs)
           (default_A : A)
           (default_B : B default_A)
           (default_C default_C' : C default_B),
      n < List.length As ->
      i2th_default2 default_C Cs n = i2th_default2 default_C' Cs n.
  Proof.
    ith_induction n As; simpl; eauto with arith.
  Qed. *)
 *)
End i2list2.
(*
Section i2list2_replace.

  (* Replacing an element of an indexed list. *)
  Variable A : Type. (* The indexing type. *)
  Variable B : A -> Type. (* The two types of indexed elements. *)
  Variable C : forall a, B a -> Type. (* The type of doubly-indexed elements. *)

  Program Fixpoint replace_2Index2
           (n : nat)
           (As : list A)
           (Bs : ilist B As)
           (Cs : i2list2 C Bs)
           (new_c : Dep_Option_elim_P C (ith2_error Bs n))
           {struct Bs} : i2list2 C Bs :=
    match n return
            i2list2 C Bs
            -> Dep_Option_elim_P C (ith2_error Bs n)
            -> i2list2 C Bs with
      | 0 => match Bs return
                     i2list2 C Bs
                     -> Dep_Option_elim_P C (ith2_error Bs 0)
                     -> i2list2 C Bs with
                 | inil2 =>
                   fun il _ => i2nil2 _ _
                 | icons2 a b As' Bs' =>
                   fun Cs' new_c =>
                     i2cons2 _ new_c (i2list2_tl Cs')
               end
      | S n => match Bs return
                     i2list2 C Bs
                     -> Dep_Option_elim_P C (ith2_error Bs (S n))
                     -> i2list2 C Bs with
                 | inil2 => fun il _ => i2nil2 _ _
                 | icons2 a As' b Bs' =>
                   fun Cs' new_c =>
                     i2cons2 _ (i2list2_hd Cs')
                            (@replace_2Index2 n As' Bs'
                                             (i2list2_tl Cs') new_c)
               end
    end Cs new_c.

  Lemma i2th_replace2_Index_neq
  : forall
      (n : nat)
      (As : list A)
      (Bs : ilist _ As)
      (Cs : i2list2 C Bs)
      (n' : nat)
      (new_c : Dep_Option_elim_P C (ith2_error Bs n')),
      n <> n'
      -> i2th_error2 (replace_2Index2 n' Cs new_c) n =
         i2th_error2 Cs n.
  Proof.
    induction n; simpl; destruct Bs; intros; icons2_invert;
    simpl in *; auto;
    destruct n'; simpl; try congruence.
    eapply IHn; congruence.
  Qed.

  Lemma i2th_replace2_Index_eq
  : forall
      (n : nat)
      (As : list A)
      (Bs : ilist _ As)
      (Cs : i2list2 C Bs)
      (new_c : Dep_Option_elim_P C (ith2_error Bs n)),
      i2th_error2 (replace_2Index2 n Cs new_c) n = new_c.
  Proof.
    induction n; destruct Bs; simpl; auto; intros;
    destruct new_c; eauto.
  Qed.

  Program Fixpoint replace_2Index2'
           (n : nat)
           (As : list A)
           (Bs : ilist B As)
           (Cs : i2list2 C Bs)
           (new_c : Dep_Option_elim_P C (ith2_error Bs n))
           {struct Cs} : i2list2 C Bs :=
    match n return
          Dep_Option_elim_P C (ith2_error Bs n)
            -> i2list2 C Bs with
      | 0 => match Cs in i2list2 _ Bs return
                   Dep_Option_elim_P C (ith2_error Bs 0)
                   -> i2list2 C Bs with
                 | i2nil2 Bs =>
                   fun _ => i2nil2 _ Bs
                 | i2cons2 a As' Bs' c i2l' =>
                   fun new_c =>
                     i2cons2 Bs' new_c i2l'
               end
      | S n => match Cs in i2list2 _ Bs return
                     Dep_Option_elim_P C (ith2_error Bs (S n))
                     -> i2list2 C Bs with
                 | i2nil2 Bs => fun _ => i2nil2 _ Bs
                 | i2cons2 a As' Bs' c i2l' =>
                   fun new_c =>
                     i2cons2 Bs' c (@replace_2Index2' n As' (ilist_tl Bs') i2l' new_c)
               end
    end new_c.

  Lemma i2th_replace_2Index2'_neq
  : forall
      (n : nat)
      (As : list A)
      (Bs : ilist _ As)
      (Cs : i2list2 C Bs)
      (n' : nat)
      (new_c : Dep_Option_elim_P C (ith2_error Bs n')),
      n <> n'
      -> i2th_error2' (replace_2Index2' n' Cs new_c) n =
         i2th_error2' Cs n.
  Proof.
    induction n; simpl; destruct Cs; intros; icons2_invert;
    simpl in *; auto;
    destruct n'; simpl; try congruence.
    unfold replace_2Index2.
    eapply IHn; congruence.
  Qed.

  Lemma i2th_replace_2Index2'_eq
  : forall
      (n : nat)
      (As : list A)
      (Bs : ilist _ As)
      (Cs : i2list2 C Bs)
      (new_c : Dep_Option_elim_P C (ith2_error Bs n)),
      i2th_error2' (replace_2Index2' n Cs new_c) n = new_c.
  Proof.
    induction n; destruct Cs; simpl; auto; intros;
    destruct new_c; eauto.
  Qed.

End i2list2_replace. *)


Inductive T {A} : Prop := c : A -> T.
Goal (@T nat).
apply c. exact 0.
Qed.


Require Import Program.Basics.

Open Scope program_scope.

(* typeclass and laws *)

Class Functor (f : Type -> Type) :=
{ fmap {A B} (g : A -> B) : f A -> f B }.

Class FunctorDec f `{Functor f} :=
{ functor_id : forall A (fa : f A), fmap id fa = fa
; functor_comp :
    forall A B C (h : A -> B) (g : B -> C) (fa : f A),
      (fmap g ∘ fmap h) fa = fmap (g ∘ h) fa
}.

(* theorems *)

Lemma fmap_eq : forall {A B m} (f g : A -> B) (ma : m A) `{Functor m},
  f = g -> fmap f ma = fmap g ma.
Proof.
  intros.
  now rewrite H0.
Qed.


(*|
###################################################
How to dependent match on a list with two elements?
###################################################

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

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

I'm trying to understand dependent types and dependent match in Coq, I
have the code below, at the bottom I have the ``add_pair`` function,
the idea is that I want to receive a (dependent) list with exactly two
elements and return the sum of the two elements in the list. Since the
size of the list is encoded in the type, I should be able to define it
as a total function, but I got an error saying that the ``match`` is
not ``exaustive``

Here is the code
|*)

Set Implicit Arguments.

Module IList.
Section Lists.
  (* o tipo generico dos elementos da lista *)
  Variable A : Set.

  (* data type da lista, recebe um nat que é
       o tamanho da lista *)
  Inductive t : nat -> Set :=
  | nil : t 0                 (* lista vazia, n = 0 *)
  | cons : forall (n : nat), A -> t n -> t (S n). (* cons de uma lista
                                              n = n + 1 *)
  (* concatena duas listas, n = n1 + n2 *)
  Fixpoint concat n1 (ls1 : t n1) n2 (ls2 : t n2) : t (n1 + n2) :=
    match ls1 in t n1 return t (n1 + n2) with
    | nil => ls2
    | cons x ls1' => cons x (concat ls1' ls2)
    end.

  (* computar o tamanho da lista é O(1) *)
  Definition length n (l : t n) : nat := n.
End Lists.
Arguments nil {_}.

(* Isso aqui serve pra introduzir notações pra gente poder
     falar [1;2;3] em vez de (cons 1 (cons 2 (cons 3 nil))) *)
Module Notations.
  Notation "a :: b" := (cons a b) (right associativity, at level 60) : list_scope.
  Notation "[ ]" := nil : list_scope.
  Notation "[ x ]" := (cons x nil) : list_scope.
  Notation "[ x ; y ; .. ; z ]" := (cons x (cons y .. (cons z nil) ..)) : list_scope.
  Open Scope list_scope.
End Notations.
Import Notations.

(* Error: Non exhaustive pattern-matching: no clause found for pattern [_] *)
Fail Definition add_pair (l : t nat 2) : nat :=
  match l in (t _ 2) return nat with
  | (cons x (cons y nil)) => x + y
  end. (* .fails *)

End IList.

(*|
Answer
******

Indeed, it is true that the match you provided is exhaustive, but the
pattern-matching algorithm of Coq is limited, and not able to detect
it. The issue, I think, is that it compiles a nested pattern-matching
such as yours (you have two imbricated ``cons``) down to a successions
of elementary pattern-matching (which have patterns of depth at most
one). But in the ``cons`` branch of the outer ``match``, the
information that the index should be ``1`` is lost if you do not
record it explicitly with an equality --- something the current
algorithm is not smart enough to do.

As a possible solution that avoids fiddling with impossible branches,
equalities, and the like, I propose the following:
|*)

Import IList. (* .none *)
Definition head {A n} (l : t A (S n)) : A :=
  match l with
  | cons x _ => x
  end.

Definition tail {A n} (l : t A (S n)) : t A n :=
  match l with
  | cons _ l' => l'
  end.

Definition add_pair (l : t nat 2) : nat :=
  head l + (head (tail l)).

(*|
----

For the record, a solution that *does* fiddle with the impossible
branches and records the information of the index using equalities
(there's probably a nicer version):

.. coq:: none
|*)

Reset head.

Require Import Lia.

Import Notations.

(*||*)

Definition add_pair (l : t nat 2) : nat :=
  match l in t _ m return m = 2 -> nat with
  | [] => fun e => ltac:(lia)
  | x :: l' => fun e =>
                 match l' in t _ m' return m' = 1 -> nat with
                 | [] => fun e' => ltac:(lia)
                 | x' :: l'' => fun e' =>
                                  match l'' in t _ m'' return m'' = 0 -> nat with
                                  | [] => fun _ => x + x'
                                  | _ => fun e'' => ltac:(lia)
                                  end ltac:(lia)
                 end ltac:(lia)
  end eq_refl.

(*|
The interesting part is the use of explicit equalities to record the
value of the index (these are used by the ``lia`` tactic to discard
impossible branches).

----

**Q:** Thank you, this is so cool! I didn't know that you can discard
impossible branches using ltac and never saw this ``ltac:...``, thank
you so much!

**Q:** The ``ltac:(lia)`` after ``end`` are the application of the
``fun e => ...`` functions returned by the match?

**A:** Yes! They are used to generate the right equalities from the
one available in context. For instance the lowest one constructs a
proof of ``m = 1`` from the proof of ``S m = 2`` available in context
(``e``).
|*)


Require Import trees.

Definition sizeDef := FunDef "size" ["t"]
 (SIf ("t" = 0)
      (SReturn 0)
      (SReturn (1 + ECall "size" ["t"->>"left"]
                  + ECall "size" ["t"->>"right"])))%code.

Inductive size_spec : Spec kcfg :=
  size_claim : forall H t p, heap_fun size_spec nil
  sizeDef [Int p] (asP H (rep_tree t p))
  (fun r => constraint (r = size t) :* litP H)%pattern.

Lemma size_proof : sound kstep size_spec.
Proof. tree_solver. Qed.


From PA Require Import ProgramAlgebra.
Import Nat.
Import List.
Require Import String.
Import ListNotations.

Variable bot : Type.

Record MyVar := mkVar {
  id: string;
  val : nat;
}.

Definition eqVarb (x y : MyVar) :=
  andb (eqb x.(id) y.(id)) (PeanoNat.Nat.eqb x.(val) y.(val)).

Definition GLOBVARS := [(mkVar "a" 10);(mkVar "b" 4)].

Definition UNDEF := mkVar "Undefined" 0.

Instance myParams : ProgramAlgebra.UserParams :=
  ProgramAlgebra.Build_UserParams MyVar GLOBVARS eqVarb.

Axiom equalGLOB : GLOBVARS = ProgramAlgebra.GLOBVARS.

Axiom equalB : eqVarb = ProgramAlgebra.eqb.

Notation "|-| l" := (ProgramAlgebra.Choice_of_Alg_List l)(at level 20).

Notation "_|_" := (ProgramAlgebra.Chaos)(at level 10).

Notation "@{ e }" := (fun x => ProgramAlgebra.Assn x e)(at level 10).

Definition eqz_b : ProgramAlgebra.Boolexp :=
  fun l =>
    match (find (fun x => eqb x.(id) "b") l) with
    | Some x => if (PeanoNat.Nat.eqb x.(val) 0) then false else true
    | _ => false
    end.

Definition gcd_step := ProgramAlgebra.makeAssign ProgramAlgebra.GLOBVARS
  (fun l =>
   match (find (fun x => eqb x.(id) "a") l),
    (find (fun x => eqb x.(id) "b") l) with
   | Some x, Some y => [(mkVar x.(id) y.(val));(mkVar y.(id) (modulo x.(val) y.(val)))]
   | _, _ => []
   end).

Definition skip := ProgramAlgebra.makeAssign ProgramAlgebra.GLOBVARS
  (fun l => l).

Fixpoint mapid {s} (x : ProgramAlgebra.Alg s) :=
  match x with
  | ProgramAlgebra.Assn _ a => @{a} (ProgramAlgebra.Alg s)
  | ProgramAlgebra.Choice _ P Q =>
     ProgramAlgebra.Choice (ProgramAlgebra.Alg s) (mapid P) (mapid Q)
  | ProgramAlgebra.Chaos _ => _|_ (ProgramAlgebra.Alg s)
  | ProgramAlgebra.Seq _ P Q =>
     ProgramAlgebra.Choice (ProgramAlgebra.Alg s) (mapid P) (mapid Q)
  | ProgramAlgebra.Cond _ P b Q =>
     ProgramAlgebra.Cond (ProgramAlgebra.Alg s) (mapid P) b (mapid Q)
  | ProgramAlgebra.Recur _ f => _|_ (ProgramAlgebra.Alg s)
  end.

Definition testIter {s} (x : ProgramAlgebra.Alg s) :=
  ProgramAlgebra.Seq (ProgramAlgebra.Alg s)
  (mapid x) (ProgramAlgebra.Cond (ProgramAlgebra.Alg s)
     (@{gcd_step} (ProgramAlgebra.Alg s)) eqz_b
     (@{skip} (ProgramAlgebra.Alg s))).

Definition testRec := ProgramAlgebra.Recur (ProgramAlgebra.Alg bot) testIter.

Definition testnf := @{ ProgramAlgebra.makeAssign ProgramAlgebra.GLOBVARS
  (fun l => [(mkVar "a" 2);(mkVar "b" 0)]) } bot.

Variable lub : ProgramAlgebra.Closure -> ProgramAlgebra.Ualg.

Example testlim : testIter testnf = testRec .
Proof. unfold testRec. rewrite ProgramAlgebra.Recur_clos with (lub := lub).
rewrite ProgramAlgebra.fix_is_lub with (lub := lub);auto.
unfold ProgramAlgebra.RecurFix. unfold testnf. eexists. split.
unfold testIter. unfold skip. unfold gcd_step.
rewrite ProgramAlgebra.Assign_Cond. unfold mapid.
rewrite ProgramAlgebra.Assign_compose. reflexivity.
unfold eqz_b. unfold ProgramAlgebra.exp_Cond.
simpl. unfold ProgramAlgebra.eqEval. auto.
Qed.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable cong_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable betS_ : Universe -> Universe -> Universe -> Prop.

Variable cn_congruencereflexive_1 : (forall A B : Universe, cong_ A B A B).
Variable lemma_congruencesymmetric_2 : (forall A B C D : Universe, (cong_ B C A D -> cong_ A D B C)).
Variable lemma_interior5_3 : (forall A B C D Xa Xb Xc Xd : Universe, ((betS_ A B C /\ (betS_ Xa Xb Xc /\ (cong_ A B Xa Xb /\ (cong_ B C Xb Xc /\ (cong_ A D Xa Xd /\ cong_ C D Xc Xd))))) -> cong_ B D Xb Xd)).
Variable axiom_nocollapse_4 : (forall A B C D : Universe, ((A <> B /\ cong_ A B C D) -> C <> D)).

Theorem lemma_4_19_5 : (forall A B C D : Universe, ((betS_ A D B /\ (cong_ A C A D /\ cong_ B D B C)) -> C = D)).
Proof.
  time tac.
Qed.

End FOFProblem.


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

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

Print Assumptions mul.


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

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

Print Assumptions mul.


Require Import Essentials.Notations.
Require Import Essentials.Types.
Require Import Essentials.Facts_Tactics.
Require Import Essentials.HoTT_Facts.
Require Import Category.Main.
Require Import Functor.Functor.
Require Import Coq_Cats.Type_Cat.Type_Cat.
Require Import Ext_Cons.Prod_Cat.Prod_Cat.

Definition HomType {C : Category} (x y : C) : hSet.
Proof.
  refine (@BuildTruncType _ (x –≻ y)%morphism _).
  apply Hom_HSet.
Defined.

(** The hom-functor is a functor that maps a pair of objects (a, b) (an object of the product category Cᵒᵖ×C) to the type of arrows from a to b. *)
Definition Hom_Func (C : Category) : (((C^op) × C) –≻ Type_Cat)%functor.
Proof.
  refine
    (
      @Build_Functor
        ((C^op) × C)
        Type_Cat
        (fun x => @HomType C (fst x) (snd x))
        (fun x y f g => compose C (fst f) ((@compose (C^op) _ _ _) (snd f) g))
        _
        _
    ); cbn in *; auto
  .
Defined.


Unset Elimination Schemes.
(* Switches off automatic generation of eliminators *)

Definition iffT (X Y: Type) : Type := (X -> Y) * (Y -> X).
Notation "X <=> Y" := (iffT X Y) (at level 95, no associativity).

Module Definitions.
  Inductive sum (X Y: Type) : Type :=
  | L: X -> sum X Y
  | R: Y -> sum X Y.
  Arguments L {X Y}.
  Arguments R {X Y}.

  Definition match_sum {X Y Z: Type}
    : sum X Y -> (X -> Z) -> (Y -> Z) -> Z
    := fun a e1 e2 => match a with L x => e1 x | R y => e2 y end.

  Definition elim_sum {X Y: Type} (p: sum X Y -> Type)
    : (forall x, p (L x)) -> (forall y, p (R y)) -> forall a, p a
    := fun e1 e2 a => match a with L x => e1 x | R y => e2 y end.

  Fact L_injective (X Y: Type) (x x': X) :
    L (Y:= Y) x = L x' -> x = x'.
  Proof.
    intros H.
    change (match_sum (Y:= Y) (L x) (fun x => x) (fun _ => x) = x').
    rewrite H.
    reflexivity.
  Qed.

  Inductive sig {X: Type} (p: X -> Type) : Type :=
  | E : forall x: X, p x -> sig p.
  Arguments E {X p}.

  Definition match_sig {X: Type} {p: X -> Type} {Z: Type}
    : sig p -> (forall x, p x -> Z) -> Z
    := fun a e => match a with E x c => e x c end.

  Definition elim_sig {X: Type} {p: X -> Type} (q: sig p -> Type)
    : (forall x c, q (E x c)) -> forall a, q a
    := fun e a => match a with E x c => e x c end.

  Definition pi1 {X: Type} {p: X -> Type}
    : sig p -> X
    := fun a => match a with E x _ => x end.

  Definition pi2 {X: Type} {p: X -> Type}
    : forall a: sig p,  p (pi1 a)
    := fun a => match a with E x c => c end.

  Definition skolem X Y (p: X -> Y -> Type) :
    (forall x, sig (p x)) <=> sig (fun f => forall x, p x (f x)).
  Proof.
    split.
    - intros F.
      exists (fun x => pi1 (F x)).
      intros x. exact (pi2 (F x)).
    - intros a.
      apply (match_sig a).
      intros f H x.
      exists (f x). apply H.
  Defined.

  (* Construction done at term level *)
  Definition skolem' X Y (p: X -> Y -> Type) :
    (forall x, sig (p x)) <=> sig (fun f => forall x, p x (f x)).
  Proof.
    refine (_,_).
    - unshelve refine (fun F => E _ _).
      + exact (fun x => pi1 (F x)).
      + exact (fun x => pi2 (F x)).
    - refine (fun a => (match_sig a (fun f h x => _))).
      cbn in h.
      exact (E (f x) (h x)).
  Defined.

  Goal forall X (p: X -> Type),
      @pi1 X p = elim_sig (fun _ => X) (fun x c => x).
  Proof.
    cbv. reflexivity.
  Qed.

  Goal forall X (p: X -> Type),
      @pi2 X p = elim_sig (fun a => p (pi1 a)) (fun x c => c).
  Proof.
    reflexivity.
  Qed.

  Fact eta X (p: X -> Type) :
    forall a: sig p, E (pi1 a) (pi2 a) = a.
  Proof.
    (* cannot be shown with match_sig *)
    refine (elim_sig _ _).
    cbn. reflexivity.
  Qed.

  Fact match_sum' X Y :
    forall a: sum X Y, sig (fun x => a = L x) + sig (fun y => a = R y).
  Proof.
    apply elim_sum.
    - intros x. left. exists x. reflexivity.
    - intros y. right. exists y. reflexivity.
  Qed.

  Fact pi1_injective X (p: X -> Type) x (c: p x) x' (c': p x') :
    E x c = E x' c' -> x = x'.
  Proof.
  intros H.
  change x with (pi1 (E x c)).
  rewrite H. reflexivity.
  Qed.

  Fail
    Fact pi2_injective X (p: X -> Type) x (c: p x) x' (c': p x') :
    E x c = E x' c' -> c = c'.

  Fact pi2_injective X (p: X -> Type) x (c c': p x) :
    E x c = E x c' -> c = c'.
  Proof.
    intros H.
    change c with (pi2 (E x c)).
    Fail pattern (E x c).
    Fail rewrite H.
  Abort.

End Definitions.

(*** Predefined Sum and Sigma Types *)

Locate "+".
Print sum.

(** We use customized notation for the predefined sigma types *)
Print sigT.
Notation sig := sigT.
Notation Sig := existT.
Notation pi1 := projT1.
Notation pi2 := projT2.
Notation "'Sigma' x .. y , p" :=
  (sigT (fun x => .. (sigT (fun y => p)) ..))
    (at level 200, x binder, right associativity,
     format "'[' 'Sigma'  '/  ' x  ..  y ,  '/  ' p ']'")
  : type_scope.

Module ProductAsSigma.
Section M.
  Variables X Y: Type.
  Definition p: X -> Type := fun _=>  Y.
  Definition f
    : X * Y -> sig p
    := fun a => Sig p (fst a) (snd a).
  Definition g
    : sig p -> X * Y
    := fun a => match a with Sig _ x c => (x, c) end.

  Fact gf_eq a :
    g (f a) = a.
  Proof.
    destruct a as [x y]. reflexivity.
  Qed.
  Fact fg_eq a :
    f (g a) = a.
  Proof.
    destruct a as [x y]. reflexivity.
  Qed.
End M.
End ProductAsSigma.

Module SumAsSigma.
Section M.
  Variables X Y: Type.
  Definition p: bool -> Type := fun b => if b then X else Y.
  Definition f
    : X + Y -> sig p
    := fun a => match a with
             | inl x => Sig p true x
             | inr y => Sig p false y
             end.
  Definition g
    : sig p -> X + Y
    := fun a => match a with
             | Sig _ true x => inl x
             | Sig _ false y => inr y
             end.

  Fact gf_eq a :
    g (f a) = a.
  Proof.
    destruct a as [x|y]; reflexivity.
  Qed.
  Fact fg_eq a :
    f (g a) = a.
  Proof.
    destruct a as [[|] z]; reflexivity.
  Qed.
End M.
End SumAsSigma.

(*** Skolem *)

Definition skolem X Y (p: X -> Y -> Type) :
  (forall x, Sigma y, p x y) <=> (Sigma f, forall x, p x (f x)).
Proof.
  split.
  - intros F.
    exists (fun x => pi1 (F x)).
    intros x.  exact (pi2 (F x)).
  - intros [f F] x.
    exists (f x). exact (F x).
Defined.

Fact sig_eta X (p: X -> Type) :
  forall a, a = Sig p (pi1 a) (pi2 a).
Proof.
  intros [x H]. cbn. reflexivity.
Qed.

Fact skolem_prop_bool Y (p: bool -> Y -> Prop) :
  (forall x, exists y, p x y) <=> (exists f, forall x, p x (f x)).
Proof.
  split.
  - intros F.
    destruct (F true) as [y1 H1].
    destruct (F false) as [y2 H2].
    exists (fun x: bool => if x then y1 else y2).
    destruct x; assumption.
  - intros [f H] x. exists (f x). apply H.
Qed.

Fact skolem_prop_prop X (Y: Prop) (p: X -> Y -> Prop) :
  (forall x, exists y, p x y) <=> (exists f, forall x, p x (f x)).
Proof.
  split.
  - intros F.
    exists (fun x => let (y,_) := F x in y).
    intros x. destruct (F x) as [y H]. exact H.
  - intros [f H] x. exists (f x). apply H.
Qed.

Module Ex_eta.
Section M.
  Variables (P: Prop) (p: P -> Prop).
  Definition pi1 (a: ex p) : P :=
    match a with ex_intro _ x c => x end.
  Definition pi2 (a: ex p) : p (pi1 a) :=
    match a with ex_intro _ x c => c end.
  Goal forall a, a = ex_intro p (pi1 a) (pi2 a).
  Proof.
    intros [x a]. reflexivity.
  Qed.
End M.
End Ex_eta.

(*** Equality Decider *)

Definition eqdec :
  forall x y: nat, (x = y) + (x <> y).
Proof.
  induction x as [|x IH]; destruct y.
  - left. reflexivity.
  - right. intros [=].
  - right. intros [=].
  - destruct (IH y) as [H|H].
    + left. f_equal. exact H.
    + right. intros [= <-]. easy.
Defined.

Definition eqb (x y: nat) : bool :=
  if eqdec x y then true else false.

(* sum_rect is the predefined eliminator for sums *)

Fact eqb_correct x y :
    eqb x y = true <-> x = y.
Proof.
  unfold eqb.
  pattern (eqdec x y).
  apply sum_rect.
  - tauto.
  - intuition congruence.
Qed.

Fact eqb_correct' x y :
    eqb x y = true <-> x = y.
Proof.
  apply (sum_rect (fun a => (if a then true else false) = true <-> x = y)).
  - tauto.
  - intuition congruence.
Qed.

(* using destruct is more convenient *)

Fact eqb_correct'' x y :
    eqb x y = true <-> x = y.
Proof.
  unfold eqb.
  destruct eqdec as [H|H].
  - tauto.
  - intuition congruence.
Qed.

(*** Distance *)

Definition distance :
  forall x y: nat, Sigma z, sum (x + z = y) (y + z = x).
Proof.
  induction x as [|x IH]; cbn.
  - intros y. exists y. auto.
  - destruct y; cbn.
    + exists (S x). auto.
    + specialize (IH y) as [z [<-|<-]];
        exists z; auto.
Defined.

Compute
  let d := distance 17 4 in
  (pi1 d, if pi2 d then true else false).

From Coq Require Import Lia.

Section Distance.
  Variable D: forall x y: nat, Sigma z, sum (x + z = y) (y + z = x).

  Fact D_sub x y :
      x - y = if pi2 (D x y) then 0 else pi1 (D x y).
  Proof.
    destruct (D x y) as [z [<-|<-]]; cbn; lia.
  Qed.

  Fact D_pi1 x y :
      pi1 (D x y) = (x - y) + (y - x).
  Proof.
    destruct (D x y) as [z [<-|<-]]; cbn; lia.
  Qed.

  Goal pi1 (D 3 7) = 4.
  Proof.
    rewrite D_pi1. reflexivity.
  Qed.
End Distance.

(*** Division by 2 *)

Definition Div_two :
  forall x, Sigma n, sum (x = n * 2) (x = S ( n * 2)).
Proof.
  induction x as [|x IH]; cbn.
  - exists 0. left. reflexivity.
  - destruct IH as [n [-> | ->]]; cbn.
    + exists n; cbn. right. reflexivity.
    + exists (S n); cbn. left. reflexivity.
Defined.

Definition div_two (x: nat) : nat * nat :=
  let (n,a) := Div_two x in (n, if a then 0 else 1).

Compute div_two 15.

Section Div_two.
  Variable D: forall x, Sigma n, sum (x = n * 2) (x = S ( n * 2)).
  Definition d (x: nat) : nat * nat :=
    let (n,a) := D x in (n, if a then 0 else 1).

  Fact d_correct x :
    let  (n,k) := d x in
    x = k + n*2 /\ (k = 0 \/ k = 1).
  Proof.
    unfold d.
    destruct (D x) as [n [-> | ->]]; cbn; auto.
  Qed.
End Div_two.

(*** Ackermann *)

Definition ack : nat -> nat -> nat.
Proof.
  induction 1 as [|x IHx].
  - exact S.
  - induction 1 as [|y IHy].
    + exact (IHx 1).
    + exact (IHx IHy).
Defined.

Goal forall x y, ack (S x) (S y) = ack x (ack (S x) y).
Proof.
  reflexivity.
Qed.

(*** Inhabitation *)

Print inhabited.

Goal forall P Q, P \/ Q <-> inhabited (P + Q).
Proof.
  split.
  - intros [a|b]; constructor; auto.
  - intros [[a|b]]; auto.
Qed.

Goal forall X (p: X -> Prop), ex p <-> inhabited (sig p).
Proof.
  split.
  - intros [x H]. constructor. eauto.
  - intros [[x H]]. eauto.
Qed.

Fact inhabited_equi X :
  inhabited X <=> exists x:X, True.
Proof.
  split.
  - intros [x]. exists x. exact I.
  - intros [x _]. constructor. exact x.
Qed.

Goal forall X (p: X -> Prop), ~ ~ex p <-> ~(sig p -> False).
Proof.
  split.
  - intros H. contradict H. intros [x H1]. eauto.
  - intros H. contradict H. intros [x H1]. eauto.
Qed.

Goal forall P Q, ~ ~(P \/ Q) <-> ~(P + Q -> False).
Proof.
  split.
  - intros H. contradict H. intros [a|a]; eauto.
  - intros H. contradict H. intros [a|a]; eauto.
Qed.

Module Choice.
  Arguments existT {A P}.
  Implicit Types X Y: Type.
  Implicit Type P: Sigma X, X -> Prop.

  Definition choice X Y :=
    forall p: X -> Y -> Prop, (forall x, ex (p x)) -> exists f, forall x, p x (f x).
  Definition wo X :=
    forall p: X -> Prop, ex p -> sig p.

  Fact wo2choice :
    inhabited (forall X, wo X) -> forall X Y, choice X Y.
  Proof.
    intros [W] X Y p F.
    exists (fun x => pi1 (W Y (p x) (F x))).
    intros x.
    destruct (W Y (p x) (F x)) as [y pxy].
    exact pxy.
  Qed.

  Fact choice2wo :
    (forall X Y, choice X Y) -> inhabited (forall X, wo X).
  Proof.
    intros C.
    destruct (C (Sigma P, ex (pi2 P))
                (Sigma P, sig (pi2 P))
                (fun a b => pi1 a = pi1 b))
      as [f H].
    - intros [[X p] [x px]]. cbn in *.
      exists (Sig (Sig X p) (Sig x px)). reflexivity.
    - constructor. intros X p exp.
      generalize (H (Sig (Sig X p) exp)). cbn.
      destruct f as [P sigP]. cbn. intros <-. exact sigP.
  Qed.

  Goal (forall X Y, choice X Y) <-> inhabited (forall X, wo X).
  Proof.
    split.
    - apply choice2wo.
    - Fail apply wo2choice.
      (* There is a universe conflict *)
  Abort.
End Choice.

(*** Bijections *)

Definition inv {X Y: Type} (g: Y -> X) (f: X -> Y) := forall x, g (f x) = x.

Inductive bijection (X Y: Type) : Type :=
| Bijection: forall (f: X -> Y) (g: Y -> X), inv g f -> inv f g -> bijection X Y.
Arguments Bijection {X Y}.

Fact bijection_trans X Y Z :
  bijection X Y -> bijection Y Z -> bijection X Z.
Proof.
  intros [f g H1 H2] [f' g' H1' H2'].
  exists (fun x => f' (f x)) (fun z => g (g' z)).
  - intros z. rewrite H1'. apply H1.
  - intros x. rewrite H2. apply H2'.
Qed.

Definition bijection_prod X Y :
  bijection (X * Y) (sig (fun x: X => Y)).
Proof.
  unshelve eexists.
  - intros [x y]. exists x. exact y.
  - intros [x y]. exact (x,y).
  - intros [x y]. reflexivity.
  - intros [x y]. reflexivity.
Defined.

Definition bijection_sum X Y :
  bijection (X + Y) (sig (fun b: bool => if b then X else Y)).
Proof.
  unshelve eexists.
  - intros [x|y].
    + exists true. exact x.
    + exists false. exact y.
  - intros [[] z].
    + left. exact z.
    + right. exact z.
  - intros [x|y]; reflexivity.
  - intros [[] z]; reflexivity.
Defined.

Definition bij_bij_sig X Y:
  bijection (bijection X Y) (Sigma f g, @inv X Y g f /\ inv f g).
Proof.
  unshelve eexists.
  - intros [f g H1 H2]. exists f, g. exact (conj H1 H2).
  - intros (f&g&H1&H2). exact (Bijection f g H1 H2).
  - intros [f g H1 H2]. reflexivity.
  - intros (f&g&H1&H2). reflexivity.
Defined.

Goal bijection nat bool -> False.
Proof.
  intros [f g H _].
  (* Challenge: There is a two line proof using lia. *)
Abort.

(*** Products and sums are universe polymorphic *)

Check prod True True.
Check prod bool bool.
Check prod Prop Prop.
Check sum True True.
Check sum bool bool.
Check sum Prop Prop.

Fact bijection_refl X :
  bijection X X.
Proof.
  exists (fun x => x) (fun x => x); easy.
Qed.

Fact bijection_sym X Y :
  bijection X Y -> bijection Y X.
Proof.
  intros [f g H1 H2]. exists g f; assumption.
Qed.

Fixpoint Num n : Type :=
  match n with
  | 0 => False
  | S n' => option (Num n')
  end.

Fact bijection_Num_void n :
  bijection (Num 0) (Num (S n)) -> False.
Proof.
  intros [f g H1 H2]. contradiction (g None).
Qed.

Fact bijection_Num_void2 n :
  bijection (Num 1) (Num (S (S n))) -> False.
Proof.
  intros [f g H1 H2].
  enough (H: g None = g (Some None)).
  { apply (f_equal f) in H. rewrite !H2 in H. discriminate H. }
  destruct g as [[]|], g as [[]|]. reflexivity.
Qed.

Definition lower {X Y} (f: option X -> option Y)
  : Y -> X -> Y
  := fun y0 x => match (f (Some x)) with
              | Some y => y
              | None => y0
              end.

Fact lower_inv X Y f g (x0: X) (y0: Y) :
  inv g f -> f None = Some y0 -> g None = Some x0 ->  inv (lower g x0) (lower f y0).
Proof.
  intros H H1 H2 x. unfold lower at 2.
  destruct (f (Some x)) as [y|] eqn:E1; unfold lower.
  - rewrite <-E1, H. reflexivity.
  - rewrite <-H1, H. congruence.
Qed.

Fact lower_inv_None X Y (f : option (option X) -> option (option Y)) g :
  inv g f -> g None = None -> inv (lower g None) (lower f None).
Proof.
  intros H H1 x. unfold lower at 2.
  destruct (f (Some x)) as [y|] eqn:E1; unfold lower.
  - rewrite <-E1, H. reflexivity.
  - exfalso. congruence.
Qed.

Lemma num_agree m n :
  bijection (Num m ) (Num n) -> m = n.
Proof.
  induction m as [|m IH] in n |-*;  destruct n; cbn.
  - easy.
  - intros [] %bijection_Num_void.
  - intros [] %bijection_sym %bijection_Num_void.
  - intros H. f_equal. apply IH. clear IH.
    destruct m, n.
    + apply bijection_refl.
    + exfalso. apply bijection_Num_void2 in H. exact H.
    + exfalso. apply bijection_sym, bijection_Num_void2 in H. exact H.
    + destruct H as [f g H1 H2].
      destruct (f None) as [y0|] eqn:E1, (g None) as [x0|] eqn:E2.
      * exists (lower f y0) (lower g x0); apply lower_inv; assumption.
      * exfalso. congruence.
      * exfalso. congruence.
      * exists (lower f None) (lower g None); apply lower_inv_None; assumption.
Qed.


From Ordinal Require Import sflib.

Require Import Coq.Classes.RelationClasses Coq.Relations.Relation_Operators Coq.Classes.Morphisms Coq.Init.Wf. (* TODO: Use Morphisms *)

Set Implicit Arguments.
Set Primitive Projections.

Theorem cantor_theorem A (f: A -> (A -> Prop)):
  exists P, forall a, f a <> P.
Proof.
  exists (fun a => ~ (f a) a). ii.
  cut (~ f a a).
  { ii. eapply H0. rewrite H. auto. }
  { ii. dup H0. rewrite H in H0. apply H0. apply H1. }
Qed.

Lemma clos_trans_well_founded
      A (R: A -> A -> Prop) (WF: well_founded R)
  :
    well_founded (clos_trans_n1 _ R).
Proof.
  ii. hexploit (well_founded_induction WF (fun a1 => forall a0 (LT: clos_trans_n1 A R a0 a1 \/ a0 = a1), Acc (clos_trans_n1 A R) a0)).
  { clear a. intros a1 IH. i. econs. i. des.
    - inv LT.
      + eapply IH; eauto.
      + eapply IH; eauto. left.
        eapply Operators_Properties.clos_trans_tn1. econs 2.
        * eapply Operators_Properties.clos_tn1_trans; eauto.
        * eapply Operators_Properties.clos_tn1_trans; eauto.
    - subst. inv H; eauto.
  }
  { right. reflexivity. }
  { eauto. }
Qed.

Lemma well_founded_irreflexive A (R: A -> A -> Prop) (WF: well_founded R)
      a
      (LT: R a a)
  :
    False.
Proof.
  hexploit (well_founded_induction WF (fun a' => ~ (a' = a))).
  { ii. des; clarify. eapply H; eauto. }
  i. eapply H. eauto.
Qed.

Lemma acc_incl A (R0 R1: A -> A -> Prop) (INCL: forall a0 a1 (LE: R0 a0 a1), R1 a0 a1)
      a (ACC: Acc R1 a)
  :
    Acc R0 a.
Proof.
  induction ACC. econs. i. eapply H0; eauto.
Qed.

Lemma wf_incl A (R0 R1: A -> A -> Prop) (INCL: forall a0 a1 (LE: R0 a0 a1), R1 a0 a1)
      (WF: well_founded R1)
  :
    well_founded R0.
Proof.
  econs. i. eapply acc_incl; eauto.
Qed.

Lemma bot_well_founded A: @well_founded A (fun _ _ => False).
Proof.
  ii. econs; ss.
Qed.

Lemma Fix_equiv
      A (R : A -> A -> Prop) (Rwf : well_founded R)
      (B: Type) (eqv: B -> B -> Prop)
      (F : forall x, (forall y, R y x -> B) -> B)
      (EQ: forall x (f g : forall y, R y x -> B),
          (forall y (p0 p1: R y x), eqv (f y p0) (g y p1)) -> eqv (F x f) (F x g))
  :
  forall x,
    eqv (Fix Rwf (fun _ => B) F x) (F x (fun (y : A) (_ : R y x) => Fix Rwf (fun _ => B) F y)).
Proof.
  cut (forall x (p0 p1: Acc R x), eqv (Fix_F (fun _ => B) F p0) (Fix_F (fun _ => B) F p1)).
  { i. unfold Fix. rewrite <- Fix_F_eq. eapply EQ. i. eapply H. }
  intros x. pattern x. revert x. eapply (well_founded_induction Rwf).
  i. rewrite <- Fix_F_eq. rewrite <- Fix_F_eq.
  eapply EQ. i. eapply H. auto.
Qed.

Variant double_rel A B (RA: A -> A -> Prop) (RB: B -> B -> Prop)
  : A * B -> A * B -> Prop :=
| double_rel_left a0 a1 b (LT: RA a0 a1): double_rel RA RB (a0, b) (a1, b)
| double_rel_right a b0 b1 (LT: RB b0 b1): double_rel RA RB (a, b0) (a, b1)
.

Lemma double_rel_well_founded A B (RA: A -> A -> Prop) (RB: B -> B -> Prop)
      (WFA: well_founded RA) (WFB: well_founded RB)
  :
  well_founded (double_rel RA RB).
Proof.
  cut (forall a b, Acc (double_rel RA RB) (a, b)).
  { ii. destruct a as [a b]. eapply H. }
  intros a0. pattern a0. revert a0.
  eapply (well_founded_induction WFA).
  intros a0 IHL. intros b0. pattern b0. revert b0.
  eapply (well_founded_induction WFB).
  intros b0 IHR. econs. intros [a1 b1]. i. inv H.
  { eapply IHL; eauto. }
  { eapply IHR; eauto. }
Qed.

Lemma double_well_founded_induction A B (RA: A -> A -> Prop) (RB: B -> B -> Prop)
      (WFA: well_founded RA) (WFB: well_founded RB)
      (P: A -> B -> Prop)
      (IND: forall a1 b1
                   (IHL: forall a0 (LT: RA a0 a1), P a0 b1)
                   (IHR: forall b0 (LT: RB b0 b1), P a1 b0),
          P a1 b1)
  :
  forall a b, P a b.
Proof.
  cut (forall ab, P (fst ab) (snd ab)).
  { i. apply (H (a, b)). }
  intros ab. pattern ab. revert ab.
  eapply (well_founded_induction (double_rel_well_founded WFA WFB)).
  intros [a b] ?. ss. eapply IND.
  { i. eapply (H (a0, b)). econstructor 1. auto. }
  { i. eapply (H (a, b0)). econstructor 2. auto. }
Qed.