(**************************************************************************
* TLC: A library for Coq                                                  *
* Demos for Containers, in particular finite maps                         *
**************************************************************************)

Set Implicit Arguments.
Generalizable Variables A B.
From TLC Require Import LibTactics LibLogic LibReflect LibOption
  LibRelation LibLogic LibOperation LibEpsilon LibMonoid LibSet
  LibContainer LibMap.

Local Open Scope set_scope.

(* ********************************************************************* *)
(** * Introduction *)

(* Assume a type of keys, call it [int] *)

Parameter int : Type.

(** Assume a type of values, called [val], that's inhabited. *)

Parameter val : Type.
Parameter Inhab_val : Inhab val.
#[global]
Existing Instance Inhab_val.

(* ********************************************************************** *)
(** * Basic usage of map operations *)

Module Basic.

(** We can use a map from [int] to [val], and read in that map *)

Definition my_read (m:map int val) (i:int) :=
  m[i].

(** We can also write a value in the map; it does not matter whether
    the key already existed or not. *)

Definition my_write (m:map int val) (i:int) (v:val) :=
  m[i := v].

(** To reason about a read, we can use the lemma [read_update]. *)

Lemma my_read_write : forall (m:map int val) (i j:int) (v:val),
  m[i := v][j] = (If i = j then v else m[j]).
Proof using.
  intros. rewrite read_update. auto.
Qed.

(** Sometimes we need to talk about the domain of a map.
    [dom m] is a [set] of keys, in the sense of LibSet's [set].
    For example, to assert that two maps have the same domain. *)

Definition my_same_dom (m1 m2:map int val) :=
  dom m1 = dom m2.

(** To assert that one key is valid for a domain, we use
    [i \in (dom m)], which is shortened to [i \indom m].
    The latter is a notation for [(x \in (dom m : set _))],
    with the annotation to help the typechecker. *)

Definition my_indom (m:map int val) (i:int) :=
  i \indom m.

(** Similarly, the notation [x \notindom m] is available. *)

(** In an inductive definition, it is commonplace to assert
    that [i] is in the domain of [m] and that [M[i] = v].
    The binds predicate captures the conjunction of these
    two facts. The definition can be unfolded using the
    following rewriting rule. *)

Parameter binds_eq_indom_read : forall A `{Inhab B} (M:map A B) x v,
  (binds M x v) = (x \indom M /\ M[x] = v).

(** Other operations on maps involve:
    - empty map [(\{} : map A B)]. The type annotation is often required.
    - union of maps [m1 \u m2]
    - removal of a set of keys [m \- E]
    - removal of a key [m \-- i], equivalent to [m \- \{i}]
    - map_reduce w.r.t. a function and a monoid, e.g.
      [fold (monoid_make plus zero) f m], which computes
      [f k1 v1 + f k2 v2 + ... + f kn vn + 0].
    - inclusion [m1 \c m2] is not yet defined, but should be soon. *)

(** Lemmas for reasoning about maps can be found in two places:
    in [LibMap.v] and in [LibContainer.v]. The latter contains
    generic lemmas, that are shared by several data structures,
    such as sets and maps. The typeclass mechanism used for the
    sharing is explained next. *)

End Basic.

(* ********************************************************************** *)
(** * Implementation of maps *)

Module Internal.

(** Finite maps are implemented using the typeclasses defined in
    LibContainer. The internal implementation is: *)

Definition map (A B : Type) := A -> option B.

(** The internal definition of [read] in a map is thus a function
    that applies the map to the index. When the result is [None]
    it returns an arbitrary value. *)

Definition read_impl A `{Inhab B} (M:map A B) (k:A) :=
  match M k with
  | None => arbitrary
  | Some v => v
  end.

(** Doing so requires the type [B] to be inhabited. Let's look at
    the error message that we get when trying to work with a map
    on a type that's not inhabited. *)

(* Uncomment below to see the error message, saying that an instance
   for [BagRead int ?B (map int B)]. The message does not say it,
   but it complains in fact that [Inhab B] could not be found.
   We'll understand why the message is like so further on. *)

(*
Definition my_failed_read B (m:map int B) (i:int) :=
  m[i].
*)

(** The notation [m[i]] is defined in [LibContainer.v] as
    [read m i]. *)

Notation "m [ i ]" := (read m i).

(** The operation [read] is a typeclass. It applies to any
    data structure of type [T] on which a read operation can
    be performed using keys of type [A] to extract a value of
    type [B]. *)

Class BagRead A B T := { read : T -> A -> B }.

(** Note that the type of [read] is:
    [forall A B T {I:BagRead A B T}, T -> A -> B].
    In other words, [read] must be applied to an
    "instance" of the typeclass [BagRead], and then
    the result is a read function for that instance.
    We'll see further on what this means. *)

(** The connection between [read_impl] for type [map] and
    the generic [read] operation is performed through an
    instance declaration: *)

#[global]
Instance read_inst : forall A `{IB:Inhab B}, BagRead A B (map A B).
Proof. constructor. applys (@read_impl A B IB). Defined.

(** In the light of this, let's inspect the interpretation of [m[i]].
    It means [@read int val (map int val) read_inst m i]. *)

Definition my_read (m:map int val) (i:int): val :=
  m[i].

(** You can activate [Set Printing All] or menu
    ["Display all level-level contents" from the view menu in CoqIDE]
    to see the low-level interpretation. *)

(*
Print my_read.
*)

(** What happens during type-checking is that [read_inst] gets
    automatically inferred by the typeclass mechanism, based on the
    type of [m]. In other words, before type inference, Coq sees:
    [@read _ _ _ _ m i]. From the type of [m], it deduces
    [@read _ _ (map int val) (_:BagRead _ _ (map int val)) m i].
    From typeclass resolution, it finds out that [read_inst] is the
    instance that could fill in the argument with type
    [BagRead _ _ (map int val)]. *)

(** Now, we can see that the instance inferred is
    [@LibMap.read_inst int val Inhab_val].
    This instance refers to the instance asserting that [val] is
    inhabited. When such an assumption about the result type cannot
    be found, then the [read_inst] instance cannot be synthesized. *)

(** We can investigate the resolution process manually as follows. *)

Lemma test_resolution_1 : BagRead int val (map int val).
Proof using. typeclass. (* short for: [eauto with typeclass_instances.] *) Qed.

Lemma test_resolution_2 : Inhab val.
Proof using. typeclass. Qed.

Lemma test_resolution_3 : forall B, Inhab B.
Proof using. intros. try typeclass. (* resolution fails *) Abort.

Lemma test_resolution_4 : BagRead int val (map int val).
Proof using. (* execute:
   debug eauto with typeclass_instances. *) Abort.

Lemma test_resolution_5 : forall B, BagRead int B (map int B).
Proof using.
  (* execute:

    intros.
    debug eauto with typeclass_instances.
    (* shows that eauto is stuck after [apply read_inst] *)
    apply read_inst.
    debug eauto with typeclass_instances.
    (* shows that eauto is stuck on this subgoal. *)

  *)
Abort.

(** The file [LibContainer.v] contains generic lemmas. For example
    [union_empty_r] asserts that [m \u \{} = m]. This lemma is
    stated for any data structure of type [T] that features an
    empty and a union operation. *)

Class Union_empty_r (T:Type) {BE: BagEmpty T} {BU: BagUnion T} :=
  { union_empty_r : forall X, union empty X = X }.

(** The proof that [map] validates the lemma [union_empty_r] is
    derived from the fact that it validates the lemma [union_empty_l]
    and commutativity of union *)

Global Instance union_empty_r_of_union_empty_l (T:Type) {BE: BagEmpty T} {BU: BagUnion T} :
  Union_empty_l -> Union_comm -> Union_empty_r.
Abort.

(** The proof that [map] validates [union_empty_l] is itself derived
    from another lemma, called [union_empty_l_of_in_union_eq_and_in_empty_eq].
    More details can be found in [LibContainerDemo], but it is not needed
    to understand the full setup to use the lemmas over maps.] *)

(** The point is that [rewrite union_empty_r] is a tactic that rewrites
    [m \u \{} = m] for any data structure [m] over which the statement
    of this equality makes sense. *)

End Internal.


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

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

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

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

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

Fixpoint append (append_arg0 : lst) (append_arg1 : lst) : lst
           := match append_arg0, append_arg1 with
              | Nil, x => x
              | Cons x y, z => Cons x (append y z)
              end.

Fixpoint len (len_arg0 : lst) : natural
           := match len_arg0 with
              | Nil => Zero
              | Cons x y => Succ (len y)
              end.

Fixpoint rev (rev_arg0 : lst) : lst
           := match rev_arg0 with
              | Nil => Nil
              | Cons x y => append (rev y) (Cons x Nil)
              end.

Lemma lem : forall l1 l2 n, Succ (len (append l1 l2)) = len (append l1 (Cons n l2)).
Proof.
  induction l1.
  - intros. simpl. f_equal. apply IHl1.
  - intros. reflexivity.
Qed.

Lemma lem2 : forall l, len l = len (append l Nil).
Proof.
  induction l.
  - simpl. f_equal. apply IHl.
  - reflexivity.
Qed.

Theorem theorem0 : forall (x : lst), eq (len (rev x)) (len x).
Proof.
induction x.
  - simpl.  rewrite <- IHx. lfind.
Admitted.


Require Import List.
Require Import Arith.
Import ListNotations.

Section SkipList.
Variable A : Type.

Inductive skip_list : Type :=
  | nil : skip_list
  | cons : A -> skip_list -> skip_list
  | skip : nat -> skip_list -> skip_list.
(* I feel evil after writing this definition *)

Fixpoint list2skip_list (l : list A) : skip_list :=
  match l with
  | [] => nil
  | h :: t => cons h (list2skip_list t)
  end.

Fixpoint skip_list2list (s : skip_list) : list A :=
  match s with
  | nil => []
  | cons h t => h :: skip_list2list t
  | skip n l => skipn n (skip_list2list l)
  end.

Theorem skip_list2list_id : forall (l : list A),
  skip_list2list (list2skip_list l) = l.
Proof.
  induction l.
  - trivial.
  - simpl.
    rewrite IHl.
    reflexivity.
Qed.

End SkipList.

Definition serializer (A: Type) := A -> list bool.
Definition deserializer (A: Type) := list bool -> option (A * nat).
Definition ser_deser_spec (A: Type) (ser : serializer A) (deser : deserializer A) :=
  forall a : A, forall bools : list bool,
      deser (ser a ++ bools) = Some (a, length (ser a)).

Class Serializer (A : Type) : Type :=
  {
    serialize : A -> list bool;
    deserialize : list bool -> option (A * nat);
    deser_ser_identity : ser_deser_spec A serialize deserialize
  }.

(* I couldn't find a suitable theorem in the coq standard library *)
Theorem skipn_length : forall (A : Type) (l1 l2 : list A),
  skipn (length l1) (l1 ++ l2) = l2.
Proof.
induction l1; intros.
- trivial.
- simpl.
  apply IHl1.
Qed.

Section NatSerializer.

Fixpoint nat_serialize (n : nat) : list bool :=
  match n with
  | O => [false]
  | S n => [true] ++ (nat_serialize n)
  end.

Fixpoint nat_deserialize (bools : list bool) : option (nat * nat) :=
  match bools with
  | true :: bools =>
    match (nat_deserialize bools) with
    | None => None
  (* Remark: n = remaining + 1 here for this specific deser/ser pair *)
    | Some (n, amt) => Some (S n, S amt)
    end
  | false :: bools => Some (O, 1)
  | [] => None
  end.

Theorem nat_ser_deser_identity :
  ser_deser_spec nat nat_serialize nat_deserialize.
Proof.
  unfold ser_deser_spec.
  induction a; intros.
  - trivial.
  - simpl.
    rewrite IHa.
    reflexivity.
Qed.

End NatSerializer.

Section ListSerializer.
Variable A : Type.
Variable serA : Serializer A.

Fixpoint list_serialize (l : list nat) : list bool :=
  match l with
  | [] => [false]
  | h :: t => [true] ++ list_serialize t
  end.

Definition deser_skip {T} (orig : skip_list bool) (result : option (T * nat)) : option (T * skip_list bool):=
  match result with
  | None => None
  | Some (a, amt) => Some (a, skip bool amt orig)
  end.

Fixpoint list_deserialize' (bools : skip_list bool) :  option (list A * nat) :=
  match deser_skip bools (deserialize (skip_list2list bool bools)) with
  | None => None
  | Some (n, rest) =>
    match (list_deserialize' rest) with
    | None => None
    | Some (tail, amtRest) => Some (n :: tail, 0)
    end
  end.

Definition list_deserialize (bools : list bool) : option (list A * nat) :=
  list_deserialize' (list2skip_list bools).

Definition list_deserialize (bools : list bool) : option (list nat * list bool) :=
  match (nat_deserialize bools) with
  | None => None
  | Some (size, bools) => list_deserialize_elements size bools
  end.
(*end code*)

Theorem list_ser_deser_identity :
  ser_deser_spec_ (list nat) list_serialize list_deserialize.
Proof.
  unfold ser_deser_spec_.
  intros.
  unfold list_serialize, list_deserialize.
  rewrite app_ass.
  rewrite nat_ser_deser_identity.
  induction a as [|h t]. (* TODO was l, now a *)
  - trivial.
  - simpl.
    rewrite app_ass.
    rewrite nat_ser_deser_identity. (* Element ser/deser identity *)
    rewrite IHt.
    reflexivity.
Qed.

End ListSerializer.


(**
Coq/SSReflect/MathComp による定理証明

6.2.1 有限群の型と補題
======

2021_03_07 @suharahiromichi
 *)

From mathcomp Require Import all_ssreflect.
From mathcomp Require Import fingroup.

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

(**
## 最初に

``group`` スコープにしておきます。
*)
Open Scope group_scope.

(**
## ``finGroupType`` とはなにか

テキストでは、「``fingroup`` は有限群の基本的な仮定や補題を提供します」
と記載されています。有限群は finite group のことですから、間違いではないのですが、
MathComp の型クラスとして定義されているのは、``finGroupType``
すなわち「有限群型」であることに注意してください。

``fingroup.v``のコメントでは、``finGroupType`` は、
"the structure for finite types with a group law" と記載されています。

有限群型とは、その要素が群の規則を満たす有限型という意味で、
``finType``型クラスを継承して、公理として乗法の結合則や単位元の存在を仮定します。
すなわち、``finType``型クラスのインスタンス型``T``を台として、以下が成り立ちます。

- 二項演算 mulg : T -> T -> T が存在する。
- 元 one : T が存在する。
- 関数 invg : T -> T が存在する。
- mulg は結合律を満たす。
- one は左単位元である。
- invg は対合である（involutive、2回適用するともとにもどる）。
```invg (invg x) = x```
- invg と mulg は逆自己同型（？）である（anti-mophism を満たす）。
```invg (mulg x y) = mulg (invg y) (invg x)```

（``anti-`` は x と y が逆になるということ）
 *)

(**
## 型インスタンスとしての「有限群型」の定義

前節の繰り返しになりますが、
型クラス``finGroupType``のインスタンス型の値は、
有限群の公理を満たすということです。
*)
Section Sect_1.

  Check finGroupType : Type.                (* 型クラス *)

(**
### 群の公理と定理

群 gT の要素 x, y, z の間で群の公理や定理が成り立ちます。
*)
  Variable gT : finGroupType.               (* 有限群 = 型インスタンス *)
  Check gT : finGroupType.

  Variable x y z : gT.                      (* 有限群の要素 *)

  Check mulg x y : gT.                      (* 乗算 *)
  Check x * y : gT.                         (* 乗算（演算子） *)

  Check invg x : gT.                        (* 逆元 *)
  Check x^-1 : gT.                          (* 逆元（演算子） *)

  (* 群の公理 *)
  Goal 1 * x = x. Proof. by rewrite mul1g. Qed.
  Goal x * y * z = x * (y * z). Proof. by rewrite mulgA. Qed.
  Goal x^-1^-1 = x. Proof. by rewrite invgK. Qed.
  Goal (x * y)^-1 = y^-1 * x^-1. Proof. by rewrite invMg. Qed.

  (* 群の定理 *)
  Goal x * 1 = x. Proof. by rewrite mulg1. Qed.
  Goal x * x^-1 = 1. Proof. by rewrite mulgV. Qed.
  Goal x^-1 * x = 1. Proof. by rewrite mulVg. Qed.

(**
参考： mulg において、``FinGroup.base gT`` が gT のカノニカル解です。
（x や y が gT 型であることから、``FinGroup.base gT`` を見つけ出せるます）
*)
  Check @mulg : forall T : baseFinGroupType, T -> T -> T.
  Check @mulg (FinGroup.base gT) x y : FinGroup.base gT.
  Compute FinGroup.sort (FinGroup.base gT). (* gT *)

(**
別に定義した有限群 ``gT'`` と ``gT`` の要素の間の乗算はできません。
*)
  Section Sect_1_2.
    Variable gT' : finGroupType.            (* 別な有限群 *)
    Variable x' y' : gT'.

    Check x' * y' : gT'.
    Fail Check x' * y.
  End Sect_1_2.

(**
## ``group_set_of_baseGroupType gT``
*)

(**
### 集合としての群

テキストの6.2節でもそうですが、
群そのもの（有限集合としての有限群）を扱いたい場合があります。

``gT`` は型インスタンスであり、コアーションで型になることに間違いありません。
*)
  Check FinGroup.sort gT : Type.
  Check gT : Type.                          (* コアーション *)
  Check x : gT.
  Check x \in gT.                           (* このような表記も可能です。 *)

(**
しかし、型と集合はCoqの対象としては別なものです。
*)
(**
## 集合としての群の型（その１）

集合としての群を扱うには次のようにします：

まず、``finGroupType``型クラスのインスタンス型（例：gT）の値を要素とする
有限集合の型は、``{set gT}``で表します。

``{set gT}``のインスタンス（この場合は集合） A, B, C は、次のように定義します：
 *)
  Check {set gT} : predArgType.
  Variable A B C : {set gT}.

(**
``{set gT}`` のインスタンスは、``[set _ : _ | _]`` のかたちでも定義できます。
あとで出てきます。任意のbool述語を併用して集合を定義できます。
*)
    Check [set a : gT | _] : {set gT}.

(**
また、``{set gT}`` は、predArgType で ``\in`` による判定ができます。
 *)
  Check x : gT.                             (* x は gT 型 *)
  Check x \in A : bool.                     (* true または false *)

(**
``mem A`` は、gT 型の変数が集合Aに含まれるか否かを決定する``gT -> bool``型の関数になります。
(``finset`` の ``set_type``の定義を参照のこと)。
*)
  Check mem A : gT -> bool.
  Check mem A x : bool. (* x \in A とだいたい同じ。。。ちょっと苦しい。 *)

(**
しかし、x は A型 でないことに注意してください。そもそも A は型ではありません。
 *)
  Fail Check x : A.
  Fail Check A : Type.

(**
集合としての群の型として、group_set_of_baseGroupType が定義されています。
 *)
  Check group_set_of_baseGroupType : baseFinGroupType -> Type.
  Check gT : baseFinGroupType.
  Check group_set_of_baseGroupType gT : Type.

(**
``group_set_of_baseGroupType gT`` は {set gT} のカノニカル解なので、
（A や B が ``{set gT}``型であることから、``group_set_of_baseGroupType gT``
を見つけ出すことができ）mulg (``*``) を使って集合としての群どうしの積が計算できます。
*)
  Check @mulg : forall T : baseFinGroupType, T -> T -> T.
  Check @mulg (group_set_of_baseGroupType gT) A B : group_set_of_baseGroupType gT.
  Check A * B : {set gT}.
  Check mulg A B : {set gT}.

(**
## 集合としての群の型（その２）

ついで、有限群は``{group A}``で表します。

``{group A}``の実体は、``{set A}``を台として、
以下の条件を追加したものです(``fingroup`` の ``group_type``の定義を参照のこと)。
*)

(**
``{group gT}``のインスタンスは、次のように使って定義します：
*)
  Check {group gT} : predArgType.
  Variable G H : {group gT}.
(**
有限群の公理や定理のうち、集合としての有限群がでてくるものが使えます。
*)

  Goal 1 \in G. Proof. by rewrite group1. Qed.
  Goal x \in G -> x^-1 \in G. Proof. by move/groupVr. Qed.
  Goal x \in G -> y \in G -> x * y \in G. Proof. apply: groupM. Qed.

(**
``{set T}`` と ``{group T}``の定義にはファントムタイプを使っていますが、
これは、``T``の部分に、
finType にカノニカルプロジェクションできる型だけを書けるように制限するためです。
*)
  Check {set bool}.                         (* bool型はよいが、 *)
  Fail Check {set nat}.                     (* nat型はダメ。 *)

(**
Math-Comp Book の 5.10.1 や次の文書も参照してください。

[https://github.com/suharahiromichi/coq/blob/master/math-comp-book/suhara.ch7-phantom_types.v]

*)

(**
## 剰余類 (coset) の定義

MathComp には、関数``rcoset`` と 演算子``A :* x`` のふたつの定義があります。
このふたつは別のものです。
 *)
(**
### ひとつめの定義

関数``rcoset``の定義は、有限群Aのすべての要素に、右からxを掛けたものです。
(A の ``mulg x = λy.(x * y)`` による像の集合といえます。)
*)
  Check rcoset : {set gT} -> gT -> {set gT}.

  Check rcoset A x.
  Check (fun a => mulg a x) @: A.           (* rcoset を展開する。 *)
  Check mulg^~x @: A.                       (* ``^~`` は MathComp 風の表記 *)
  Check [set a * x | a in A].               (* ``@:`` を展開する。 *)
  (* ``@:`` は、finset で定義 *)

(**
### ふたつめの定義

演算子``A :* x``の定義は、有限集合としての有限群Aと``{x}``を掛けたものです。
*)
  Check A :* x.
  Check A * [set x].                    (* ``:*`` を展開する。 *)
  Check mulg A [set x].                 (* ``*`` を展開する。 *)

(**
### ふたつの定義がおなじであることの証明
*)
  Check rcosetE
    : forall (gT : finGroupType) (A : {set gT}) (x : gT), rcoset A x = A :* x.
  Check rcosetP
    : reflect (exists2 a, a \in G & y = a * x) (y \in G :* x).

(**
## 剰余群 (cosets) の定義

MathComp には、関数``rcosets`` があります。
``rcosets A B`` は、有限集合としての有限群Bのすべての要素に、
有限集合としての有限群Aのすべての要素を右から掛けたものです。

関数``rcosets``の定義は、
有限集合としての有限群Bのすべての要素に、
有限集合としての剰余類Aを右から掛けたものです。XXXXX
 *)
  Check rcosets : {set gT} -> {set gT} -> {set {set gT}}.

  Check rcosets A B.
  Check (rcoset A) @: B.                    (* rcosets を展開する。 *)

(**
### ひとつめの定義

rcoset の定義を rcoset のひとつめの定義（``[set a * x | a in A] ``）で展開すると、
つぎのようになります。
*)
  Print rcosets.
  Check [set (rcoset A x) | x in B].        (* ``@:`` を展開する。 *)
  Check [set [set a * x | a in A] | x in B]. (* rcoset を展開する。 *)
(**
これは、次に示すものではありません。
*)
  Check A * B  : {set gT}.

(**
### ふたつめの定義

rcoset の定義を rcoset のふたつめ定義（``A :* x``）で展開すると、
つぎのようになります。
*)
  Check [set (A :* x) | x in B].

(**
### ふたつの定義がおなじであることの証明

ここで、 exists2 の2は、2つの命題を&で結ぶという意味。
*)
  Check rcosetsP
    : reflect (exists2 x, (x \in B) & (C = A :* x)) (C \in rcosets A B).

End Sect_1.

(**
# おまけ

rcosetsP の「ふたつめの定義」に近い定義を示す。
*)
Section Appendix.

  Variable gT : finGroupType.

(**
左が rcosetsP の書き方、右が「ふたつめの定義」の書き方です。
*)
  Check @imsetP
    : forall (aT rT : finType) (f : aT -> rT) (B : mem_pred aT) (C : rT),
      reflect (exists2 x : aT, (in_mem x B) & (C = f x)) (C \in imset f B).

  Lemma test (B C : {set gT}) f :
    reflect (exists2 x, (x \in B) & (C = f x)) (C \in [set f x | x in B]).
  Proof.
      by apply: imsetP.
  Qed.

  Lemma rcosetsP' (A B C : {set gT}) :
    reflect (C \in [set (A :* x) | x in B]) (C \in rcosets A B).
  Proof.
    apply: (iffP idP).
    - move=> H.
        by apply/imsetP/rcosetsP.
    - by move/imsetP/rcosetsP.
  Qed.

End Appendix.

(* END *)


Require Import HoTT.

From GC Require Import equiv_lemmas pointed_lemmas finite_lemmas nat_lemmas trunc_lemmas permutations
                       (* monoidal_1type *)
                       group_complete_1type.

(*Defining the monoidal 1-type of finite sets and isomorphisms*)
Section BSigma.

  (*This type corresponds to the category of finite sets and isomorphisms*)
  Record BSigma :=
    {card_BSigma : nat ; fintype_of_BSigma :> Finite_Types card_BSigma}.
    (* {m : nat & Finite_Types m}. *)
    (* { S : Type & Finite S}. *)
  (* Definition type_of_fin : BSigma -> Type := (fun A => A.2.1). *)
  (* Coercion type_of_fin : BSigma  >-> Sortclass. *)

  Definition issig_BSigma :
    BSigma <~> {A : Type & Finite A}.
  Proof.
    srapply @equiv_adjointify.
    - intros [n A]. exists A. exact _.
    - intros [A [n e]]. exact (Build_BSigma n (A; e)).
    - intros [A [n e]]. simpl.
      apply path_sigma_hprop. reflexivity.
    - intros [n A]. simpl. reflexivity.
  Defined.

  Global Instance istrunc_BSigma : IsTrunc 1 BSigma.
  Proof.
    apply (trunc_equiv' {S : Type & Finite S}).
    - apply equiv_inverse. apply issig_BSigma.
    - apply trunc_sigma'.
      +  intro A. exact _.
      +  intros A B.
         srapply @istrunc_paths_Type.
         apply isset_Finite. exact B.2.
  Defined.

  Definition fin_to_BSigma {n : nat}
    : Finite_Types n -> BSigma
    := Build_BSigma n.

  (*Canonical objects in BSigma*)
  Definition canon_BSigma (n : nat) : BSigma := fin_to_BSigma (canon n).

  Lemma finite_types_eqcard {m n : nat} (A : Finite_Types m) (B : Finite_Types n) :
    A <~> B -> m = n.
  Proof.
    destruct A as [A fA]. destruct B as [B fB]. simpl. intro e.
    strip_truncations.
    apply nat_eq_fin_equiv.
    exact (fB oE e oE (equiv_inverse fA)).
  Qed.

  (* in finite_lemmas: *)
  (* (* Describing the path type of BSigma *) *)
  (* Definition path_BSigma {A B : BSigma} : A <~> B -> A = B. *)
  (* Proof. *)
  (*   refine ((equiv_ap issig_BSigma A B)^-1 o _). *)
  (*   destruct A as [m [A eA]]. destruct B as [n [B eB]]. simpl. *)
  (*   exact (equiv_path_finite_types' (A; finite_finite_type (A; eA)) (B; finite_finite_type (B; eB))). *)
  (* Defined. *)

  (* Definition path_BSigma_inv {A B : BSigma} : A = B -> A <~> B. *)
  (* Proof. *)
  (*   intros []. exact equiv_idmap. *)
  (* Defined. *)

  (* Global Instance isequiv_path_BSigma {A B : BSigma} : IsEquiv (@path_BSigma A B). *)
  (* Proof. *)
  (*   srapply @isequiv_adjointify. *)
  (*   - exact path_BSigma_inv. *)
  (*   - intros []. simpl. *)
  (*     unfold path_BSigma. *)

  (* Definition path_BSigma (A B : BSigma) : *)
  (*   (A <~> B) -> A = B. *)
  (* Proof. *)
  (*   refine (equiv_inverse (equiv_ap issig_BSigma A B) o _). *)
  (*   intro e. *)
  (*   apply equiv_path_finite_types'. exact e. *)
  (* Defined. *)

  (* Definition path_BSigma_id (A : BSigma) : *)
  (*   path_BSigma A A (equiv_idmap) = idpath. *)
  (* Proof. *)
  (*   unfold path_BSigma. *)
  (*   apply moveR_equiv_V. simpl. *)
  (*   apply (moveR_equiv_M). simpl. *)
  (*   apply (moveR_equiv_M). simpl. reflexivity. *)
  (* Defined. *)

  Definition inv_path_BSigma {A B : BSigma}
    : A = B -> A <~> B.
  Proof.
    intros []. exact equiv_idmap.
  Defined.

  Definition equiv_path_BSigma (A B : BSigma) :
    (A <~> B) <~> A = B.
  Proof.
    refine ((equiv_ap issig_BSigma A B)^-1 oE _).
    exact (equiv_path_finite_types' (issig_BSigma A) (issig_BSigma B) ).
  Defined.

  Definition inv_equiv_path_BSigma (A B : BSigma) :
    (equiv_inverse (equiv_path_BSigma A B)) == inv_path_BSigma.
  Proof.
    intros []. reflexivity.
  Defined.

  Definition path_BSigma (A B : BSigma) : A <~> B -> A = B
    := equiv_path_BSigma A B.

  (* Proof. *)
  (*   destruct A as [m A]. destruct B as [n B]. simpl. *)
  (*   intro e. *)
  (*   destruct (finite_types_eqcard A B e). *)
  (*   apply (path_sigma (fun m : nat => Finite_Types m) (m; A) (m;B) idpath). simpl. *)
  (*   apply path_finite_types. *)
  (*   exact e. *)
  (* Defined. *)

  (* Definition isequiv_path_BSigma {A B : BSigma} : IsEquiv (@path_BSigma A B). *)
  (* Proof. *)
  (*   srapply @isequiv_adjointify. *)
  (*   - intros []. exact equiv_idmap. *)
  (*   - intros []. *)
  (*     unfold path_BSigma. *)
  (*     assert (H : (finite_types_eqcard (pr2 A) (pr2 A) equiv_idmap) = idpath). *)
  (*     { apply hset_nat. } destruct H. *)
  (*     destruct . *)

  (* shorter proof than in finite_lemmas *)

  Definition path_BSigma_1 (A : BSigma) :
    path_BSigma _ _ (equiv_idmap A) = idpath.
  Proof.
    unfold path_BSigma. unfold equiv_path_BSigma. ev_equiv.
    apply moveR_equiv_V. unfold equiv_path_finite_types'. ev_equiv.
    apply moveR_equiv_M. simpl.
    apply (moveR_equiv_M (f := equiv_path_universe _ _)). reflexivity.
  Defined.

  Definition path_BSigma_V {A B : BSigma} (e : A <~> B)
    : (path_BSigma _ _ e)^ = path_BSigma _ _ (equiv_inverse e).
  Proof.
    refine (_ @ ap (fun g => path_BSigma B A (equiv_inverse g)) (eissect (@path_BSigma A B) e)).
    generalize (path_BSigma A B e).  intros [].
    simpl. apply inverse.
    refine (_ @ path_BSigma_1 A).
    apply (ap (path_BSigma _ _)).
    apply path_equiv. simpl.  reflexivity.
  Defined.

  Definition pft_to_pbs {m : nat} {A B : Finite_Types m}
    : A = B -> (fin_to_BSigma A) = (fin_to_BSigma B)
    := ap (fin_to_BSigma).
    (* : A = B -> (m;A) = (m;B) :> BSigma *)
    (* := fun p => path_sigma Finite_Types (m; A) (m; B) idpath p. *)

  Definition path_BSigma_fix {m : nat} (A B : Finite_Types m) (e : A <~> B)
    : pft_to_pbs (path_finite_types m A B e)
      = @path_BSigma (fin_to_BSigma A) (fin_to_BSigma B) e.
  Proof.
    refine (_ @ ap (@path_BSigma
                      (fin_to_BSigma _)
                      (fin_to_BSigma _))
              (eissect (path_finite_types m A B) e)).
    generalize (path_finite_types m A B e).
    intros []. simpl.
    refine ((path_BSigma_1 _)^).
  Defined.

  Global Instance isequiv_pft_to_pbs {m : nat} {A B : Finite_Types m}
    : IsEquiv (@pft_to_pbs m A B).
  Proof.
    assert (H : @pft_to_pbs m A B
            = equiv_path_BSigma
                (fin_to_BSigma A) (fin_to_BSigma B)
                oE (equiv_path_finite_types m A B)^-1).
    { apply path_arrow. intros []. ev_equiv.
      apply inverse.
      refine (path_BSigma_1 _). }
    rewrite H.
    apply equiv_isequiv.
  Qed.

  (* (* path_BSigma respects composition *) *)
  Definition path_BSigma_compose {A B C : BSigma} (e1 : A <~> B) (e2 : B <~> C) :
    path_BSigma _ _ (e2 oE e1) = path_BSigma _ _ e1 @ path_BSigma _ _ e2.
  Proof.
    (* path_BSigma e2 @ path_BSigma e1 = path_BSigma (e1 oE e2). *)
  Proof.
    refine
      (ap011 (fun g1 g2 => path_BSigma A C (g2 oE g1))
             (eissect (path_BSigma A B) e1)^ (eissect (path_BSigma B C) e2)^ @ _).
    generalize (path_BSigma _ _ e2). intros [].
    generalize (path_BSigma _ _ e1). intros []. simpl.
    refine (path_BSigma_1 A).
  Qed.

  Definition sum_BSigma : BSigma -> BSigma -> BSigma.
  Proof.
    intros [m A] [n B].
    exact (fin_to_BSigma (sum_finite_types A B)).
  Defined.

  Definition BSigma_id : BSigma := canon_BSigma 0.

  Local Notation "S1 ⊕ S2" := (sum_BSigma S1 S2) (at level 50, no associativity).

  (* (* symmetry *) *)
  (* Definition path_BSigma_twist (a b : nat) : *)
  (*   (@path_BSigma *)
  (*     (sum_BSigma (canon_BSigma a) (canon_BSigma b)) *)
  (*     (sum_BSigma (canon_BSigma b) (canon_BSigma a)) *)
  (*     (equiv_sum_symm (canon_BSigma a) (canon_BSigma b))) *)
  (*   @ *)
  (*     @path_BSigma *)

  (*       (sum_BSigma (canon_BSigma b) (canon_BSigma a)) *)
  (*       (canon_BSigma _) *)
  (*       (equiv_finsum b a) *)
  (*   = *)
  (*   @path_BSigma *)
  (*     (sum_BSigma (canon_BSigma a) (canon_BSigma b)) *)
  (*     (canon_BSigma _) *)
  (*     (equiv_finsum a b) *)
  (*   @ *)
  (*   ap canon_BSigma (nat_plus_comm b a). *)
  (* Proof. *)
  (*   induction a. *)
  (*   - simpl. *)
  (*     induction b. *)
  (*     + simpl. *)
  (*       refine ((path_BSigma_compose _ _ )^ @ _). *)

  (* path_BSigma behaves well with respect to sum *)
  Lemma path_BSigma_sum (A1 A2 B1 B2 : BSigma)
        (e1 : A1 <~> B1) (e2  : A2 <~> B2)
    : path_BSigma (sum_BSigma A1 A2) (sum_BSigma B1 B2) (e1 +E e2)
      = ap011 sum_BSigma (path_BSigma _ _ e1) (path_BSigma _ _ e2).
  Proof.
    rewrite (ap011 equiv_functor_sum'
                   (eissect (equiv_path_BSigma A1 B1) e1)^ (eissect (equiv_path_BSigma A2 B2) e2)^).
    change ((equiv_path_BSigma ?A ?B) ?e) with (path_BSigma A B e).
    destruct (path_BSigma A1 B1 e1). destruct (path_BSigma A2 B2 e2).
    simpl.
    refine (_ @ path_BSigma_1 _).
    apply (ap (path_BSigma _ _)).
    apply path_equiv. apply path_arrow.
    intros [a | a]; reflexivity.
  Defined.

  Definition finsum_id (m n : nat) :
    sum_BSigma (canon_BSigma m) (canon_BSigma n) = canon_BSigma (n+m) :=
    path_BSigma (sum_BSigma (canon_BSigma m) (canon_BSigma n)) (canon_BSigma (n+m)) (equiv_finsum m n).

  Definition finsum_id_fix (m n : nat)
    : sum_finite_types (canon m) (canon n) = canon (n + m) :=
    path_finite_types _ (sum_finite_types (canon m) (canon n)) (canon (n+m)) (equiv_finsum m n).

  Definition path_BSigma_blocksum {a b : nat}
             (alpha : canon_BSigma a <~> canon_BSigma a)
             (betta : canon_BSigma b <~> canon_BSigma b)
    : path_BSigma (canon_BSigma (a +' b)) (canon_BSigma (a +' b)) (block_sum alpha betta) =

      (finsum_id a b)^ @ (ap011 sum_BSigma (path_BSigma _ _ alpha) (path_BSigma _ _ betta) @
                                finsum_id a b).
  Proof.
    unfold finsum_id.
    rewrite <- path_BSigma_sum.
    rewrite path_BSigma_V.
    rewrite <- path_BSigma_compose. rewrite <- path_BSigma_compose.
    reflexivity.
  Defined.

  (* rename the following and define them using the previous lemma *)
  Definition natural_path_BSigma_l {S1 S2 S3: BSigma} (e : S1 <~> S2)
    : ap (fun x : BSigma => x ⊕ S3) (path_BSigma _ _ e)
    = path_BSigma (S1 ⊕ S3) (S2 ⊕ S3) (equiv_functor_sum_r (B := S3) e).
  Proof.
    refine (_ @ ap (fun e' => @path_BSigma (S1⊕ S3) (S2 ⊕ S3) (equiv_functor_sum_r e'))
              (eissect (@path_BSigma S1 S2) e)).
    generalize (path_BSigma _ _ e). intros [].
    simpl. apply inverse.
    refine (_ @ path_BSigma_1 (S1 ⊕ S3)).
    apply (ap (path_BSigma _ _)).
    apply path_equiv. apply path_arrow. intros [s1 | s3]; reflexivity.
  Qed.

  Definition natural_path_BSigma_r {S1 S2 S3: BSigma} (e : S2 <~> S3)
    : ap (fun x : BSigma => S1 ⊕ x) (path_BSigma _ _ e)
      = path_BSigma (S1 ⊕ S2) (S1 ⊕ S3) (equiv_functor_sum_l (A := S1) e).
  Proof.
    refine (_ @ ap (fun e' => @path_BSigma (S1 ⊕ S2) (S1 ⊕ S3) (equiv_functor_sum_l e'))
              (eissect (@path_BSigma S2 S3) e)).
    generalize (path_BSigma _ _ e). intros [].
    simpl. apply inverse.
    refine (_ @ path_BSigma_1 (S1 ⊕ S2)).
    apply (ap (path_BSigma _ _)).
    apply path_equiv. apply path_arrow. intros [s1 | s2]; reflexivity.
  Qed.

  (*The monoidal structure on BSigma*)

  Definition BSigma_assoc : associative sum_BSigma.
  Proof.
    intros S1 S2 S3.
    apply path_BSigma.
    apply equiv_sum_assoc'.
  Defined.

  Definition BSigma_lid : left_identity_mult sum_BSigma (canon_BSigma 0).
  Proof.
    intro S. apply path_BSigma.
    apply sum_empty_l.
  Defined.

  Definition BSigma_rid : right_identity_mult sum_BSigma (canon_BSigma 0).
  Proof.
    intro S. apply path_BSigma.
    apply sum_empty_r.
  Defined.

  Definition BSigma_symmetric : symmetric sum_BSigma.
  Proof.
    intros S1 S2. apply path_BSigma. apply equiv_sum_symm.
  Defined.

  Definition BSigma_triangle1 : coherence_triangle1 BSigma_assoc BSigma_lid.
  Proof.
    intros S1 S2.
    unfold BSigma_lid.
    refine (natural_path_BSigma_l _ @ _).
    unfold BSigma_assoc.
    refine (_ @ (path_BSigma_compose _ _)).
    apply (ap (path_BSigma _ _)).
    apply path_equiv. apply path_arrow.
    intros [[[] | s1] | s2]; reflexivity.
  Qed.

  Definition BSigma_triangle2 : coherence_triangle2 BSigma_assoc BSigma_lid BSigma_rid.
  Proof.
    intros S1 S2. unfold BSigma_rid. unfold BSigma_assoc. unfold BSigma_lid. simpl.
    refine (natural_path_BSigma_l _ @ _).
    refine (_ @ whiskerL _ (natural_path_BSigma_r _)^).
    refine (_ @ (path_BSigma_compose  _ _)).
    apply (ap (path_BSigma _ _)).
    apply path_equiv. apply path_arrow.
    intros [[s1 | []] | s2]; reflexivity.
  Qed.

  Definition BSigma_pentagon : coherence_pentagon BSigma_assoc.
  Proof.
    intros S1 S2 S3 S4.
    refine (natural_path_BSigma_l _  @ _).
    apply moveL_pV.
    refine ((path_BSigma_compose _ _)^ @ _).
    apply moveL_pV.
    refine (whiskerL _ (natural_path_BSigma_r _) @ _).
    refine ((path_BSigma_compose _ _)^ @ _).
    refine (_ @ (path_BSigma_compose _ _)).
    apply (ap (path_BSigma _ _)).
    apply path_equiv. apply path_arrow.
    intros [[[s1 | s2]| s3] | s4]; reflexivity.
  Defined.

  (* The next two lemmas should be moved *)
  Definition isinj_functor_sum {A1 A2 B1 B2 : Type} (f1 f1' : A1 -> B1) (f2 f2': A2 -> B2) :
    functor_sum f1 f2 = functor_sum f1' f2' -> (f1 = f1') * (f2 = f2').
  Proof.
    intro p.
    set (p' := ap10 p).
    apply pair.
    - apply path_arrow. intro a.
      apply (path_sum_inl B2). exact (p' (inl a)).
    - apply path_arrow. intro a.
      apply (path_sum_inr B1). exact (p' (inr a)).
  Defined.

  Definition isinj_equiv_functor_sum_r {A1 A2 B : Type} (e1 e2 : A1 <~> A2) :
    equiv_functor_sum_r (B := B) e1 = equiv_functor_sum_r e2 -> e1 = e2.
  Proof.
    intro p. apply path_equiv.
    refine (fst ((isinj_functor_sum e1 e2 idmap idmap) _)).
    apply (path_equiv^-1 p).
  Defined.

  Definition BSigma_lcancel (S1 S2 : BSigma) (p q : S1 = S2) (T : BSigma) :
    ap (fun x => x ⊕ T) p = ap (fun x => x ⊕ T) q -> p = q.
  Proof.
    intro h.
    apply (equiv_inj (@path_BSigma S1 S2)^-1).
    apply (isinj_equiv_functor_sum_r (B:=T)
                                     ((equiv_path_BSigma _ _)^-1 p) ((equiv_path_BSigma _ _)^-1 q)) .
    apply (equiv_inj (@path_BSigma (S1 ⊕ T) (S2 ⊕ T))).
    refine ((natural_path_BSigma_l _)^ @ _ @ natural_path_BSigma_l _).
    refine (_ @ h @ _);
      apply (ap (ap (fun x : BSigma => x ⊕ T))).
      - apply eisretr.
      - apply inverse. apply eisretr.
  Defined.

  Definition BSigma_moncat : Monoidal_1Type :=
    Build_Monoidal_1Type
      (BuildTruncType 1 BSigma) sum_BSigma (canon_BSigma 0) BSigma_assoc BSigma_lid BSigma_rid
      BSigma_triangle1 BSigma_triangle2 BSigma_pentagon.

  Definition group_completion_BSigma := group_completion BSigma_moncat BSigma_lcancel .

  (* Lemma equiv_toempty (A : Type) : *)
  (*   (A -> Empty) <~> (A <~> Empty). *)
  (* Proof.     *)
  (*   apply equiv_iff_hprop. *)
  (*   - intro f. apply (BuildEquiv A Empty f). apply all_to_empty_isequiv. *)
  (*   - apply equiv_fun. *)
  (* Qed. *)

  Lemma sum_empty_is_empty (A B : Type) :
    A + B <~> Empty -> A <~> Empty.
  Proof.
    intro e.
    apply (BuildEquiv A Empty (fun a => e (inl a)) ). apply all_to_empty_isequiv.
  Defined.

  Definition univalent_group_completion_BSigma :
    Categories.IsCategory group_completion_BSigma.
  Proof.
    apply univalent_monactcat; simpl.
    - intros A B.
      intro p.
      apply path_BSigma. simpl.
      apply (sum_empty_is_empty A B).
      apply ((path_BSigma _ _)^-1 p).
    - intro A.
      apply (trunc_equiv' (Empty <~> A)).
      + apply (equiv_path_BSigma (canon_BSigma 0)).
      + apply (trunc_equiv' (A <~> Empty)).
        * apply equiv_equiv_inverse.
        * exact _.
  Qed.

  (* Now we prove that associativity of sum_BSigma on canonical finite types correspond to*)
  (* associativity of natural numbers. *)
  (* move to better place? *)
  (* Lemma ap_pr1_assoc (A B C : BSigma) *)
  (*   : (ap pr1 (BSigma_assoc A B C))^ = (plus_assoc (pr1 C) (pr1 B) (pr1 A)). *)
  (* Proof. *)
  (*   apply hset_nat. *)
  (* Qed. *)

  Definition equiv_sum_assoc_Fin (j k l : nat)
    : (Fin l + Fin k) + Fin j <~>
       Fin l + (Fin k + Fin j).
  Proof.
    induction j.
    - refine (_ oE sum_empty_r _).
      apply (equiv_functor_sum_l (sum_empty_r _)^-1).
    - simpl.
      refine (_ oE (equiv_functor_sum' IHj (equiv_idmap Unit)) oE _).
      + refine (_ oE equiv_sum_assoc _ _ _).
        apply equiv_functor_sum_l. apply equiv_sum_assoc.
      +
        refine (_ oE (equiv_sum_assoc _ _ _)^-1 ). apply equiv_idmap.
  Defined.

  Definition id_equiv_sum_assoc_Fin (j k l : nat)
    : equiv_sum_assoc (Fin l) (Fin k) (Fin j) = equiv_sum_assoc_Fin j k l.
  Proof.
    induction j.
    - simpl. apply path_equiv. apply path_arrow.
      intros [[x | x] | []]; reflexivity.
    - simpl. rewrite <- IHj.
      apply path_equiv. apply path_arrow.
      intros [[x | x] | [x | []]]; reflexivity.
  Defined.

  Definition sum_canon_BSigma (j k : nat) :
    sum_BSigma (canon_BSigma j) (canon_BSigma k) = canon_BSigma (k + j)%nat.
  Proof.
    srapply @path_BSigma. apply equiv_finsum.
  Defined.

  Definition canon_assoc (a b c : nat)
    : Fin (a + (b + c)) <~> Fin ((a + b) + c ).
  Proof.
    refine (_ oE (equiv_finsum _ _)^-1).
    refine (_ oE (equiv_functor_sum_r (equiv_finsum _ _))^-1).
    refine (_ oE ((equiv_sum_assoc' _ _ _))).
    refine (equiv_finsum _ _ oE _).
    apply (equiv_functor_sum_l (equiv_finsum _ _)).
  Defined.

  (* Definition canon_assoc (a b c : nat) *)
  (*   : Fin ((a + b) + c ) <~> Fin (a + (b + c)). *)
  (* Proof. *)
  (*   refine (_ oE (equiv_finsum _ _)^-1). *)
  (*   refine (_ oE (equiv_functor_sum_l (equiv_finsum _ _))^-1). *)
  (*   refine (_ oE ((equiv_sum_assoc _ _ _))^-1). *)
  (*   refine (equiv_finsum _ _ oE _). *)
  (*   apply (equiv_functor_sum_r (equiv_finsum _ _)). *)
  (* Defined. *)

  Definition equiv_functor_sum_r_compose
    : forall (A A1 A2 B : Type)
             (e1 : A <~> A1)
             (e2 : A1 <~> A2),
      equiv_functor_sum_r (B := B) (e2 oE e1)
      = equiv_functor_sum_r (B:= B) e2 oE equiv_functor_sum_r (B := B) e1.
  Proof.
    intros. apply path_equiv. apply path_arrow.
    intros [x | x]; reflexivity.
  Defined.

  (* move *)
  Definition equiv_finsum_succ (a b : nat)
    : equiv_finsum a (b.+1) = equiv_functor_sum_r (equiv_finsum a b) oE (equiv_sum_assoc' _ _ _)^-1.
  Proof.
    apply path_equiv. apply path_arrow.
    intro x. simpl. apply finsum_succ.
  Defined.

  Definition functor_sum_assoc {A B C A' B' C' : Type} (f : A -> A') (g : B -> B') (h : C -> C')
    : functor_sum (functor_sum f g) h  o (sum_assoc_inv _ _ _) ==
      sum_assoc_inv _ _ _  o (functor_sum f (functor_sum g h)).
  Proof.
    intros [a | [b | c]]; reflexivity.
  Defined.

  Definition functor_sum_idmap (A B: Type)
    : @functor_sum A A B B idmap idmap == idmap.
  Proof.
    intros [a | b]; reflexivity.
  Defined.

  Definition functor_sum_compose {A A1 A2 B B1 B2 : Type}
             (f1 : A -> A1) (f2 : A1 -> A2)
             (g1 : B -> B1) (g2 : B1 -> B2)
    : functor_sum (f2 o f1) (g2 o g1) == functor_sum f2 g2 o functor_sum f1 g1.
  Proof.
    intros [a | b]; reflexivity.
  Defined.

  Definition equiv_functor_sum_r_V (A A' B : Type) (e : A <~> A')
    : equiv_functor_sum_r (B := B) (e^-1) = equiv_inverse (equiv_functor_sum_r e).
  Proof.
    apply path_equiv. reflexivity.
  Defined.

  Definition canon_assoc_succ (a b c : nat)
    : canon_assoc (a.+1) b c
      = equiv_functor_sum_r (canon_assoc a b c).
  Proof.
    unfold canon_assoc. simpl.
    apply emoveR_eV. apply emoveR_eV.
    rewrite equiv_finsum_succ. rewrite equiv_finsum_succ.
    rewrite equiv_finsum_succ.
    repeat rewrite equiv_functor_sum_r_compose.
    repeat rewrite equiv_functor_sum_r_V.
    apply path_equiv. apply path_arrow. intro x. ev_equiv. simpl.
    apply (ap (equiv_functor_sum_r (equiv_finsum c (a + b)))).
    rewrite <- (functor_sum_compose (finsum (b + c) a) (finsum_inv (b + c) a) idmap idmap).
    change (finsum_inv ?x ?y) with ((equiv_finsum x y)^-1).
    change (finsum ?x ?y ?z) with (equiv_finsum x y z).
    rewrite (path_arrow _ _ (eissect (equiv_finsum (b + c) a))).
    rewrite functor_sum_idmap.  simpl.
    rewrite functor_sum_assoc.
    rewrite <- (functor_sum_compose (finsum c b) (finsum_inv c b) idmap (functor_sum idmap idmap)).
    change (finsum_inv c b) with ((equiv_finsum c b)^-1).
    change (finsum c b ?x) with (equiv_finsum c b x).
    rewrite (path_arrow _ _ (eissect (equiv_finsum c b))).
    destruct x as [[x | x] | [x | x]]; reflexivity.
  Defined.

  Definition canon_BSigma_assoc (a b c : nat) :
    canon_BSigma (a + (b + c))%nat = canon_BSigma ((a + b) + c)%nat.
  Proof.
    apply path_BSigma. exact (canon_assoc a b c).
  Defined.

  (* Definition canon_BSigma_succ (a : nat) *)
  (*   : canon_BSigma (a.+1) = sum_BSigma (canon_BSigma a) (canon_BSigma 1). *)
  (* Proof. *)
  (*   apply path_BSigma. apply equiv_functor_sum_l. *)
  (*   simpl. apply equiv_inverse. *)
  (*   apply sum_empty_l. *)
  (* Defined. *)

  (* Definition canon_BSigma_assoc_succ (a b c : nat) *)
  (*   : canon_BSigma_assoc (a.+1) b c *)
  (*     = canon_BSigma_succ _ @ ap (fun x => sum_BSigma x (canon_BSigma 1)) (canon_BSigma_assoc a b c) *)
  (*                         @ (canon_BSigma_succ _)^. *)
  (* Proof. *)
  (*   unfold canon_BSigma_assoc. unfold canon_BSigma_succ. *)
  (*   apply moveR_Vp. apply moveR_Vp. *)
  (*   unfold sum_canon_BSigma.     *)
  (*   repeat rewrite path_BSigma_V. simpl. *)
  (*   rewrite natural_path_BSigma_l. rewrite natural_path_BSigma_l. *)
  (*   rewrite natural_path_BSigma_r. rewrite natural_path_BSigma_r. *)
  (*   rewrite path_BSigma_V.  *)
  (*   repeat rewrite <- path_BSigma_compose. *)
  (*   rewrite natural_path_BSigma_l. repeat rewrite <- path_BSigma_compose. *)

  (*   apply (ap path_BSigma).  *)
  (*   apply path_equiv. apply path_arrow. *)
  (*   intros [x | [x | [x | x]]]; simpl. *)
  (*   - apply (ap inl). *)
  (*     unfold finsum.  *)
  (*   unfold canon_BSigma in x. unfold canon in x.  *)
  (*   simpl in x. *)

  Definition eq_canon_BSigma_assoc (a b c : nat)
    : canon_BSigma_assoc a b c = ap canon_BSigma (plus_assoc a b c)^.
  Proof.
    unfold canon_BSigma_assoc.
    induction a.
    - simpl. unfold canon_assoc.
      refine (_ @ path_BSigma_1 _).
      apply (ap (path_BSigma _ _)).
      apply emoveR_eV.
      refine (_ @ (ecompose_1e _)^).
      apply emoveR_eV.
      apply path_equiv. apply path_arrow.
      intros [[x | x] | []]; reflexivity.
    - rewrite canon_assoc_succ.
      simpl.
      assert (H : forall (m n : nat) (p : m = n),
                 ap canon_BSigma (ap S p)
                 = @path_BSigma (canon_BSigma (m.+1)) (canon_BSigma (n.+1))
                     (equiv_functor_sum_r
                        (B := Unit)
                        ((equiv_path_BSigma (canon_BSigma (m)) (canon_BSigma (n)))^-1
                                      (ap canon_BSigma p)))).
      { intros m n []. simpl.
        apply inverse. refine (_ @ path_BSigma_1 _).
        apply (ap (path_BSigma _ _)). apply path_equiv. simpl. apply path_arrow.
        intros [x|x]; reflexivity. }
      rewrite <- ap_V.
      rewrite H. clear H.
      apply (ap (path_BSigma _ _)). apply (ap equiv_functor_sum_r).
      apply moveL_equiv_V.
      apply IHa.
  Qed.

End BSigma.

Definition add_canon (m n : nat) :
  pMap (Build_pType (Finite_Types n) _) (Build_pType (Finite_Types (n+m)) _).
Proof.
  srapply @Build_pMap.
  - simpl. intro B. exact (sum_finite_types (canon m) B).
  - exact (path_finite_types
             (n+m)
             (sum_finite_types (canon m) (canon n))
             (canon (n+m))
             (equiv_finsum m n)).
Defined.


From Coq.Unicode Require Import Utf8.
From Coq.Program Require Import Tactics.
From Categories.Essentials Require Import Facts_Tactics Quotient.
From Categories Require Import Category.Main Functor.Main.
From cat_monotone Require Import PartialOrder Lattice.
From Coq.Lists Require Import List.

Section monotone.
  Context (po : PO).

  Definition monotone_base := list po.

  Definition principal_base (x : po) : monotone_base := cons x nil.

  Definition monotone_base_op (x y : monotone_base) : monotone_base := x ++ y.

  Definition monotone_rel_base (a b : monotone_base) : Prop :=
    ∀ x, (∃ y, In y a ∧ po x y) ↔ (∃ y, In y b ∧ po x y).

  Program Definition monotone_rel : EquiRel monotone_base :=
    {| EQR_rel := monotone_rel_base |}.
  Next Obligation.
  Proof.
    split.
    - intros a x; tauto.
    - intros a b Hab x; specialize (Hab x); tauto.
    - intros a b c Hab Hbc x; specialize (Hab x); specialize (Hbc x); tauto.
  Qed.

  Definition monotone := quotient monotone_rel.

  Definition principal (x : po) := class_of monotone_rel (principal_base x).

  Definition monotone_unit := class_of monotone_rel nil.

  Definition monotone_op (x y : monotone) : monotone :=
    class_of
      monotone_rel
      (monotone_base_op (representative x) (representative y)).

  Lemma in_monotone_op x a b :
    In x (representative (monotone_op a b)) →
    (∃ y, In y (representative a) ∧ po x y) ∨
    (∃ y, In y (representative b) ∧ po x y).
  Proof.
    intros Hx.
    pose proof (representative_of_class_of monotone_rel
                 (monotone_base_op (representative a) (representative b)))
      as Hab.
    specialize (Hab x) as [(z & Hz1 & Hz2) _].
    { eexists; split; [apply Hx| reflexivity]. }
    setoid_rewrite in_app_iff in Hz1.
    destruct Hz1 as [Hz1|Hz1]; eauto.
  Qed.

  Lemma in_monotone_op_back1 x a b :
    In x (representative a) →
    ∃ y, In y (representative (monotone_op a b)) ∧ po x y.
  Proof.
    intros Hx.
    pose proof (representative_of_class_of monotone_rel
                 (monotone_base_op (representative a) (representative b)))
      as Hab.
    specialize (Hab x) as [_ (z & Hz1 & Hz2)].
    { setoid_rewrite in_app_iff.
      exists x; split; [left; trivial| reflexivity]. }
    exists z; auto.
  Qed.

  Lemma in_monotone_op_back2 x a b :
    In x (representative b) →
    ∃ y, In y (representative (monotone_op a b)) ∧ po x y.
  Proof.
    intros Hx.
    pose proof (representative_of_class_of monotone_rel
                 (monotone_base_op (representative a) (representative b)))
      as Hab.
    specialize (Hab x) as [_ (z & Hz1 & Hz2)].
    { setoid_rewrite in_app_iff.
      exists x; split; [right; trivial| reflexivity]. }
    exists z; auto.
  Qed.

  Lemma monotone_unit_empty x : ¬ In x (representative monotone_unit).
  Proof.
    intros Hx.
    pose proof (representative_of_class_of monotone_rel nil) as Hnil.
    specialize (Hnil x) as [(z & Hz1%in_nil & Hz2) _]; [|trivial; fail].
    exists x; split; [trivial|reflexivity].
  Qed.

  Lemma is_in_monotone_preresntative_class_of x a :
    In x a → ∃ y, In y (representative (class_of monotone_rel a)) ∧ po x y.
  Proof.
    intros Hx.
    apply (representative_of_class_of monotone_rel a).
    eexists; split; [|reflexivity]; trivial.
  Qed.

  Lemma in_monotone_preresntative_class_of x a :
    In x (representative (class_of monotone_rel a)) → ∃ y, In y a ∧ po x y.
  Proof.
    intros Hx.
    apply (representative_of_class_of monotone_rel a).
    eexists; split; [|reflexivity]; trivial.
  Qed.

  Lemma in_principal x y : In x (representative (principal y)) → po x y.
  Proof.
    intros Hy.
    pose proof (representative_of_class_of monotone_rel (principal_base y) x)
      as [(z & Hz1 & Hz2) _].
    { exists x; split; [trivial|reflexivity]. }
    apply in_inv in Hz1 as [<-|?%in_nil]; tauto.
  Qed.

  Lemma is_in_principal x : ∃ y, In y (representative (principal x)) ∧ po x y.
  Proof.
    destruct (representative_represented _ (principal x) x) as
        [(z & Hz1 & H2) _]; [|eauto; fail].
    exists x; split; simpl; [auto|reflexivity].
  Qed.

  Lemma monotone_op_comm x y : monotone_op x y = monotone_op y x.
  Proof.
    apply class_of_inj.
    intros c.
    setoid_rewrite in_app_iff.
    split; (intros (?&?&?); eexists; split; [|eassumption]); tauto.
  Qed.

  Lemma monotone_op_assoc x y z :
    monotone_op (monotone_op x y) z = monotone_op x (monotone_op y z).
  Proof.
    apply class_of_inj.
    intros c.
    setoid_rewrite in_app_iff.
    split.
    - intros (d & Hd1 & Hd2).
      destruct Hd1 as [Hd1|Hd1].
      + apply in_monotone_op in Hd1 as [(e & He1 & He2)|(e & He1 & He2)].
        * exists e; split; [|etransitivity]; eauto.
        * destruct (in_monotone_op_back1 _ _ z He1) as (f & Hf1 & Hf2).
          exists f; split; [auto; fail|].
          etransitivity; [eassumption|etransitivity; eauto].
      + destruct (in_monotone_op_back2 _ y _ Hd1) as (e & He1 & He2).
        exists e; split; [auto; fail|].
        etransitivity; eauto.
    - intros (d & Hd1 & Hd2).
      destruct Hd1 as [Hd1|Hd1].
      + destruct (in_monotone_op_back1 _ _ y Hd1) as (e & He1 & He2).
        exists e; split; [auto; fail|].
        etransitivity; eauto.
      + apply in_monotone_op in Hd1 as [(e & He1 & He2)|(e & He1 & He2)].
        * destruct (in_monotone_op_back2 _ x _ He1) as (f & Hf1 & Hf2).
          exists f; split; [auto; fail|].
          etransitivity; [eassumption|etransitivity; eauto].
        * exists e; split; [|etransitivity]; eauto.
  Qed.

  Lemma monotone_op_unit_id x : monotone_op monotone_unit x = x.
  Proof.
    apply (uniquely_represented _ _ _ (representative x) (representative x));
    [|apply representative_represented|reflexivity].
    apply (related_represented
             _ _ (representative (monotone_op monotone_unit x))).
    { apply representative_represented. }
    intros c; split.
    - intros (d & Hd1 & Hd2).
      apply in_monotone_op in Hd1 as
          [(e & He1%monotone_unit_empty & He2)|(e & He1 & He2)]; [tauto|].
      exists e; split; [|etransitivity]; eauto.
    - intros (d & Hd1 & Hd2).
      destruct (in_monotone_op_back2 _ monotone_unit _ Hd1) as (e & He1 & He2).
      exists e; split; [auto; fail|].
      etransitivity; eauto.
  Qed.

  Lemma monotone_op_idemp x : monotone_op x x = x.
  Proof.
    eapply uniquely_represented;
      [apply representative_represented|apply representative_represented|].
    intros c; split.
    - intros (d & Hd1 & Hd2).
      apply in_monotone_op in Hd1 as
          [(e & He1 & He2)|(e & He1 & He2)].
      + exists e; split; [|etransitivity]; eauto.
      + exists e; split; [|etransitivity]; eauto.
    - intros (d & Hd1 & Hd2).
      destruct (in_monotone_op_back2 _ x _ Hd1) as (e & He1 & He2).
      exists e; split; [auto; fail|].
      etransitivity; eauto.
  Qed.

  Definition monotone_order x y := ∃ z, y = monotone_op x z.

  Local Obligation Tactic := idtac.

  Program Definition monotone_order_PO : PO :=
    {| PO_type := monotone;
       PO_car := monotone_order
    |}.
  Next Obligation.
  Proof.
    split.
    - intros x; exists monotone_unit.
      rewrite monotone_op_comm, monotone_op_unit_id; trivial.
    - intros x y z [u Hu] [v Hv].
      exists (monotone_op u v).
      rewrite Hv, Hu, monotone_op_assoc; trivial.
  Qed.
  Next Obligation.
  Proof.
    intros x y [z ->] [u ->].
    rewrite !monotone_op_assoc.
    rewrite (monotone_op_comm z (monotone_op _ _)).
    rewrite !monotone_op_assoc.
    rewrite monotone_op_idemp.
    rewrite (monotone_op_comm z); trivial.
  Qed.

  Program Definition monotone_JSLB : JSLB :=
    {| JSLB_PO := monotone_order_PO;
       join := monotone_op;
       bot := monotone_unit; |}.
  Next Obligation.
  Proof.
    intros x; exists x; rewrite monotone_op_unit_id; trivial.
  Qed.
  Next Obligation.
  Proof.
    intros x y; exists y; trivial.
  Qed.
  Next Obligation.
  Proof.
    intros x y; exists x; rewrite monotone_op_comm; trivial.
  Qed.
  Next Obligation.
  Proof.
    intros x y z [u Hxz] [v Hyz]; simpl in *.
    exists (monotone_op u v).
    rewrite (monotone_op_comm u v).
    rewrite (monotone_op_assoc x).
    rewrite <- (monotone_op_assoc y).
    rewrite <- Hyz.
    rewrite (monotone_op_comm z u).
    rewrite <- (monotone_op_assoc x).
    rewrite <- Hxz.
    rewrite monotone_op_idemp; trivial.
  Qed.

  Lemma monotone_correct x y :
    po x y ↔ monotone_order (principal x) (principal y).
  Proof.
    split.
    - intros Hxy.
      exists (principal y).
      apply class_of_inj.
      intros c; split.
      + intros (d & Hd1 & Hd2).
        apply is_in_monotone_preresntative_class_of in Hd1 as (e & He1 & He2).
        setoid_rewrite in_app_iff.
        exists e; split; [right|etransitivity]; eauto.
      + intros (d & Hd1 & Hd2).
        setoid_rewrite in_app_iff in Hd1.
        destruct Hd1 as [Hd1|Hd1].
        * apply in_principal in Hd1.
          exists y; split; [apply in_eq|].
          etransitivity; [eassumption| etransitivity]; eauto.
        * apply in_principal in Hd1.
          exists y; split; [apply in_eq|].
          etransitivity; eauto.
    - intros [a Ha].
      assert (monotone_rel
                (principal_base y)
                (monotone_base_op
                   (representative (principal x))
                   (representative a)))
        as Hrel by (apply equal_classes; trivial).
      pose proof (is_in_monotone_preresntative_class_of x (principal_base x))
        as (z & Hz1 & Hz2).
      { apply in_eq. }
      specialize (Hrel x) as [_ (w & Hw1 & Hw2)].
      { setoid_rewrite in_app_iff.
        exists z; split; [left; trivial|trivial]. }
      apply in_inv in Hw1 as [<-|?%in_nil]; tauto.
  Qed.

End monotone.

Local Obligation Tactic := idtac.

Program Definition PO_morphism_of_monotone_JSLB_morph
        po po' (f : PO_morphism po po') :
  PO_morphism (monotone_order_PO po) (monotone_order_PO po') :=
{| POM_mor x := class_of (monotone_rel po') (map f (representative x))
|}.
Next Obligation.
Proof.
  intros po po' f x y [u ->]; simpl.
  exists (class_of (monotone_rel po') (map f (representative u))).
  apply class_of_inj.
  intros c; split; setoid_rewrite in_app_iff.
  - intros (d & Hd1 & Hd2).
    apply in_map_iff in Hd1 as [d' [<- Hd']].
    apply in_monotone_op in Hd' as [(z & Hz1 & Hz2)|(z & Hz1 & Hz2)].
    + destruct (is_in_monotone_preresntative_class_of
                  po' (f z) (map f (representative x)))
        as (w & Hw1 & Hw2).
      { apply in_map; trivial. }
      exists w; split; [left; trivial; fail|].
      transitivity (f d'); [trivial; fail|].
      transitivity (f z); [|trivial; fail].
      apply POM_mono; trivial.
    + destruct (is_in_monotone_preresntative_class_of
                  po' (f z) (map f (representative u)))
        as (w & Hw1 & Hw2).
      { apply in_map; trivial. }
      exists w; split; [right; trivial; fail|].
      transitivity (f d'); [trivial; fail|].
      transitivity (f z); [|trivial; fail].
      apply POM_mono; trivial.
  - intros (d & [Hd1|Hd1] & Hd2).
    + apply in_monotone_preresntative_class_of in Hd1 as (e & He1 & He2).
      apply in_map_iff in He1 as [e' [<- He']].
      apply (in_monotone_op_back1 _ _ _ u) in He' as (i & Hi1 & Hi2).
      exists (f i); split; [apply in_map; trivial; fail|].
      transitivity d; [assumption|].
      transitivity (f e'); [assumption|].
      apply POM_mono; trivial.
    + apply in_monotone_preresntative_class_of in Hd1 as (e & He1 & He2).
      apply in_map_iff in He1 as [e' [<- He']].
      apply (in_monotone_op_back2 _ _ x) in He' as (i & Hi1 & Hi2).
      exists (f i); split; [apply in_map; trivial; fail|].
      transitivity d; [assumption|].
      transitivity (f e'); [assumption|].
      apply POM_mono; trivial.
Qed.

Program Definition monotone_JSLB_morph po po' (f : PO_morphism po po') :
    JSLB_morphism (monotone_JSLB po) (monotone_JSLB po') :=
{| JSLBM_mor := PO_morphism_of_monotone_JSLB_morph po po' f |}.
Next Obligation.
Proof.
  intros po po' f x y; simpl.
  apply class_of_inj.
  intros c; split; setoid_rewrite in_app_iff.
  - intros (d & Hd1 & Hd2).
    apply in_map_iff in Hd1 as [d' [<- Hd']].
    apply in_monotone_op in Hd' as [(z & Hz1 & Hz2)|(z & Hz1 & Hz2)].
    + destruct (is_in_monotone_preresntative_class_of
                  po' (f z) (map f (representative x)))
        as (w & Hw1 & Hw2).
      { apply in_map; trivial. }
      exists w; split; [left; trivial; fail|].
      transitivity (f d'); [trivial; fail|].
      transitivity (f z); [|trivial; fail].
      apply POM_mono; trivial.
    + destruct (is_in_monotone_preresntative_class_of
                  po' (f z) (map f (representative y)))
        as (w & Hw1 & Hw2).
      { apply in_map; trivial. }
      exists w; split; [right; trivial; fail|].
      transitivity (f d'); [trivial; fail|].
      transitivity (f z); [|trivial; fail].
      apply POM_mono; trivial.
  - intros (d & [Hd1|Hd1] & Hd2).
    + apply in_monotone_preresntative_class_of in Hd1 as (e & He1 & He2).
      apply in_map_iff in He1 as [e' [<- He']].
      apply (in_monotone_op_back1 _ _ _ y) in He' as (i & Hi1 & Hi2).
      exists (f i); split; [apply in_map; trivial; fail|].
      transitivity d; [assumption|].
      transitivity (f e'); [assumption|].
      apply POM_mono; trivial.
    + apply in_monotone_preresntative_class_of in Hd1 as (e & He1 & He2).
      apply in_map_iff in He1 as [e' [<- He']].
      apply (in_monotone_op_back2 _ _ x) in He' as (i & Hi1 & Hi2).
      exists (f i); split; [apply in_map; trivial; fail|].
      transitivity d; [assumption|].
      transitivity (f e'); [assumption|].
      apply POM_mono; trivial.
Qed.
Next Obligation.
Proof.
  intros po po' f.
  apply class_of_inj.
  intros x; split.
  - intros (d & Hd1 & Hd2).
    apply in_map_iff in Hd1 as [d' [<- Hd'%monotone_unit_empty]]; tauto.
  - intros (d & [] & Hd2).
Qed.

Program Definition monotone_JSLB_functor : Functor PO_cat JSLB_cat :=
  {| FO := monotone_JSLB;
     FA := monotone_JSLB_morph |}.
Next Obligation.
Proof.
  intros po.
  apply JSLBM_morphism_eq.
  apply POM_morphism_eq.
  intros a; cbn.
  rewrite map_id.
  apply class_of_representative.
Qed.
Next Obligation.
Proof.
  intros po po' po'' f g.
  apply JSLBM_morphism_eq.
  apply POM_morphism_eq.
  intros x; cbn.
  apply class_of_inj.
  intros y; split.
  - intros (z & Hz1 & Hz2).
    apply in_map_iff in Hz1 as (w & <- & Hw2).
    assert (In (f w) (map f (representative x))) as Hfw
        by (apply in_map; trivial).
    apply is_in_monotone_preresntative_class_of in Hfw as (u & Hu1 & Hu2).
    exists (g u); split; [apply in_map; trivial; fail|].
    etransitivity; [eassumption|].
    apply POM_mono; trivial.
  - intros (z & Hz1 & Hz2).
    apply in_map_iff in Hz1 as (w & <- & Hw2).
    apply in_monotone_preresntative_class_of in Hw2 as (u & Hu1 & Hu2).
    apply in_map_iff in Hu1 as (v & <- & Hv2).
    exists (g (f v)); split.
    + apply in_map_iff; eauto.
    + transitivity (g w); [eassumption|].
      apply POM_mono; trivial.
Qed.


(*************************************************************)
(*   Copyright Dominique Larchey-Wendling [*]                 *)
(*                                                            *)
(*                             [*] Affiliation LORIA -- CNRS  *)
(*************************************************************)
(*      This file is distributed under the terms of the       *)
(*         CeCILL v2 FREE SOFTWARE LICENSE AGREEMENT          *)
(*************************************************************)

(* ** Object-level encoding of bounded universal quantification I *)

Require Import Arith Lia List Bool Setoid.

From Undecidability.Shared.Libs.DLW.Utils
  Require Import utils_tac gcd prime binomial sums bool_nat rel_iter.

From Undecidability.H10.ArithLibs
  Require Import luca.

From Undecidability.H10.Matija
  Require Import cipher.

From Undecidability.H10.Dio
  Require Import dio_logic dio_expo.

Set Implicit Arguments.

Set Default Proof Using "Type".

Local Infix "≲" := binary_le (at level 70, no associativity).
Local Notation power := (mscal mult 1).
Local Notation "∑" := (msum plus 0).
Local Infix "⇣" := nat_meet (at level 40, left associativity).
Local Infix "⇡" := nat_join (at level 50, left associativity).

(* This the Diophantine encoding of binomial coefficents *)

Section dio_fun_binomial.

  Let plus_cancel_l : forall a b c, a + b = a + c -> b = c.
  Proof. intros; lia. Qed.

  Hint Resolve Nat.mul_add_distr_r : core.

  (* We use this characterization with Newton's devel

      (1+q)^n = ∑ binomial(n,i).q^i   when q > 2^n

    *)

  Let is_binomial_eq b n k :
         b = binomial n k
     <-> exists q, q = power (1+n) 2
                /\ is_digit (power n (1+q)) q k b.
  Proof.
    split.
    + intros ?; subst.
      set (q := power (1+n) 2).
      assert (Hq : q <> 0).
      { unfold q; generalize (@power_ge_1 (S n) 2); intros; simpl; lia. }
      set (c := power n (1+q)).
      exists q; split; auto; split.
      * apply binomial_lt_power.
      * fold c.
        destruct (le_lt_dec k n) as [ Hk | Hk ].
        - exists (∑ (n-k) (fun i => binomial n (S k+i) * power i q)),
                 (∑ k (fun i => binomial n i * power i q)); split; auto.
          2: { apply sum_power_lt; auto; intros; apply binomial_lt_power. }
          rewrite Nat.mul_add_distr_r, <- mult_assoc, <- power_S.
          rewrite <- sum_0n_distr_r with (1 := Nat_plus_monoid) (3 := Nat_mult_monoid); auto.
          rewrite <- plus_assoc, (plus_comm _ (∑ _ _)).
          rewrite <- msum_plus1 with (f := fun i => binomial n i * power i q); auto.
          rewrite plus_comm.
          unfold c.
          rewrite Newton_nat_S.
          replace (S n) with (S k + (n-k)) by lia.
          rewrite msum_plus; auto; f_equal; apply msum_ext.
          intros; rewrite power_plus; ring.
        - exists 0, c.
          rewrite binomial_gt; auto.
          rewrite Nat.mul_0_l; split; auto.
          unfold c.
          apply lt_le_trans with (power (S n) q).
          ++ rewrite Newton_nat_S.
             apply sum_power_lt; auto.
             intros; apply binomial_lt_power.
          ++ apply power_mono; lia.
    + intros (q & H1 & H3).
      assert (Hq : q <> 0).
      { rewrite H1; generalize (@power_ge_1 (S n) 2); intros; simpl; lia. }
      rewrite Newton_nat_S in H3.
      apply is_digit_fun with (1 := H3).
      destruct (le_lt_dec k n) as [ Hk | Hk ].
      * red; split.
        - subst; apply binomial_lt_power.
        - exists (∑ (n-k) (fun i => binomial n (S k+i) * power i q)),
                 (∑ k (fun i => binomial n i * power i q)); split.
          2: {  apply sum_power_lt; auto; intros; subst; apply binomial_lt_power. }
          rewrite Nat.mul_add_distr_r, <- mult_assoc, <- power_S.
          rewrite <- sum_0n_distr_r with (1 := Nat_plus_monoid) (3 := Nat_mult_monoid); auto.
          rewrite <- plus_assoc, (plus_comm _ (∑ _ _)).
          rewrite <- msum_plus1 with (f := fun i => binomial n i * power i q); auto.
          rewrite plus_comm.
          replace (S n) with (S k + (n-k)) by lia.
          rewrite msum_plus; auto; f_equal.
          apply msum_ext.
          intros; rewrite power_plus; ring.
      * rewrite binomial_gt; auto.
        rewrite <- Newton_nat_S.
        split; try lia.
        exists 0, (power n (1+q)); split; auto.
        apply lt_le_trans with (power (S n) q).
        - rewrite Newton_nat_S.
          apply sum_power_lt; auto.
          subst; intros; apply binomial_lt_power.
        - apply power_mono; lia.
  Qed.

  Lemma dio_fun_binomial n k : 𝔻F n -> 𝔻F k -> 𝔻F (fun ν => binomial (n ν) (k ν)).
  Proof.
    dio by lemma (fun ν => is_binomial_eq (ν 0) (n ν⭳) (k ν⭳)).
  Defined.

End dio_fun_binomial.

#[export] Hint Resolve dio_fun_binomial : dio_fun_db.

Local Fact dio_fun_binomial_example : 𝔻F (fun ν => binomial (ν 0) (ν 1)).
Proof. dio auto. Defined.

(* Check dio_fun_binomial_example. *)
(* Eval compute in df_size_Z (proj1_sig dio_fun_binomial_example). *)

(* This result comes from Lucas' theorem *)

Theorem binary_le_binomial n m : n ≲ m <-> rem (binomial m n) 2 = 1.
Proof.
  split.
  + induction 1 as [ n | n m H1 H2 IH2 ].
    * rewrite binomial_n0, rem_lt; lia.
    * rewrite lucas_lemma with (1 := prime_2) (2 := div_rem_spec1 m 2) (4 := div_rem_spec1 n 2);
        try (apply div_rem_spec2; lia).
      rewrite mult_comm, <- rem_mult_rem, IH2, Nat.mul_1_r.
      revert H1.
      generalize (rem_2_is_0_or_1 m) (rem_2_is_0_or_1 n).
      intros [ G1 | G1 ] [ G2 | G2 ]; rewrite G1, G2; intros; try lia.
      ++ rewrite binomial_n0, rem_lt; lia.
      ++ rewrite binomial_n0, rem_lt; lia.
      ++ rewrite binomial_n1, rem_lt; lia.
  + induction on n m as IH with measure m.
    destruct (eq_nat_dec m 0) as [ Hm | Hm ].
    * destruct n; try (intros; constructor; fail).
      subst; rewrite binomial_gt, rem_lt; lia.
    * generalize (div_rem_spec1 m 2) (div_rem_spec1 n 2); intros H1 H2.
      rewrite lucas_lemma with (1 := prime_2) (2 := H1) (4 := H2); auto;
        try (apply div_rem_spec2; lia).
      rewrite rem_2_mult; intros (H3 & H4).
      apply IH in H3; try lia.
      constructor 2; auto.
      revert H4.
      generalize (rem_2_is_0_or_1 m) (rem_2_is_0_or_1 n).
      intros [ G1 | G1 ] [ G2 | G2 ]; rewrite G1, G2; intros; try lia.
      rewrite binomial_gt, rem_lt in H4; lia.
Qed.

Theorem dio_rel_binary_le x y : 𝔻F x -> 𝔻F y -> 𝔻R (fun v => x v ≲ y v).
Proof.
  dio by lemma (fun v => binary_le_binomial (x v) (y v)).
Defined.

#[export] Hint Resolve dio_rel_binary_le : dio_rel_db.

Theorem dio_fun_nat_meet a b : 𝔻F a -> 𝔻F b -> 𝔻F (fun ν => a ν ⇣ b ν).
Proof.
  dio by lemma (fun v => nat_meet_dio (v 0) (a v⭳) (b v⭳)).
Defined.

#[export] Hint Resolve dio_fun_nat_meet : dio_fun_db.


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

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

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

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

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

Fixpoint less (less_arg0 : natural) (less_arg1 : natural) : bool
           := match less_arg0, less_arg1 with
              | x, Zero => false
              | Zero, Succ x => true
              | Succ x, Succ y => less x y
              end.
Fixpoint eqb (n m: natural) : bool :=
match n, m with
   | Zero, Zero => true
   | Zero, Succ _ => false
   | Succ _, Zero => false
   | Succ n', Succ m' => eqb n' m'
end.
Fixpoint count (count_arg0 : natural) (count_arg1 : lst) : natural
           := match count_arg0, count_arg1 with
              | x, Nil => Zero
              | x, Cons y z => if eqb x y then Succ (count x z) else count x z
              end.

Fixpoint insort (insort_arg0 : natural) (insort_arg1 : lst) : lst
           := match insort_arg0, insort_arg1 with
              | i, Nil => Cons i Nil
              | i, Cons x y => if less i x then Cons i (Cons x y) else Cons x (insort i y)
              end.

Fixpoint sort (sort_arg0 : lst) : lst
           := match sort_arg0 with
              | Nil => Nil
              | Cons x y => insort x (sort y)
              end.

Lemma Nat_beq_eq : forall (x y : natural), eqb x y = true -> x = y.
Proof.
   intros.
   generalize dependent y.
   induction x.
   - intros. destruct y.
   + simpl in H. apply IHx in H. rewrite H. reflexivity.
   + discriminate.

   - intros. destruct y.

   + discriminate.
   + reflexivity.

Qed.

Theorem theorem0 : forall (x : natural) (y : natural) (z : lst), not (eq x y) -> eq (count x (insort y z)) (count x z).
Proof.
   intros.
  induction z.
  - simpl. destruct (eqb x n) eqn:?.
    + destruct (less y n) eqn:?.
      * simpl. destruct (eqb x y) eqn:?.
        --
lfind.  contradiction.
Admitted.