Require Import List.

Require Import Logic.Class.Eq.

Require Import Logic.Rel.Properties.

Require Import Logic.Func.Replace.

Require Import Logic.List.In.
Require Import Logic.List.Remove.
Require Import Logic.List.Replace.
Require Import Logic.List.Include.
Require Import Logic.List.Coincide.
Require Import Logic.List.InjectiveOn.

Require Import Logic.Fol.Syntax.
Require Import Logic.Fol.Functor.
Require Import Logic.Fol.Variable.
Require Import Logic.Fol.Congruence.

(* Returns the list of free variables (with possible duplication) in a term     *)
(* When facing a forall quantification, we need to be able to remove a variable *)
(* from the list of free variables of the subterm, hence decidable equality.    *)
Fixpoint Fr (v:Type) (e:Eq v) (p:P v) : list v :=
    match p with
    | Bot           => nil
    | Elem x y      => cons x (cons y nil)
    | Imp p1 p2     => Fr v e p1 ++ Fr v e p2
    | All x p1      => remove x (Fr v e p1)
    end.

Arguments Fr {v} {e} _.

(* The free variables of the proposition (fmap f p) are a subset of the images  *)
(* by f of the free variables of the proposition p.                             *)
Lemma free_fmap : forall (v w:Type) (e:Eq v) (e':Eq w) (f:v -> w) (p:P v),
    Fr (fmap f p) <= map f (Fr p).
Proof.
    intros v w e e' f.
    induction p as [|x y|p1 IH1 p2 IH2|x p1 IH1]; simpl.
    - apply incl_refl.
    - apply incl_refl.
    - rewrite map_app. apply incl_app.
        + apply incl_appl, IH1.
        + apply incl_appr, IH2.
    - apply incl_tran with (remove (f x) (map f (Fr p1))).
        + apply remove_mon, IH1.
        + apply incl_tran with (map f (remove x (Fr p1))).
            { apply remove_map_incl. }
            { apply incl_refl. }
Qed.

(* A free variable is a variable                                                *)
Lemma free_var : forall (v:Type) (e:Eq v) (p:P v), Fr p <= var p.
Proof.
    intros v e.
    induction p as [|x y|p1 IH1 p2 IH2|x p1 IH1]; simpl.
    - apply incl_refl.
    - apply incl_refl.
    - apply incl_app2; assumption.
    - apply incl_tran with (Fr p1).
        + apply remove_incl.
        + apply incl_tl. assumption.
Qed.

Lemma free_inj : forall (v w:Type) (e:Eq v) (e':Eq w) (f:v -> w) (p:P v),
    injective_on (var p) f -> Fr (fmap f p) = map f (Fr p).
Proof.
    intros v w e e' f.
    induction p as [|x y|p1 IH1 p2 IH2|x p1 IH1]; simpl; intros H.
    - reflexivity.
    - reflexivity.
    - rewrite map_app, IH1, IH2.
        + reflexivity.
        + apply injective_on_appr with (var p1). assumption.
        + apply injective_on_appl with (var p2). assumption.
    - rewrite IH1. apply remove_inj2. apply injective_on_incl with (cons x (var p1)).
        + apply incl_cons.
            { left. reflexivity. }
            { apply incl_tl, free_var. }
        + assumption.
        + apply injective_on_cons with x. assumption.
Qed.

Lemma free_replace1 : forall (v:Type) (e:Eq v) (p:P v) (x y:v),
    ~ y :: (var p)  ->
    ~ x :: (Fr p) ->
    Fr (fmap (y // x) p) = Fr p.
Proof.
    intros v e p x y Hy Hx.
    rewrite (free_inj v v e e).
    - rewrite <- map_id. apply coincide_map. unfold coincide.
      intros u H. rewrite replace_not_x.
        + reflexivity.
        + intros E. subst. apply Hx, H.
    - apply replace_inj. assumption.
Qed.

Lemma free_replace2 : forall (v:Type) (e:Eq v) (p:P v) (x y:v),
    ~ y :: (var p)  ->
      x :: (Fr p) ->
     forall (z:v),
        z :: Fr (fmap (y // x) p) <->
        z = y \/ (z :: Fr p) /\ z <> x.
Proof.
    intros v e p x y Hy Hx z. rewrite (free_inj v v e e). split.
    - intros H. destruct (eqDec z y) as [Hzy|Hzy].
        + left. assumption.
        + right. apply in_map_iff in H. destruct H as [u [H1 H2]]. split.
            { destruct (eqDec u x) as [Hux|Hux].
                { rewrite Hux, replace_x in H1. exfalso.
                  apply Hzy. symmetry. assumption. }
                { rewrite replace_not_x in H1.
                    { rewrite <- H1. assumption. }
                    { assumption. }}}
            { intros Hzx. rewrite Hzx in H1.
              destruct (eqDec u x) as [Hux|Hux].
                { rewrite Hux, replace_x, <- Hzx in H1.
                  apply Hzy. symmetry. assumption. }
                { rewrite replace_not_x in H1.
                    { apply Hux. assumption. }
                    { assumption. }}}
   - intros [H|[H1 H2]]; apply in_map_iff.
        + exists x. split.
            { rewrite replace_x. symmetry. assumption. }
            { assumption. }
        + exists z. split.
            { rewrite replace_not_x.
                { reflexivity. }
                { assumption. }}
            { assumption. }
    - apply replace_inj. assumption.
Qed.

Lemma free_congruence : forall (v:Type) (e:Eq v),
    congruence (fun (p q:P v) => Fr p = Fr q).
Proof.
    intros v e. split.
    - split.
        + intros p. reflexivity.
        + split.
            { intros p q H. symmetry. assumption. }
            { intros p q r Hpq Hqr.
              apply eq_trans with (Fr q); assumption. }
    - split.
        + intros p1 p2 q1 q2 H1 H2. simpl. rewrite H1, H2. reflexivity.
        + intros x p1 q1 H1. simpl. rewrite H1. reflexivity.
Qed.


Require Import
  HoTT.Classes.interfaces.abstract_algebra
  HoTT.Classes.interfaces.orders
  HoTT.Classes.interfaces.naturals
  HoTT.Classes.theory.rings (* for Ring -> SemiRing *).

Class IntegersToRing@{i j} (A:Type@{i})
  := integers_to_ring: forall (R:Type@{j}) `{IsRing R}, A -> R.
Arguments integers_to_ring A {_} R {_ _ _ _ _ _} _.

Class Integers A {Aap:Apart A} {Aplus Amult Azero Aone Anegate Ale Alt}
  `{U : IntegersToRing A} :=
  { integers_ring :> @IsRing A Aplus Amult Azero Aone Anegate
  ; integers_order :> FullPseudoSemiRingOrder Ale Alt
  ; integers_to_ring_mor:> forall {B} `{IsRing B}, IsSemiRingPreserving (integers_to_ring A B)
  ; integers_initial: forall {B} `{IsRing B} {h : A -> B} `{!IsSemiRingPreserving h} x,
      integers_to_ring A B x = h x}.

Section specializable.
  Context (Z N : Type) `{Integers Z} `{Naturals N}.

  Class IntAbs := int_abs_sig : forall x,
    { n : N | naturals_to_semiring N Z n = x } |_|
    { n : N | naturals_to_semiring N Z n = -x }.

  Definition int_abs `{ia : IntAbs} (x : Z) : N :=
    match int_abs_sig x with
    | inl (n;_) => n
    | inr (n;_) => n
    end.

  Definition int_to_nat `{Zero N} `{ia : IntAbs} (x : Z) : N :=
    match int_abs_sig x with
    | inl (n;_) => n
    | inr (n;_) => 0
    end.
End specializable.


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

6.2 テーマ2 有限群とラグランジュの定理
======
2018_05_02 @suharahiromichi

2021_03_06 @suharahiromichi
 *)

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

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

Section Lagrange.
(**
# 6.2.1 有限群の定義
 *)

  Open Scope group_scope.

  (* gT は finGroupType（有限群）型クラスの型インスタンスである。 *)
  Variable gT : finGroupType.

(**
## 定理：任意の剰余類の濃度は、もとの集合の濃度に等しい

テキストの順番とは異なりますが、
これは fingroup で証明されている補題を使って証明できるため先に証明します。
``csm_6_2_1_fingroup.v`` も参照してください。

使用するのは、次のふたつの補題です。
*)
(**
### 使用する補題 ``rcosetsP``

この補題の意味は以下です。

任意の集合Aが、
適当なxについて$H x$と等しいこと（適当なxの剰余類であること）と、
Aが$H \backslash G$の要素であることは、必要十分条件である：

$$(\exists x, x \in G \land A = H x) \iff A \in H \backslash G$$
*)
  Section Test.
    Variable A H G : {set gT}.

    Check rcosetsP
      : reflect (exists2 x, x \in G & A = H :* x) (A \in rcosets H G).
  End Test.

(**
### 使用する補題 ``card_rcoset``

この補題の意味は以下です。

任意のxの剰余類の濃度は、もとの集合の濃度に等しい：

$$\forall x, |A x| = |A|$$
*)
  Check card_rcoset
    : forall (gT : finGroupType) (A : {set gT}) (x : gT), #|A :* x| = #|A|.

(**
### 証明したい補題 ``myCard_rcoset``

証明したいのは、以下の命題です。

剰余群に含まれる任意の剰余類の濃度は、もとの集合の濃度に等しい：

Goal: $$ A \in H \backslash G \to |A| = |H| $$

補題：``card_rcoset``は、任意のxに対して剰余類を決めているのに対して、
証明したい命題は、任意の$H \backslash G$の要素で剰余類を選んでいます。
そこに違いがあります。
*)
  Lemma myCard_rcoset (G H : {group gT}) (A : {set gT}) :
    A \in rcosets H G -> #|A| = #|H|.
  Proof.
    move/rcosetsP.
(**
Goal: $$ (\exists x, x \in G \land A = H x) \to |A| = |H| $$
*)
    case.
(**
Goal: $$ \forall x, x \in G \to A = H x \to |A| = |H| $$
*)
    move=> a asinG ->.
    rewrite card_rcoset.
(**
Goal: $$ |H| = |H| $$
*)
    done.

    Restart.
    case/rcosetsP => a ainG ->.
      by apply: card_rcoset.
  Qed.

(**
# 6.2.2 部分群の性質
*)
(**
## 部分群

以下では、$G$を群、$H$をその部分群とします。すなわち、$ H \subset G $
*)
  Variable G H : {group gT}.              (* G, H は有限群型の変数 *)
  Hypothesis HG : H \subset G.

(**
## 同値関係の定義

bool型の二項関係（$\sim$）を定義します。

$$ x \sim y \equiv x y^{-1} \in H $$
*)
  Definition R := [rel x y | x * y^-1 \in H].
  Check R : gT -> gT -> bool.               (* simpl_rel gT. *)
(**
テキストと異なりますが、Coq側でも演算子``~``を定義して使うことにします。
*)
  Notation "x ~ y" := (R x y) (at level 40, left associativity).

(**
## 同値関係の証明

$\sim$が、同値関係であることを証明します。
同値関係の定義 ``equivalence_rel`` は、 ``ssrbool.v``
で定義されていますので、これを証明します。
*)
  Print equivalence_rel.
  (*
    fun (T : Type) (R : rel T) => forall x y z : T, R z z * (R x y -> R x z = R y z).
   *)
  Set Printing All.
  Print equivalence_rel.
  (*
    fun (T : Type) (R : rel T) =>
    forall x y z : T,
    prod (is_true (R z z)) (forall _ : is_true (R x y), @eq bool (R x z) (R y z))
   *)
  Unset Printing All.

(**
``*`` は、prod の意味で、Type型のふたつの直積です。

これに対して、お馴染みの ``/\`` は、andの意味で、Prop型のふたつの直積を示します。

ここでは、両者は同じとといってよいと思います。
それぞれコンストラクタを適用することでゴールをふたつに分解できます。

- prod のコンストラクタは pair
- and のコンストラクタは conj

なお、conj を適用するときに、タクティクsplitを使うこともできます。
 *)

(**
また、``=`` の両辺がboolであるなら、boolの値がおなじことを示すので、
これは、論理式としての必要十分条件（``<->``) を示します。

``apply/idP/idP`` を実行することで、
ゴールを必要条件と十分条件のふたつに分解できます。
*)

  Lemma equiv_rel_R : equivalence_rel R.
  Proof.
    rewrite /equivalence_rel => x y z.
(**
ゴールは、MathComp の表記で次のようになります：

```z ~ z * (x ~ y -> (x ~ z = y ~ z))```
 *)
(**
Goal: $$ z \sim z \land (x \sim y\ \to (x\ \sim z \iff y \sim z)) $$

前述のとおり、pairを適用してでゴールを分けます：
*)
    apply: pair => /=.
(**
Goal: $$ z z^{-1} \in H $$
*)
    - by rewrite mulgV group1.
(**
Goal: $$ x y^{-1} \in H -> (x z^{-1} \in H \iff y z^{-1} \in H) $$

``=`` は ``<->`` の意味なので、前述のとおり ``apply/idP/idP`` を実行します。
*)
    - move=> xRinvy.                        (* xRinvy : x * y^-1 \in H *)
      apply/idP/idP.
      (* -> *)
      + move/groupVr in xRinvy.             (* xRinvy : (x * y^-1)^-1 \in H *)

(**
補題（積は閉じている）： groupM : ``x in H -> y in H -> x * y in H`` を使って、
ゴールの前提部の ``x * z^-1 \in H`` を ``(x * y^-1)^-1 * (x * z^-1) \in H``
に書き換えます。
 *)
        Check groupM : forall (gT : finGroupType) (G : {group gT}) x y,
            x \in G -> y \in G -> x * y \in G.
        Check groupM xRinvy : x * z^-1 \in H -> (x * y^-1)^-1 * (x * z^-1) \in H.
        move/(groupM xRinvy).
(*
        rewrite invMg.
        rewrite invgK.
        rewrite mulgA.
        rewrite -(mulgA y).
        rewrite mulVg.
        rewrite mulg1.
        done.
*)
          by rewrite invMg invgK mulgA -(mulgA y) mulVg mulg1.

      (* <- *)
      + Check (groupM xRinvy) : y * z^-1 \in H -> x * y^-1 * (y * z^-1) \in H.
        move/(groupM xRinvy).
          by rewrite mulgA -(mulgA x) mulVg mulg1.
  Qed.

(**
# 6.2.3 剰余類の性質の形式化

``myCard_rcoset`` はすでに最初の節で証明していますので、次の定理の証明をします。
*)
(**
## 定理：

$$x \in G \to H x = \\{y \in G\ |\ x \sim y \\}$$
*)
  Lemma coset_equiv_class (x : gT) :
    x \in G -> H :* x = [set y in G | x ~ y].
  Proof.
    move=> xinG.
(**
Goal: ``H :* x = [set y in G | x ~ y]``

集合が等しいことを証明するには、
集合の任意の要素が同じなら、集合が等しいことを使います。
 *)
    apply/setP => /= y.
(**
Goal: ``(y \in H :* x) = (y \in [set y0 in G | x ~ y0])```

右辺の \in に関する簡約を行います。
 *)
    rewrite inE.
(**
Goal: ``(y \in H :* x) = (y \in G) && (x ~ y)``

ゴールを必要条件と十分条件に分けます。
*)
    apply/idP/idP.
    (* -> *)
(**
Goal: ``y \in H :* x -> (y \in G) && (x * y^-1 \in H)``

前提を rcoset (mulgの像) の定義に変換します。∃が現れますから、前提の∃にはcaseを使います。
*)
    - case/rcosetP => z zinH -> {y}.
      apply/andP.
      apply: conj.         (* split *)

(**
Goal: ``z * x \in G``

掛算を ``z \in G`` と ``x \in G`` に分けます。前者は前提にあるので後者が残ります。
*)
      Check groupM : forall (gT : finGroupType) (G : {group gT}) (x y : gT),
          x \in G -> y \in G -> x * y \in G.

      + rewrite groupM //.                 (* apply: groupM => // *)
(**
Goal: ``z \in G``

から ``HG : H ⊂ G`` かつ ``z ∈ H`` なので、``z ∈ G`` は明らかです。

テキストは以下のようになっていますが、
```
        move/subsetP : HG => HG'.
          by move: (HG' _ zinH).
```
generaralize を使ったほうが、解りやすいと思います。一行でも書ける。
*)
        move: HG z zinH.
        move/subsetP.
(**
Goal: {subset H <= G} -> forall z : gT, z \in H -> z \in G
*)
        done.       (* 3行を1行にまとめると、by move/subsetP : HG z zinH *)

(**
Goal: ``x * (z * x)^-1 \in H``
 *)
      + by rewrite invMg mulgA mulgV mul1g groupV.

    (* <- *)
    - case/andP => yinG xinvyinH.
      apply/rcosetP.
(**
ex_intro2 を適用して exists2 を消します。
テキストにあるプレースホルダーを埋めると次のようになります。
*)
      Check (ex_intro2 (fun g => g \in H)
                       (fun a => y = a * x)
                       (y * x^-1)) :
        y * x^-1 \in H ->
        y = y * x^-1 * x ->
        exists2 a : gT, a \in H & y = a * x.

      apply: (ex_intro2 (fun g => g \in H)   (* _ *)
                        (fun a => y = a * x) (* _ *)
                        (y * x^-1)).

      + by rewrite -groupV invMg invgK.
      + by rewrite -mulgA mulVg mulg1.
  Qed.

(**
## 補題：

$H \backslash G = G\ /\ \sim$

右辺は、``G`` の ``〜`` についての商である。
*)
  Lemma rcosets_equiv_part : rcosets H G = equivalence_partition R G.
  Proof.
    apply/setP => /= X.
    rewrite /rcosets /equivalence_partition.
(**
Goal:

```(X \in [set rcoset H x | x in G]) = (X \in [set [set y in G | x ~ y] | x in G])```

set の内側を取り出すと、

左辺： ``rcoset H x``

右辺： ``[set y in G | x ~ y]``

となり、``H :* x = rcoset H x``
であることから、定理 coset_equiv_class と同じであることが判ります。

まず、必要条件と十分条件に分けます。
 *)
    apply/idP/idP.
    (* -> *)
(**
``H :* x = rcoset H x`` の置き換えには、rcosetP か rcosetsP が使えます。
``csm_6_2_1_fingroup.v`` も参照してください。
*)
    - case/rcosetsP => x0 x0inG X_Hx.
(**
Goal: ``X \in [set [set y in G | x ~ y] | x in G]``
*)
      (* apply/imsetP *)
      Check @imsetP _ _ (fun x => [set y in G | x ~ y]) (mem G) X
        : reflect (exists2 x : gT, x \in G & X = [set y in G | x ~ y])
                  (X \in [set [set y in G | x ~ y] | x in G]).
      apply/(@imsetP _ _ (fun x => [set y in G | x ~ y]) (mem G) X).
(**
Goal: ``exists2 x : gT, x \in G & X = [set y in G | x ~ y]``
*)
      (* プレースホルダーを埋めると次になる。 *)
      Check (ex_intro2 (fun g => g \in G)
                       (fun x => (X = [set y in G | x ~ y]))
                       x0) :
        x0 \in G ->
               X = [set y in G | x0 ~ y] ->
               exists2 g : gT, g \in G & X = [set y in G | g ~ y].
      apply: (ex_intro2 (fun g => g \in G)
                        (fun x => (X = [set y in G | x ~ y]))
                        x0) => //.
(**
Goal: ``X = [set y in G | x0 ~ y]``
*)
        by rewrite -coset_equiv_class.      (* 直前の補題 *)

    (* <- *)
    - case/imsetP => x1 xinG Hypo.
      apply/imsetP.

      (* プレースホルダーを埋めると次になる。 *)
      Check (ex_intro2 (fun g => g \in G)
                       (fun x => X = rcoset H x)
                       x1) :
        x1 \in G ->
               X = rcoset H x1 ->
               exists2 x : gT, x \in G & X = rcoset H x.
      apply: (ex_intro2 (fun g => g \in G)
                        (fun x => X = rcoset H x)
                        x1).
      + done.
      + rewrite rcosetE.
        by rewrite coset_equiv_class.
  Qed.

(**
## 補題：

$H \backslash G$ は、$G$の分割である。

商であるということと、分割になっているということは区別されます。
ひとつまえの補題と違って、後者では$\sim$が明示的に現れないことがポイントです。

ラグランジュの定理の証明で実際に使用するのは、この補題です。
*)
  Lemma partition_rcosets : partition (rcosets H G) G.
  Proof.
(**
分割の定義は、次のようになります。
*)
    (* rewrite /partition /trivIset /cover. *)
(**
   \bigcup_(B in rcosets H G) B == G &&
   \sum_(B in rcosets H G) #|B| == #|\bigcup_(B in rcosets H G) B| &&
   set0 \notin rcosets H G
*)
    rewrite rcosets_equiv_part.
(**
goal: ``partition (equivalence_partition R G) G``
*)

    Check equivalence_partitionP : forall (T : finType) (R : rel T) (D : {set T}),
        {in D & &, equivalence_rel R} -> partition (equivalence_partition R D) D.
    apply/equivalence_partitionP => x y z xinG yinG zinG.
(**
goal: ```z ~ z * (x ~ y -> x ~ z = y ~ z)```
*)
      by apply : equiv_rel_R.
  Qed.

(**
# 6.2.4 ラグランジュの定理
 *)
(**
## 指数について

テキストにもあるように、
一般的な数学の記法では、$(G : H)$ は（$H$による$G$の）右剰余類の個数を表します。
これを（$H$による$G$の）指数ともいいます。

ラグランジュの定理は、$G$の濃度は、その部分群$H$の濃度で割り切ることができ、
その商は、$H$による$G$の指数である、というものです。すなわち、

$$(G : H) = |H \backslash G|$$

なお、MathComp では、指数は、``#|_ : _|``という2項のNotationです。
これが定義であることを確認します。
*)
  Goal #|G : H| = #|rcosets H G|.
  Proof.
    rewrite /indexg.
    done.
  Qed.

(**
（参考）右剰余類の個数も左剰余類の個数もおなじなので、
fingroup.v にある補題``card_lcosets``で、次が成り立ちます：

$$(G : H) = |G / H| = |H \backslash G|$$
*)
  Goal #|G : H| = #|lcosets H G|.
  Proof.
    rewrite card_lcosets.
    done.
  Qed.

(**
## 使用する補題 ``card_partition``

finset.v で証明されている補題です。P（集合の集合）が D（集合）の分割になっているならば、
Pの全ての要素の濃度の総和は、Dの濃度に等しい。

$$ |D| = \sum_{A \in P}\ |A|$$
*)
  Check card_partition
    : forall (T : finType) (P : {set {set T}}) (D : {set T}),
      partition P D -> #|D| = \sum_(A in P) #|A|.

(**
これに直前に証明した補題(partition_rcosets)を前提に与えます。

すると、剰余群のすべての要素（すべての剰余類）の濃度の総和は、
群$G$の濃度に等しい、となります。これは、剰余群は、群$G$の分割であるためですね。

$$ |G| = \sum_{A \in H \backslash G}\ |A| $$
*)
  Check (card_partition partition_rcosets)
    : #|G| = \sum_(A in rcosets H G) #|A|.

(**
## 使用する補題 ``eq_bigr``

myCard_rcoset の $|A| = |H|$ を Σの中に適用して書き換える補題です。

``\sum_`` (Σ) などの ``\bigop[/]_`` の中はλ変数で束縛されていますから、
rewriteでは書き換えできないので、``bigop.v`` で証明された補題を使います。
``eq_bigr`` は、bigopに一般に証明されていますが、``\sum_`` (Σ) ならば次のようになります。

$$ \sum_{i \in H \backslash G}\ |A| = \sum_{i \in H \backslash G}\ |H| $$
*)

(**
これを使って、最初に証明した補題 myCard_rcoset でΣの中を書き換えると次のようになります。
*)
  Check @myCard_rcoset G H : forall A : {set gT},
      A \in rcosets H G -> #|A| = #|H|.
  Check ((eq_bigr (fun _ => #|H|)) (@myCard_rcoset G H))
    : \sum_(A in rcosets H G) #|A| = \sum_(A in rcosets H G) #|H|.

(**
## 総和についての補題 ``sum_nat_const``

総和についての補題を紹介します。
テキストでは、補題``big_const``を使って``iter``の式に変換していますが、
そのものずばりの補題があるので、それを使います。
これは、定数の総和をもとめる $\sum_{0 <= i < n} c = c\ n$ の集合版です。

$$\sum_{i \in A} c = |A|\ c$$
 *)
  Check sum_nat_const
    : forall (fT : finType) (A : pred fT) (c : nat), \sum_(i in A) c = (#|A| * c)%N.

(**
## 定理の証明

証明したいのは以下です。
$G$を群、$H$をその部分群とするとき、
$G$の濃度は、$H$の濃度と（$H$による$G$の）指数の積に等しい：

$$|G| = |H|\ (G : H)$$
*)
  Theorem myLagrange : #|G| = (#|H| * #|G : H|)%nat.
  Proof.
(**
Goal: $$|G| = |H|\ (G : H)$$
*)
    rewrite (card_partition partition_rcosets).
(**
Goal: $$\sum_{A \in H \backslash G} |A| = |H|\ (G : H)$$
*)
    rewrite ((eq_bigr (fun _ => #|H|)) (@myCard_rcoset G H)).
(**
Goal: $$\sum_{A \in H \backslash G} |H| = |H|\ (G : H)$$
*)
    rewrite sum_nat_const.
(**
Goal: $$|H \backslash G|\ |H| = |H|\ |G : H|$$
*)
    rewrite /indexg.
      by rewrite mulnC.
  Qed.

End Lagrange.

(* END *)


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

From Undecidability.Shared.Libs.DLW
  Require Import utils finite pos vec.

From Undecidability.MuRec.Util
  Require Import recalg recursor minimizer ra_ca.

Set Implicit Arguments.

Notation "[| f |]" := (@ra_rel _ f) (at level 0).

Section soundness_and_completeness.

  (* By induction on the ra_ca predicate *)

  Lemma ra_ca_inc_bs k (f : recalg k) v x : (exists n, [f;v] -[n>> x) -> [f;v] ▹ x.
  Proof.
    intros (n & H); revert H.
    induction 1 as [ n v | v | v
                   | k v p
                   | k i f gj v n w q x H1 IH1 H2 IH2
                   | k f g v n x H1 IH2
                   | k f g v n p x q y H1 IH1 H2 IH2
                   | k f v p n w q H1 IH1 H2 IH2 ]; try (constructor; auto; fail).
    apply in_ra_bs_comp with w; auto.
    apply in_ra_bs_rec_S with x; auto.
    apply in_ra_bs_min with w; auto.
  Qed.

  (* By induction on the ra_bs predicate *)

  Lemma ra_bs_inc_rel k (f : recalg k) v x : [f;v] ▹ x -> [|f|] v x.
  Proof.
    induction 1 as [ n v | v | v
                   | k v p
                   | k i f gj v w x H1 IH1 H2
                   | k f g v n x H1
                   | k f g v n x y H1 IH1 H2
                   | k f v n w H1 IH1 H2 ]; try reflexivity.
    exists w; split; auto; intros; rewrite vec_pos_set; auto.
    red; unfold s_rec; simpl; auto.
    rewrite ra_rel_fix_rec in IH1 |- *; unfold s_rec in IH1 |- *.
    simpl in IH1 |- *; exists x; auto.
    rewrite ra_rel_fix_min; unfold s_min; split; auto.
    intros y Hy.
    exists (vec_pos w (nat2pos Hy)).
    generalize (IH1 (nat2pos Hy)).
    rewrite pos2nat_nat2pos.
    eqgoal; do 2 f_equal.
  Qed.

  (* By induction on f *)

  Lemma ra_rel_inc_ca k (f : recalg k) v x : [|f|] v x -> exists n, [f;v] -[n>> x.
  Proof.
    revert v x; induction f as [ k | | | k p | k i f gj Hf Hgj
                               | k f g Hf Hg
                               | ]; intros v x.
    rewrite ra_rel_fix_cst; unfold s_cst; intros []; exists 1; constructor.
    rewrite ra_rel_fix_zero; unfold s_zero; intro; subst; exists 1; constructor.
    rewrite ra_rel_fix_succ; unfold s_succ; intro; subst; exists 1; constructor.
    rewrite ra_rel_fix_proj; unfold s_proj; intros []; exists 1; constructor.

    rewrite ra_rel_fix_comp; unfold s_comp; intros (w & H1 & H2).
    apply Hf in H1; destruct H1 as (n & H1).
    assert (forall p, exists n, [vec_pos gj p;v] -[n>> vec_pos w p) as H3.
      intros p; specialize (H2 p); rewrite vec_pos_map in H2; auto.
    apply vec_reif in H3.
    destruct H3 as (m & Hm).
    exists (1+n+vec_sum m).
    apply in_ra_ca_comp with (2 := H1); auto.

    rewrite ra_rel_fix_rec; unfold s_rec.
    rewrite (vec_head_tail v); simpl; generalize (vec_head v) (vec_tail v).
    clear v; intros i v.
    revert x; induction i as [ | i IHi ]; intros x; simpl.
    intros H; apply Hf in H; destruct H as (n & Hn); exists (S n); constructor; auto.
    intros (y & H1 & H2).
    apply IHi in H1; destruct H1 as (n & Hn).
    apply Hg in H2; destruct H2 as (m & Hm).
    exists (1+n+m); apply in_ra_ca_rec_S with (1 := Hn); auto.

    rewrite ra_rel_fix_min; unfold s_min; intros (H1 & H2).
    assert (forall (p : pos x), exists r, [|f|] (pos2nat p##v) (S r)) as H3.
      intros p; apply (H2 _ (pos2nat_prop p)).
    apply vec_reif in H3.
    destruct H3 as (w & Hw).
    assert (forall p, exists n, [f;pos2nat p##v] -[n>> S (vec_pos w p)) as H3.
      intros p; apply IHf, Hw.
    apply vec_reif in H3.
    destruct H3 as (m & Hm).
    apply IHf in H1.
    destruct H1 as (n & Hn).
    exists (1+n+vec_sum m).
    apply in_ra_ca_min with (1 := Hm); auto.
  Qed.

  (* Hence, there is a correspondance between the relational semantics
      and the bigstep semantics of recalg.
   **)

  Hint Resolve ra_ca_inc_bs ra_bs_inc_rel ra_rel_inc_ca : core.

  Theorem ra_bs_correct k (f : recalg k) v x : [|f|] v x <-> [f;v] ▹ x.
  Proof. split; auto. Qed.

  Theorem ra_ca_correct k (f : recalg k) v x : [|f|] v x <-> exists n, [f;v] -[n>> x.
  Proof. split; auto. Qed.

End soundness_and_completeness.


(* Copyright (c) 2014, Robert Dockins *)

Require Import Relations.
Require Import List.

Require Import basics.
Require Import preord.
Require Import categories.

Delimit Scope set_scope with set.
Open Scope set_scope.

(**  * Set theory.

       Here we define a notion of "set theory" that is sufficent
       for our purposes.  Note that the set theories we define
       are significantly weaker than the set theories used for
       foundational mathematics (say, ZF).

       First, our sets are typed: a "set theory" defines an operator
       [set] that sents preorders to preorders.  In addition to the
       membership predicate, the only operations we stipulate must
       exist are the operation to form singleton sets, the union
       operation, and the operation to take the image of a monotone
       function.

       Two particular notions of "set theory" we are interested in
       are the finite sets and the enumerable (countable) sets.
       We'll also be interested in the notion of directed sets,
       which play an important role in the deveopment of domain theory.
       Directeness is abstracted into a notion of "colored" sets, which
       unifies several closely related definitions.

       Note that the operations we require are precicely what is
       required for "set" to be a monad in the category of preorders.
       This, as it happens, is an unanticipated coincidence!  Perhaps
       there is some deeper meaning implied by this coincidence, but I
       have yet to discover it.
  *)
Module set.
Section mixin_def.
  Variable set : preord -> Type.
  Variable member : forall (A:preord), A -> set A -> Prop.
  Variable single : forall (A:preord), A -> set A.
  Variable image : forall (A B:preord) (f:A → B), set A -> set B.

  (** The standard inclusion preorder on sets. *)
  Let incl A X Y := forall a, member A a X -> member A a Y.

  Program Definition set_preord (A:preord) : preord :=
    Preord.Pack (set A) (Preord.Mixin _ (@incl A) _ _).
  Next Obligation.
    hnf; auto.
  Qed.
  Next Obligation.
    hnf; intros. apply H0. apply H. auto.
  Qed.

  Variable union : forall A:preord, set (set_preord A) -> set A.

  Record mixin_of :=
    Mixin
      {  member_eq : forall (A:preord) (a b:A) (X:set A),
          a ≈ b -> member A a X -> member A b X

      ; single_axiom : forall (A:preord) (a b:A),
          member A a (single A b) <-> a ≈ b

      ; union_axiom : forall (A:preord) (XS:set (set_preord A)) (a:A),
          member A a (union A XS) <->
          exists X:set A, member (set_preord A) X XS /\ member A a X

      ; image_axiom0 : forall (A B C:preord) (f:A → B) (g:B → C) (X:set A) (c:C),
          member C c (image A C (g ∘ f) X) <->
          member C c (image B C g (image A B f X))
      ; image_axiom1 : forall (A B:preord) (f:A → B) (P:set A) (x:A),
          member A x P -> member B (f#x) (image A B f P)
      ; image_axiom2 : forall (A B:preord) (f:A → B) (P:set A) (x:B),
          member B x (image A B f P) ->
            exists y, member A y P /\ x ≈ f#y
      }.
End mixin_def.

Record theory :=
  Theory
  { set : preord -> Type
  ; member : forall (A:preord), A -> set A -> Prop
  ; single : forall (A:preord), A -> set A
  ; image : forall (A B:preord) (f:A → B), set A -> set B
  ; union : forall A:preord, set (set_preord set member A) -> set A
  ; mixin :> mixin_of set member single image union
  }.
End set.

Definition set_preord (T:set.theory) (A:preord) :=
  set.set_preord (set.set T) (@set.member T) A.
Canonical Structure set_preord.

Notation set := set_preord.

(**   Here, we equip set theories with their standard notations,
      ∈ for memebership, ⊆ for subset inclusion, and ∪ for unions.
  *)

Definition image (T:set.theory) (A B:preord) (f:A → B) (X:set T A) : set T B :=
  @set.image T A B f X.
Definition single (T:set.theory) (A:preord) (a:A) : set T A :=
  @set.single T A a.
Definition union (T:set.theory) (A:preord) (XS:set T (set T A)) : set T A :=
  set.union T A XS.

Notation "x ∈ X" := (@set.member _ _ x (X)%set) : set_scope.
Notation "x ∉ X"  := (not (@set.member _ _ x (X)%set)) : set_scope.
Notation "∪ XS" := (@union _ _ (XS)%set) : set_scope.

Arguments set.member [t] [A] a X : simpl never.
Arguments image [T] [A] [B] f X : simpl never.
Arguments single [T] [A] a : simpl never.
Arguments union [T] [A] XS : simpl never.

Definition incl (A:preord) (XT YT:set.theory) (X:set XT A) (Y:set YT A) :=
  forall a:A, a ∈ X -> a ∈ Y.

Notation "X ⊆ Y" := (@incl _ _ _ (X)%set (Y)%set) : set_scope.
Arguments incl [A XT YT] X Y.

(**  Here we provide convenient access points to the set theory axioms.
  *)
Lemma member_eq : forall (T:set.theory) (A:preord) (a b:A) (X:set T A),
  a ≈ b -> a ∈ X -> b ∈ X.
Proof.
  intro T. apply (set.member_eq _ _ _ _ _ (set.mixin T)).
Qed.

Lemma single_axiom : forall (T:set.theory) (A:preord) (a b:A),
  a ∈ @set.single T A b <-> a ≈ b.
Proof.
  intro T. apply (set.single_axiom _ _ _ _ _ (set.mixin T)).
Qed.

Lemma union_axiom : forall (T:set.theory) (A:preord) (XS:set T (set T A)) (a:A),
  a ∈ ∪XS <-> exists X, X ∈ XS /\ a ∈ X.
Proof.
  intro T. apply (set.union_axiom _ _ _ _ _ (set.mixin T)).
Qed.

Lemma image_axiom0 : forall (T:set.theory)
  (A B C:preord) (f:A → B) (g:B → C) (X:set T A) (c:C),
          c ∈ image (g ∘ f) X <-> c ∈ image g (image f X).
Proof.
  intro T. apply (set.image_axiom0 _ _ _ _ _ (set.mixin T)).
Qed.

Lemma image_axiom1 : forall (T:set.theory)
  (A B:preord) (f:A → B) (P:set T A) (x:A),
  x ∈ P -> f x ∈ image f P.
Proof.
  intro T. apply (set.image_axiom1 _ _ _ _ _ (set.mixin T)).
Qed.

Lemma image_axiom1' (T:set.theory) (A B:preord) (f:A → B)
  (P:set T A) (x:B) : (exists a, x ≈ f a /\ a ∈ P) -> x ∈ image f P.
Proof.
  intros [a [??]].
  apply member_eq with (f a); auto.
  apply image_axiom1. auto.
Qed.

Lemma image_axiom2 : forall (T:set.theory)
  (A B:preord) (f:A → B) (P:set T A) (x:B),
  x ∈ image f P -> exists y, y ∈ P /\ x ≈ f y.
Proof.
  intro T. apply (set.image_axiom2 _ _ _ _ _ (set.mixin T)).
Qed.

(**  Next, we do all the muckety-muck necessary to
     do setoid rewriting with set theories.
  *)
Require Import Setoid.
Require Import Coq.Program.Basics.

Add Parametric Morphism (T:set.theory) (A:preord) :
  (@set.member T A)
   with signature (eq_op (Preord_Eq A)) ==>
                  (eq_op (Preord_Eq (set T A))) ==>
                  iff
    as member_morphism.
Proof.
  intros. split; intros.
  destruct H0. apply H0. eapply member_eq; eauto.
  destruct H0. apply H2. eapply member_eq. symmetry. apply H.
  auto.
Qed.

Add Parametric Morphism (T:set.theory) (A:preord) :
  (@set.member T A)
   with signature (eq_op (Preord_Eq A)) ==>
                  (@Preord.ord_op (set T A)) ==>
                  impl
    as member_incl_morphism.
Proof.
  intros. red; intros.
  apply H0. eapply member_eq; eauto.
Qed.

Add Parametric Morphism (T1 T2:set.theory) (A:preord) :
  (@incl A T1 T2)
   with signature (eq_op (Preord_Eq (set T1 A))) ==>
                  (eq_op (Preord_Eq (set T2 A))) ==>
                  iff
    as incl_morphism.
Proof.
  repeat intro. split; repeat intro.
  destruct H0. apply H0.
  apply H1.
  destruct H. apply H4. auto.
  destruct H0. apply H3.
  apply H1.
  destruct H. apply H. auto.
Qed.

Add Parametric Morphism (T1 T2:set.theory) (A:preord) :
  (@incl A T1 T2)
   with signature (Preord.ord_op (set T1 A)) -->
                  (Preord.ord_op (set T2 A)) ++>
                  impl
    as incl_ord_morphism.
Proof.
  repeat intro.
  apply H0. apply H1. apply H. auto.
Qed.

Lemma incl_refl (T:set.theory) (A:preord) (X:set T A) : X ⊆ X.
Proof.
  red; auto.
Qed.

Lemma incl_trans (T1 T2 T3:set.theory) (A:preord)
  (X:set T1 A) (Y:set T2 A) (Z:set T3 A) :
  X ⊆ Y -> Y ⊆ Z -> X ⊆ Z.
Proof.
  unfold incl. intuition.
Qed.

Add Parametric Relation (T:set.theory) (A:preord) : (set T A) (@incl A T T)
  reflexivity proved by (incl_refl T A)
  transitivity proved by (incl_trans T T T A)
  as incl_rel.

Add Parametric Morphism (T:set.theory) (A:preord) :
  (@incl A T T)
   with signature (@incl A T T) -->
                  (@incl A T T) ++>
                  impl
    as incl_incl_morphism.
Proof.
  repeat intro.
  apply H0. apply H1. apply H. auto.
Qed.

Add Parametric Morphism (T:set.theory) (A:preord) (B:preord) :
  (@image T A B)
    with signature (eq_op (Preord_Eq (A ⇒ B))) ==>
                   (eq_op (Preord_Eq (set T A))) ==>
                   (eq_op (Preord_Eq (set T B)))
     as image_morphism.
Proof.
  intros. split. red. simpl; intros.
  apply image_axiom2 in H1.
  destruct H1 as [z [??]].
  rewrite H2.
  apply member_eq with ((y:hom _ A B) #z).
  destruct H. split.
  apply H3. apply H.
  apply image_axiom1.
  destruct H0. apply H0. auto.

  red. simpl; intros.
  apply image_axiom2 in H1.
  destruct H1 as [z [??]].
  rewrite H2.
  apply member_eq with ((x:hom _ A B) #z).
  destruct H. split.
  apply H. apply H3.
  apply image_axiom1.
  destruct H0. apply H3. auto.
Qed.

Add Parametric Morphism (T:set.theory) (A:preord) (B:preord) :
  (@image T A B)
    with signature (eq_op (Preord_Eq (A ⇒ B))) ==>
                   (Preord.ord_op (set T A)) ==>
                   (Preord.ord_op (set T B))
     as image_ord_morphism.
Proof.
  repeat intro.
  apply image_axiom2 in H1.
  destruct H1 as [z [??]].
  rewrite H2.
  apply member_eq with ((y:hom _ A B) #z).
  destruct H; split.
  apply H3. apply H.
  apply image_axiom1.
  apply H0. auto.
Qed.

Add Parametric Morphism (T:set.theory) (A:preord) :
  (@union T A)
    with signature (eq_op (Preord_Eq (set T (set T A)))) ==>
                   (eq_op (Preord_Eq (set T A)))
     as union_morphism.
Proof.
  intros. split; repeat intro.
  apply union_axiom in H0.
  apply union_axiom.
  destruct H0 as [X [??]].
  exists X. split; auto.
  rewrite <- H; auto.
  apply union_axiom in H0.
  apply union_axiom.
  destruct H0 as [X [??]].
  exists X. split; auto.
  rewrite H; auto.
Qed.

Add Parametric Morphism (T:set.theory) (A:preord) :
  (@union T A)
    with signature (Preord.ord_op (set T (set T A))) ++>
                   (Preord.ord_op (set T A))
     as union_ord_morphism.
Proof.
  repeat intro.
  apply union_axiom in H0.
  apply union_axiom.
  destruct H0 as [X [??]].
  exists X. split; auto.
Qed.

Section image_compose.
  Variable T:set.theory.
  Variables A B C:preord.
  Variable f:B → C.
  Variable g:A → B.
  Variable XS:set T A.

  Lemma image_compose :
    image (f ∘ g) XS ≈ image f (image g XS).
  Proof.
    split; hnf; intros.
    apply image_axiom2 in H. destruct H as [y [??]].
    simpl in H0.
    rewrite H0.
    apply image_axiom1. apply image_axiom1. auto.
    apply image_axiom2 in H. destruct H as [y [??]].
    apply image_axiom2 in H. destruct H as [z [??]].
    rewrite H0. rewrite H1.
    apply image_axiom1'. exists z. split; auto.
  Qed.
End image_compose.

(**  A set theory has a [set_dec] if set membership is decidable.
  *)
Record set_dec (T:set.theory) (A:preord) :=
  Setdec
  { setdec :> forall (x:A) (X:set T A), { x ∈ X } + { x ∉ X } }.

(**  Here we define some general order-theoretic notions.
  *)
Definition lower_set {T:set.theory} {A:preord} (X:set T A) :=
  forall (a b:A), a ≤ b -> b ∈ X -> a ∈ X.

Definition upper_set {T:set.theory} {A:preord} (X:set T A) :=
  forall (a b:A), a ≤ b -> a ∈ X -> b ∈ X.

Definition upper_bound {T:set.theory} {A:preord}
  (ub:A) (X:set T A) :=
  forall x, x ∈ X -> x ≤ ub.

Definition lower_bound {T:set.theory} {A:preord}
  (lb:A) (X:set T A) :=
  forall x, x ∈ X -> lb ≤ x.

Definition minimal_upper_bound {T:set.theory} {A:preord}
  (mub:A) (X:set T A) :=
  upper_bound mub X /\
  (forall b, upper_bound b X -> b ≤ mub -> mub ≤ b).

Definition maximal_lower_bound {T:set.theory} {A:preord}
  (mlb:A) (X:set T A) :=
  lower_bound mlb X /\
  (forall b, lower_bound b X -> mlb ≤ b -> b ≤ mlb).

Definition least_upper_bound {T:set.theory} {A:preord}
  (lub:A) (X:set T A) :=
  upper_bound lub X /\
  (forall b, upper_bound b X -> lub ≤ b).

Definition greatest_lower_bound {T:set.theory} {A:preord}
  (glb:A) (X:set T A) :=
  lower_bound glb X /\
  (forall b, lower_bound b X -> b ≤ glb).

(**  Now prove that these definitions all respect set equality.
  *)
Add Parametric Morphism (T:set.theory) (A:preord) :
  (@lower_set T A)
  with signature (eq_op _) ==> impl
    as lower_set_morphism.
Proof.
  repeat intro.
  rewrite <- H. apply (H0 a b); auto. rewrite H; auto.
Qed.

Add Parametric Morphism (T:set.theory) (A:preord) :
  (@upper_set T A)
  with signature (eq_op _) ==> impl
    as upper_set_morphism.
Proof.
  repeat intro.
  rewrite <- H. apply (H0 a b); auto. rewrite H; auto.
Qed.

Add Parametric Morphism (T:set.theory) (A:preord) :
  (@upper_bound T A)
  with signature (eq_op _) ==> (eq_op _) ==> impl
    as upper_bound_morphism.
Proof.
  repeat intro. rewrite <- H. apply H1. rewrite H0. auto.
Qed.

Add Parametric Morphism (T:set.theory) (A:preord) :
  (@lower_bound T A)
  with signature (eq_op _) ==> (eq_op _) ==> impl
    as lower_bound_morphism.
Proof.
  repeat intro. rewrite <- H. apply H1. rewrite H0. auto.
Qed.

Add Parametric Morphism (T:set.theory) (A:preord) :
  (@least_upper_bound T A)
  with signature (eq_op _) ==> (eq_op _) ==> impl
    as least_upper_bound_morphism.
Proof.
  repeat intro.
  destruct H1; split; intros.
  eapply upper_bound_morphism; eauto.
  rewrite <- H. apply H2.
  eapply upper_bound_morphism. 3: eauto. auto. auto.
Qed.

Add Parametric Morphism (T:set.theory) (A:preord) :
  (@minimal_upper_bound T A)
  with signature (eq_op _) ==> (eq_op _) ==> impl
    as minimal_upper_bound_morphism.
Proof.
  repeat intro.
  destruct H1; split; intros.
  eapply upper_bound_morphism; eauto.
  rewrite <- H. apply H2.
  eapply upper_bound_morphism. 3: eauto. auto. auto.
  rewrite H; auto.
Qed.

Add Parametric Morphism (T:set.theory) (A:preord) :
  (@greatest_lower_bound T A)
  with signature (eq_op _) ==> (eq_op _) ==> impl
    as greatest_lower_bound_morphism.
Proof.
  repeat intro.
  destruct H1; split; intros.
  eapply lower_bound_morphism; eauto.
  rewrite <- H. apply H2.
  eapply lower_bound_morphism. 3: eauto. auto. auto.
Qed.

Add Parametric Morphism (T:set.theory) (A:preord) :
  (@maximal_lower_bound T A)
  with signature (eq_op _) ==> (eq_op _) ==> impl
    as maximal_lower_bound_morphism.
Proof.
  repeat intro.
  destruct H1; split; intros.
  eapply lower_bound_morphism; eauto.
  rewrite <- H. apply H2.
  eapply lower_bound_morphism. 3: eauto. auto. auto.
  rewrite H; auto.
Qed.

(**  Colored sets are a generalization of the idea of "directed" sets.

     A "color" is a property a set may have which is parametric over
     a set theory.  We require that the property of being "colored" is
     preserved by the operations of a set theory: every singleton set
     is colored; a colored union of colored sets is colored; and the
     image (under a monotone function) of a colored set is again colored.
  *)
Record color :=
  Color
  { color_prop : forall (T:set.theory) (A:preord) (X:set T A), Prop
  ; color_eq : forall (T:set.theory) (A:preord) (X Y:set T A),
        X ≈ Y -> color_prop T A X -> color_prop T A Y
  ; color_single : forall (T:set.theory) (A:preord) (a:A),
        color_prop T A (single a)
  ; color_image : forall (T:set.theory) (A B:preord) (f:A → B) (X:set T A),
        color_prop T A X -> color_prop T B (image f X)
  ; color_union : forall (T:set.theory) (A:preord) (XS:set T (set T A)),
        color_prop T (set T A) XS ->
        (forall X:set T A, X ∈ XS -> color_prop T A X) ->
        color_prop T A (∪XS)
  }.
Arguments color_prop c [T] [A] X.

(* Doesn't follow union law??
Program Definition color_or (C1 C2:color) : color :=
  Color (fun SL A X => color_prop C1 X \/ color_prop C2 X) _ _.
Next Obligation.
  destruct H; [ left | right ]; apply color_image; auto.
Qed.
Next Obligation.
*)

(**  The conjunction of two coloring properties is again a color.
  *)
Program Definition color_and (C1 C2:color) : color :=
  Color (fun SL A X => color_prop C1 X /\ color_prop C2 X) _ _ _ _.
Next Obligation.
  split; eapply color_eq; eauto.
Qed.
Next Obligation.
  split; apply color_single; auto.
Qed.
Next Obligation.
  split; apply color_image; auto.
Qed.
Next Obligation.
  split.
  apply color_union; auto.
  intros. apply H0; auto.
  apply color_union.
  auto.
  intros. apply H0; auto.
Qed.

(* fails to satisfy the singleton axiom...
Program Definition is_empty : color :=
  Color (fun SL A X => forall x, x ∈ X -> False) _ _ _.
Next Obligation.
  apply (H0 x).
  apply H. auto.
Qed.
Next Obligation.
  apply image_axiom2 in H0. destruct H0 as [y [??]].
  apply (H y); auto.
Qed.
Next Obligation.
  apply union_axiom in H1.
  destruct H1 as [X [??]].
  apply (H X); auto.
Qed.
*)

(**  The property of being inhabited is a simple example of a color.
  *)
Program Definition inhabited : color :=
  Color (fun SL A X => exists a:A, a ∈ X) _ _ _ _.
Next Obligation.
  exists H0. apply H; auto.
Qed.
Next Obligation.
  exists a. apply single_axiom. auto.
Qed.
Next Obligation.
  exists (Preord.map A B f H).
  apply image_axiom1; auto.
Qed.
Next Obligation.
  destruct (H0 H) as [x ?]; auto.
  exists x. apply union_axiom; auto.
  eauto.
Qed.

Obligation Tactic := idtac.

(**  Given a base set theory [T], we can collect together all the sets
     of [T] that satisfy some coloring property: these colored sets
     again form a set theory.
  *)
Module colored_sets.
Section colored_sets.
  Variable T:set.theory.
  Variable C:color.

  Definition cset A := { X:set T A | color_prop C X }.
  Definition csingle A a : cset A := exist _ (single a) (color_single C T A a).
  Definition cmember A a (X:cset A) := a ∈ proj1_sig X.
  Definition cimage (A B:preord) (f:A → B) (X:cset A) :=
    exist _ (image f (proj1_sig X))
            (color_image C T A B f (proj1_sig X) (proj2_sig X)).

  Program Definition forget_color (A:preord) : (set.set_preord cset cmember A → set_preord T A) :=
    Preord.Hom (set.set_preord cset cmember A) (set_preord T A) (fun X => proj1_sig X) _.
  Next Obligation.
    auto.
  Qed.

  Section cunion.
    Variable A:preord.
    Variable XS:cset (set.set_preord cset cmember A).

    Program Definition cunion : cset A :=
      exist _ (union (image (forget_color _) XS)) _.
    Next Obligation.
      apply color_union; auto.
      apply color_image. apply proj2_sig.
      intros.
      apply image_axiom2 in H.
      destruct H as [Y [??]].
      eapply color_eq.
      symmetry; apply H0.
      simpl. apply proj2_sig.
    Qed.
  End cunion.

  Program Definition mixin :
    set.mixin_of cset cmember csingle cimage cunion :=
    set.Mixin _ _ _ _ _ _ _ _ _ _ _.
  Next Obligation.
    intros. apply member_eq with a; auto.
  Qed.
  Next Obligation.
    unfold cmember, csingle. simpl; intros.
    apply single_axiom.
  Qed.
  Next Obligation.
    intros.
    unfold cmember.
    unfold cunion at 1. simpl.
    rewrite union_axiom.
    intuition.
    destruct H as [X [??]].
    apply image_axiom2 in H.
    destruct H as [Y [??]].
    exists Y. split; auto.
    simpl in H1.
    destruct H1. apply H1. auto.
    destruct H as [X [??]].
    exists (proj1_sig X).
    split; auto.
    apply (image_axiom1 T _ _ (forget_color _)); auto.
  Qed.
  Next Obligation.
    unfold cmember, cimage. simpl.
    intros. apply (image_axiom0 T).
  Qed.
  Next Obligation.
    unfold cmember, cimage. simpl.
    intros. apply (image_axiom1 T). auto.
  Qed.
  Next Obligation.
    unfold cmember, cimage. simpl.
    intros. apply (image_axiom2 T). auto.
  Qed.
End colored_sets.
End colored_sets.

Canonical Structure cset_theory (T:set.theory) (CL:color) :=
  set.Theory
     (colored_sets.cset T CL)
     (colored_sets.cmember T CL)
     (colored_sets.csingle T CL)
     (colored_sets.cimage T CL)
     (colored_sets.cunion T CL)
     (colored_sets.mixin T CL).


(* TernaryProperties.v *)

Require Import Ternary.

Lemma andt_assoc a b c : (a && (b && c) = (a && b) && c)%tern.
Proof.
  destruct a; destruct b; destruct c; reflexivity.
Qed.

Lemma andt_comm a b : (a && b = b && a)%tern.
Proof.
  destruct a; destruct b; reflexivity.
Qed.

Lemma ort_assoc a b c : (a || (b || c) = (a || b) || c)%tern.
Proof.
  destruct a; destruct b; destruct c; reflexivity.
Qed.

Lemma ort_comm a b : (a || b = b || a)%tern.
Proof.
  destruct a; destruct b; reflexivity.
Qed.

(* end *)


Require Import BenB.

(* Domeinen *)
Variable M: Set.
  (* Verzameling van alle levende en overleden mensen. *)
Definition T := R.
  (* Verzameling tijdstippen in reele getallen als minuten. *)

(* Predikaten *)
Variable isMan (* x *) : M -> Prop.
  (* x is een man *)
  (* Opzoeken in gemeentelijke basisadministratie. *)

Variable ouderVan (* x y *) : M -> M -> Prop.
  (* x is een ouder van y. *)
  (* Opzoeken in gemeentelijke basisadministratie. *)

Variable wordtGeboren (* x t *) : M -> T -> Prop.
  (* x wordt geboren op tijdstip t. *)
  (* Controleren via geboorteregister. *)

Variable overlijdt (* x t *) : M -> T -> Prop.
  (* x overlijdt op tijdstip t. *)
  (* Controleren via overlijdensakte. *)

Variable trouwtMet (* x y t *): M -> M -> T -> Prop.
  (* x trouwt met y op tijdstip t *)
  (* Controleren via huwelijksregister. *)

(*
   Hierboven mag u niets aanpassen. U zult met dit domeinmodel moeten
   proberen om onderstaande hulppredikaten zo goed mogelijk te
   formaliseren.
*)

(* Hulphulppredikaten *)
(* Deze definities staan hier alleen maar voor de mensen die graag de
   systematische vertaalmethode gebruiken en daarvoor
   extra Definition's nodig hebben.

   Gebruikt u ze niet, zet er dan dummy's neer, bijvoorbeeld
   Definition HH1 := True.
*)

Definition zelfdeGeboorteDatum (x:M) (y:M) :=
    forall t:T,
            wordtGeboren x t
        /\
            wordtGeboren y t
.
(* x en y hebben dezelfde geboortedatum *)

Definition zelfdeVader (x:M) (y:M) :=
    exists m:M,
            isMan m
        /\
            ouderVan m x
        /\
            ouderVan m y
.
(* x en y hebben dezelfde vader *)

Definition zelfdeMoeder (x:M) (y:M) :=
    exists m:M,
            ~isMan m
        /\
            ouderVan m x
        /\
            ouderVan m y
.
(* x en y hebben dezelfde moeder *)

Definition ouderDan (x:M) (y:M) :=
    forall t:T,
        forall d:T,
            wordtGeboren x t
            /\
            wordtGeboren y d
            ->
            (t<d)
.
(* x is ouder dan y *)

Definition ouderDanAndereKinderen (x:M) (y:M) :=
    forall m:M,
        ouderVan m y
        /\
        (x<>m)
        ->
        ouderDan x m
.
(* x is ouder dan alle kinderen van y *)

Definition HH4 := True
.

Definition HH5 := True
.

Definition HH6 := True
.

Definition HH7 := True
.

Definition HH8 := True
.

(* Hulppredikaten *)
(*
   Maak voor de onderstaande hulppredikaten nette definities
   binnen dit domeinmodel.

   Uw studentnummer bepaalt welke definities u precies moet
   uitwerken. De overige definities dient u op de gebruikelijke
   manier voor Coq accepteerbaar te maken.

   De gewenste betekenis staat in commentaar vermeld.

   U mag de types van de hulppredikaten niet aanpassen.

   U mag wel gebruikmaken van reeds eerder gedefinieerde
   (hulp)hulpredikaten.

   Zorg dat de layout van de formules overeenkomt met de
   wiskundige structuur.
*)

Definition leeft (x:M) (t:T) :=
  (* Mens x leeft op tijdstip t. *)
  True
.

Definition isWeduwe (x:M) (t:T) :=
  (* Mens x is weduwe op tijdstip t. *)
  True
.

Definition tweeling (x:M) (y:M) :=
    (* Mens x en mens y zijn samen een tweeling. *)
    zelfdeGeboorteDatum x y
  /\
    zelfdeVader x y
  /\
    zelfdeMoeder x y
.

Definition oudsteKindVan (x:M) (y:M) :=
  (* x is het oudste kind van y. *)
    ouderVan y x
  /\
    ouderDanAndereKinderen x y
.


(** Author : Hichem Saghrouni
Internship at IRIT, 2018
Under the supervision of Ralph Matthes

Later continued by Ralph Matthes (R.M.), see the end of this comment.

Work on the paper
HINZE, R. and WU, N., 2016. Unifying structured recursion schemes: An Extended Study. Journal of Functional Programming, vol. 26, https://doi.org/10.1017/S0956796815000258.

The purpose of this file is to formalize in UniMath the recursion scheme
presented by Hinze and Wu, with their original approach making use of
liftings and conjugates.

For this, we formalize the notions of
- Distributive Laws, which are natural transformations between
compositions of functors
- Conjugates, which induce a binary relation between distributive laws,
defined by certain identities found in this document
- Liftings, which constitute a specific type of functors between F-Algebras

These constructions finally allow us to follow the proof by Hinze and Wu
of their theorem (found under "Theorem 5.2 (Adjoint folds)" in their
paper) and thus reprove it formally.

Added by R.M.: how canonically defined liftings compose

*)

Require Import UniMath.Foundations.Sets.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.
Require Import UniMath.CategoryTheory.whiskering.
Require Import UniMath.CategoryTheory.FunctorAlgebras.
Require Import UniMath.CategoryTheory.UnitorsAndAssociatorsForEndofunctors.
Require Import UniMath.CategoryTheory.limits.initial.
Require Import UniMath.CategoryTheory.Adjunctions.Core.

Local Open Scope cat.

Section DefDistrLaw.

Context {C C' D D' : precategory} (F : functor C D) (F' : functor C' D')
          (H : functor C' C) (K : functor D' D).

(** the definition of Hinze and Wu - no other laws required for being considered a distributive law *)
Definition DistrLaw (*{C C' D D' : precategory} (F : functor C D) (F' : functor C' D')
  (H : functor C' C) (K : functor D' D)*) : UU :=
  nat_trans (H ∙ F) (F' ∙ K).

(** a small help for later type-checking *)
Definition DistrLaw_data (*{C C' D D' : precategory} (F : functor C D) (F' : functor C' D')
  (H : functor C' C) (K : functor D' D)*) : UU :=
  nat_trans_data (H ∙ F) (F' ∙ K).

End DefDistrLaw.

Section OperationsDistrLaws.

Definition comp_distr_laws {C C' C'' D D' D'' : category}{F : functor C D}{F' : functor C' D'}
  {F'' : functor C'' D''}{H : functor C' C}{H' : functor C'' C'}{K : functor D' D}{K' : functor D'' D'}
  (lambda : DistrLaw F F' H K) (lambda' : DistrLaw F' F'' H' K') :
  DistrLaw F F'' (H' ∙ H ) (K' ∙ K).
Proof.
  red.
  apply (nat_trans_comp _ _ _ (α_functors _ _ _)).
  use (nat_trans_comp _ _ _ _ (α_functors _ _ _)).
  apply (nat_trans_comp _ _ _ (pre_whisker H' lambda)).
  apply (nat_trans_comp _ _ _ (α_functors_inv _ _ _)).
  exact (post_whisker lambda' K).
Defined.

Definition id_distr_law  {C D : category} (F : functor C D) :
  DistrLaw F F (functor_identity C) (functor_identity D).
Proof.
  red.
  apply (nat_trans_comp _ _ _ (λ_functors _)).
  apply ρ_functors_inv.
Defined.

Lemma comp_distr_laws_assoc {C C' C'' C''' D D' D'' D''' : category} {F : functor C D}
      {F' : functor C' D'}  {F'' : functor C'' D''} {F''' : functor C''' D'''}
      {H : functor C' C} {H' : functor C'' C'} {H'' : functor C''' C''}
      {K : functor D' D} {K' : functor D'' D'} {K'' : functor D''' D''}
      (lambda : DistrLaw F F' H K)
      (lambda' : DistrLaw F' F'' H' K') (lambda'' : DistrLaw F'' F''' H'' K'') :
  comp_distr_laws (comp_distr_laws lambda lambda') lambda'' =
                comp_distr_laws lambda (comp_distr_laws lambda' lambda'').
Proof.
  apply nat_trans_eq_alt.
  intro c.
  simpl.
  repeat rewrite id_left.
  repeat rewrite id_right.
  set (aux1 := nat_trans_ax lambda).
  (*rewrite <- assoc.*)
  (*Beginning of variant to : rewrite assoc*)
  eapply pathscomp0. (*etrans.*)
  { apply pathsinv0.
    apply assoc.
    (*End of variant to rewrite*)
  }
  apply cancel_precomposition.
  apply pathsinv0.
  etrans.
  { apply functor_comp. }
  apply cancel_precomposition.
  apply idpath.
Qed.

  (*lois unitaires : composition avec l'identité, idF neutre à gauche et à droite*)

Definition id_distr_law_left {C D : category} (F : functor C D) :
  ∏ (C' D' : category) (F' : functor C' D') (H : functor C' C) (K : functor D' D)
    (lambda : DistrLaw F F' H K),
  comp_distr_laws (id_distr_law F) lambda  = lambda.
Proof.
  intros C' D'.
  intros F' H K.
  intro lambda.
  apply nat_trans_eq_alt.
  intro c.
  simpl.
  repeat rewrite id_left.
  apply id_right.
Qed.

(* Locate "·". *)

Definition id_distr_law_right {C' D' : category} (F' : functor C' D') :
  ∏ (C D : category) (F : functor C D) (H : functor C' C) (K : functor D' D)
    (lambda : DistrLaw F F' H K),
  comp_distr_laws lambda (id_distr_law F')  = lambda.
Proof.
  intros C D.
  intros F H K.
  intro lambda.
  apply nat_trans_eq_alt.
  intro c.
  simpl.
  repeat rewrite id_left.
  rewrite id_right.
  etrans.
  { apply cancel_precomposition.
    apply functor_id.
  }
  apply id_right.
Qed.

End OperationsDistrLaws.

Section Conjugates.

Lemma adjuncts_mutually_inverse1 {C D : category} {A : D} {B : C}
      {L : functor D C} {R : functor C D} (h : are_adjoints L R)
      (f : L A --> B) (g : A --> R B) :
  f = φ_adj_inv h g -> φ_adj h f = g.
Proof.
  intro p.
  set (η := unit_from_are_adjoints h).
  set (ε := counit_from_are_adjoints h).
  set (triangle_right := triangle_id_right_ad h).
  change (unit_from_are_adjoints h) with η in triangle_right.
  change (counit_from_are_adjoints h) with ε in triangle_right.
  unfold φ_adj.
  assert (hyp : f = (φ_adj_inv h g)).
  - exact p.
  - rewrite hyp.
    unfold φ_adj_inv.
    rewrite functor_comp.
    change (# R (# L g)) with (# (L ∙ R) g).
    rewrite assoc.
    set (Hη := nat_trans_ax η).
    etrans.
    { apply cancel_postcomposition.
      apply pathsinv0.
      apply Hη.
    }
    rewrite <- id_right.
    rewrite <-  assoc.
    apply cancel_precomposition.
    exact (triangle_right B).
Qed.

Lemma adjuncts_mutually_inverse2 {C D : category} {A : D} {B : C}
      {L : functor D C} {R : functor C D} (h : are_adjoints L R)
      (f : L A --> B) (g : A --> R B) :
  φ_adj h f = g -> f = φ_adj_inv h g.
Proof.
  intro p.
  set (η := unit_from_are_adjoints h).
  set (ε := counit_from_are_adjoints h).
  set (triangle_left := triangle_id_left_ad h).
  unfold φ_adj_inv.
  assert (hyp : g = (φ_adj h f)).
  - apply pathsinv0.
    exact p.
  - rewrite hyp.
    unfold φ_adj.
    rewrite functor_comp.
    change ( # L (# R f)) with (# (R ∙ L) f).
    rewrite <- assoc.
    set (Hε := nat_trans_ax ε).
    apply pathsinv0.
    etrans.
    { apply cancel_precomposition.
      apply Hε.
    }
    rewrite <- id_left.
    rewrite assoc.
    apply cancel_postcomposition.
    exact (triangle_left A).
Qed.

(*  Locate "-->".
  Print φ_adj.
  Print Adjunctions.φ_adj. *)

(* Condition 3.11a in Hinze & Wu *)
Definition are_conjugates {C C' D D' : category} {L : functor D C} {R : functor C D}
           {L' : functor D' C'} {R' : functor C' D'}{H : functor C C'} {K : functor D D' }
           (h : are_adjoints L R) (h' : are_adjoints L' R')
           (σ : DistrLaw L' L K H) (τ : DistrLaw K H R R') : UU :=
  ∏ (A : D) (B : C) (f : (L A) --> B),
  φ_adj h' (nat_trans_data_from_nat_trans σ A · #H f) = #K (φ_adj h f) · nat_trans_data_from_nat_trans τ B.

(* Condition 3.11b in Hinze & Wu *)
Definition are_conjugates' {C C' D D' : category} {L : functor D C} {R : functor C D}
           {L' : functor D' C'} {R' : functor C' D'}  {H : functor C C'} {K : functor D D' }
           (h : are_adjoints L R) (h' : are_adjoints L' R')
           (σ : DistrLaw L' L K H) (τ : DistrLaw K H R R') : UU :=
  ∏ (A : D) (B : C) (g : A --> R B),
  nat_trans_data_from_nat_trans σ A · #H (φ_adj_inv h g) = φ_adj_inv h' (#K g · nat_trans_data_from_nat_trans τ B ).

(* Locate "×". *)

Lemma isaprop_are_conjugates {C C' D D' : category} {L : functor D C} {R : functor C D}
      {L' : functor D' C'} {R' : functor C' D'} {H : functor C C'} {K : functor D D' }
      (h : are_adjoints L R) (h' : are_adjoints L' R')
      (σ : DistrLaw L' L K H) (τ : DistrLaw K H R R') :
  isaprop (are_conjugates h h' σ τ).
Proof.
  apply impred; intro d.
  apply impred; intro c.
  apply impred; intro f.
  apply homset_property.
Qed.

Lemma isaprop_are_conjugates'  {C C' D D' : category} {L : functor D C} {R : functor C D}
      {L' : functor D' C'} {R' : functor C' D'} {H : functor C C'} {K : functor D D' }
      (h : are_adjoints L R) (h' : are_adjoints L' R')
      (σ : DistrLaw L' L K H) (τ : DistrLaw K H R R') :
  isaprop (are_conjugates' h h' σ τ).
Proof.
  apply impred; intro d.
  apply impred; intro c.
  apply impred; intro g.
  apply homset_property.
Qed.

Lemma are_conjugates_is_are_conjugates' {C C' D D' : category}
      {L : functor D C} {R : functor C D} {L' : functor D' C'} {R' : functor C' D'}
      {H : functor C C'} {K : functor D D' } (h : are_adjoints L R) (h' : are_adjoints L' R')
      (σ : DistrLaw L' L K H) (τ : DistrLaw K H R R') :
  are_conjugates h h' σ τ = are_conjugates' h h' σ τ.
Proof.
  apply propositionalUnivalenceAxiom.
  - apply isaprop_are_conjugates.
  - apply isaprop_are_conjugates'.
  - (* direction from left to right *)
    red.
    intro P.
    red in P.
    intros A B g.
    set (hyp := (P A B (φ_adj_inv h g))).
    apply adjuncts_mutually_inverse2 in hyp.
    assert (hyp2 : # K (φ_adj h (φ_adj_inv h g)) = # K g).
    + apply maponpaths.
      apply φ_adj_after_φ_adj_inv.
    + apply pathsinv0 in hyp.
      eapply pathscomp0 in hyp.
      2 : {
        apply maponpaths.
        apply cancel_postcomposition.
        apply pathsinv0.
        apply hyp2.
      }
      apply pathsinv0 in hyp.
      exact hyp.
  - (* direction from right to left *)
    red.
    intro P.
    red in P.
    intros A B f.
    set (hyp := (P A B (φ_adj h f))).
    apply (adjuncts_mutually_inverse1 h' (pr1 σ A · # H (φ_adj_inv h (φ_adj h f))) (# K (φ_adj h f) · pr1 τ B)) in hyp.
    eapply pathscomp0 in hyp.
    2 : {
      apply maponpaths.
      apply cancel_precomposition.
      apply maponpaths.
      apply pathsinv0.
      apply φ_adj_inv_after_φ_adj.
    }
    exact hyp.
Qed.

Definition σ_data_from_τ {C C' D D' : category} {L : functor D C} {R : functor C D}
           {L' : functor D' C'} {R' : functor C' D'} {H : functor C C'} {K : functor D D' }
           (h : are_adjoints L R) (h' : are_adjoints L' R')
           (τ : DistrLaw K H R R') : DistrLaw_data L' L K H :=
  λ A : D, φ_adj_inv h' (#K (unit_from_are_adjoints h A) · nat_trans_data_from_nat_trans τ (L A)).

Lemma is_nat_trans_σ_data_from_τ {C C' D D' : category} {L : functor D C} {R : functor C D}
           {L' : functor D' C'} {R' : functor C' D'} {H : functor C C'} {K : functor D D' }
           (h : are_adjoints L R) (h' : are_adjoints L' R')
           (τ : DistrLaw K H R R') : is_nat_trans _ _ (σ_data_from_τ h h' τ).
Proof.
  red.
  intros d d' f.
  unfold σ_data_from_τ.
  etrans.
  { apply pathsinv0.
    simpl.
    apply φ_adj_inv_natural_precomp.
  }
  (*simpl.*)
  apply pathsinv0.
  etrans.
  { apply pathsinv0.
    simpl.
    apply φ_adj_inv_natural_postcomp.
  }
  apply maponpaths.
  apply pathsinv0.
  etrans.
  rewrite assoc.
  (* Variant:
    set (Kcompax1 := pr2 K).
    set (Kcompax2 := pr2  (pr2 K)).
    unfold is_functor in Kcompax1.
    unfold functor_compax in Kcompax2.

    apply Kcompax2.
   *)
  rewrite <- functor_comp.
  2: {
    set (Hτ := nat_trans_ax τ).
    change  (# R' (# H (# L f))) with ( # (H ∙ R') (#L f)).
    (*equals by defintion*)
    (*Variant : replace (# R' (# H (# L f))) with ( # (H ∙ R') (#L f)). + proof that we can replace, ie find a path between the two*)
    rewrite <- assoc.
    apply cancel_precomposition.
    (*exact (Hτ _ _ _).*)
    apply Hτ.
  }

  rewrite assoc.
  apply cancel_postcomposition.
  change (# (R ∙ K) (# L f)) with (# K (# (L ∙ R) f)).
  etrans.
  2 : {
    use functor_comp.
  }
  apply maponpaths.
  (*apply pathsinv0.*)
  set (Hη := nat_trans_ax (unit_from_are_adjoints h)).
  apply Hη.
Defined.

Definition σ_from_τ {C C' D D' : category} {L : functor D C} {R : functor C D}
  {L' : functor D' C'} {R' : functor C' D'} {H : functor C C'} {K : functor D D' }
  (h : are_adjoints L R) (h' : are_adjoints L' R') (τ : DistrLaw K H R R') : DistrLaw L' L K H.
Proof.
  apply (make_nat_trans _ _ (σ_data_from_τ h h' τ)).
  apply is_nat_trans_σ_data_from_τ.
Defined.

Lemma σ_from_τ_is_conjugate {C C' D D' : category} {L : functor D C}
      {R : functor C D} {L' : functor D' C'} {R' : functor C' D'} {H : functor C C'} {K : functor D D' }
      (h : are_adjoints L R) (h' : are_adjoints L' R')
      (hs : has_homsets C') (τ : DistrLaw K H R R') :
  are_conjugates' h h' (σ_from_τ h h' τ) τ.
Proof.
  red.
  intros A B g.
  unfold σ_from_τ.
  simpl.
  unfold σ_data_from_τ.
  set (η := (unit_from_are_adjoints h)).
  etrans.
  { apply pathsinv0.
    apply φ_adj_inv_natural_postcomp.
  }
  apply maponpaths.
  set (Hτ := nat_trans_ax τ).
  etrans.
  { rewrite <- assoc.
    apply cancel_precomposition.
    apply pathsinv0.
    apply Hτ.
  }
  rewrite assoc.
  apply cancel_postcomposition.
  change (# (R ∙ K) (φ_adj_inv h g)) with (# K (# R (φ_adj_inv h g))).
  etrans.
  { apply pathsinv0.
    use functor_comp.
  }
  apply maponpaths.
  (* Locate "·". *)
  change (nat_trans_data_from_nat_trans η A · # R (φ_adj_inv h g)) with (φ_adj h (φ_adj_inv h g)).
  apply φ_adj_after_φ_adj_inv.
Qed.

Definition τ_data_from_σ {C C' D D' : category} {L : functor D C} {R : functor C D}
           {L' : functor D' C'} {R' : functor C' D'} {H : functor C C'} {K : functor D D' }
           (h : are_adjoints L R) (h' : are_adjoints L' R') (σ : DistrLaw L' L K H) :
  DistrLaw_data K H R R' :=
  λ B : C, φ_adj h' (nat_trans_data_from_nat_trans σ (R B) · #H (counit_from_are_adjoints h B)).

Lemma is_nat_trans_τ_data_from_σ {C C' D D' : category} {L : functor D C} {R : functor C D}
           {L' : functor D' C'} {R' : functor C' D'} {H : functor C C'} {K : functor D D' }
           (h : are_adjoints L R) (h' : are_adjoints L' R') (σ : DistrLaw L' L K H) :
  is_nat_trans _ _ (τ_data_from_σ h h' σ).
Proof.
  red.
  intros c c' f.
  unfold τ_data_from_σ.
  etrans.
  { apply pathsinv0.
    simpl.
    apply φ_adj_natural_precomp.
  }
  apply pathsinv0.
  etrans.
  { apply pathsinv0.
    simpl.
    apply φ_adj_natural_postcomp.
  }
  apply maponpaths.
  etrans.
  2: {
    set (Hσ := nat_trans_ax σ).
    change  (# L' (# K (# R f))) with ( # (K ∙ L') (#R f)).
    rewrite assoc.
    apply cancel_postcomposition.
    apply pathsinv0.
    apply Hσ.
  }
  rewrite <- assoc.
  rewrite <- functor_comp.
  rewrite <- assoc.
  apply cancel_precomposition.
  change (# (L ∙ H) (# R f)) with (# H (# (R ∙ L) f)).
  etrans.
  2: { apply (functor_comp H). }
  apply maponpaths.
  set (Hη := nat_trans_ax (counit_from_are_adjoints h)).
  apply pathsinv0.
  apply Hη.
Qed.

Definition τ_from_σ {C C' D D' : category} {L : functor D C} {R : functor C D}
           {L' : functor D' C'} {R' : functor C' D'} {H : functor C C'} {K : functor D D' }
           (h : are_adjoints L R) (h' : are_adjoints L' R') (σ : DistrLaw L' L K H) :
  DistrLaw K H R R'.
Proof.
  apply (make_nat_trans _ _ (τ_data_from_σ h h' σ)).
  apply is_nat_trans_τ_data_from_σ.
Defined.

Lemma τ_from_σ_is_conjugate {C C' D D' : category} {L : functor D C} {R : functor C D}
           {L' : functor D' C'} {R' : functor C' D'} {H : functor C C'} {K : functor D D' }
           (h : are_adjoints L R) (h' : are_adjoints L' R') (hs : has_homsets C') (σ : DistrLaw L' L K H) : are_conjugates h h' σ (τ_from_σ h h' σ).
Proof.
  red.
  intros A B g.
  unfold τ_from_σ; simpl.
  unfold τ_data_from_σ.
  set (ε := (counit_from_are_adjoints h)).
  etrans.
  2: { apply φ_adj_natural_precomp. }
  apply maponpaths.
  etrans.
  2: { set (Hσ := nat_trans_ax σ).
    rewrite assoc.
    apply cancel_postcomposition.
    apply pathsinv0.
    apply Hσ.
  }
  rewrite <- assoc.
  apply cancel_precomposition.
  change (# (L ∙ H) (φ_adj h g)) with (# H (# L (φ_adj h g))).
  etrans.
  2: { apply (functor_comp H). }
  apply maponpaths.
  apply pathsinv0.
  apply φ_adj_inv_after_φ_adj.
Qed.

End Conjugates.

Section Liftings.

Definition is_lifting {C D: category} {F: functor C C} {G: functor D D} (H: functor C D) (HH: functor (FunctorAlg F) (FunctorAlg G)): UU.
Proof.
  set (UF := forget_algebras F).
  set (UG := forget_algebras G).
  exact (UF ∙ H = HH ∙ UG).
Defined.

Definition lifting_from_distr_law_data_on_ob {C D: category} {F: functor C C} {G: functor D D} {H: functor C D} (lambda : DistrLaw G F H H): FunctorAlg F → FunctorAlg G.
Proof.
  intro Aa.
  set (A := alg_carrier _ Aa).
  set (a := alg_map _ Aa).
  set (B := H A).
  set (b := nat_trans_data_from_nat_trans lambda A · (# H a)).
  use tpair.
  - exact B.
  - exact b.
Defined.

Lemma lifting_from_distr_law_data_aux {C D: category} {F: functor C C} {G: functor D D} {H: functor C D} (lambda : DistrLaw G F H H)(Aa Bb : algebra_ob F)(h : algebra_mor F Aa Bb)
  : is_algebra_mor G (lifting_from_distr_law_data_on_ob lambda Aa)
                     (lifting_from_distr_law_data_on_ob lambda Bb) (#H h).
Proof.
  unfold is_algebra_mor.
  simpl.
  set (ax := nat_trans_ax lambda).
  apply pathsinv0.
  etrans.
  { rewrite assoc.
    apply cancel_postcomposition.
    apply ax. }
  rewrite <- assoc.
  apply pathsinv0.
  rewrite <- assoc.
  apply cancel_precomposition.
  set (h_commutes := algebra_mor_commutes _ _ _ h).
  rewrite <- functor_comp.
  apply pathsinv0.
  change (# (F ∙ H) h) with (# H (# F h)).
  etrans.
  { apply pathsinv0.
    apply (functor_comp H). }
  apply maponpaths.
  apply pathsinv0.
  apply h_commutes.
Qed.

Definition lifting_from_distr_law_data {C D: category} {F: functor C C} {G: functor D D} {H: functor C D} (lambda : DistrLaw G F H H): functor_data (FunctorAlg F) (FunctorAlg G).
Proof.
  use make_functor_data.
  - apply (lifting_from_distr_law_data_on_ob lambda).
  - cbn.
    intros Aa Bb.
    intro h.
    unfold algebra_mor.
    use tpair.
    + exact (#H (pr1 h)).
    + apply lifting_from_distr_law_data_aux.
Defined.

Lemma is_functor_lifting_from_distr_law_data {C D: category} {F: functor C C} {G: functor D D} {H: functor C D} (lambda : DistrLaw G F H H): is_functor (lifting_from_distr_law_data lambda).
Proof.
  split.
  - intro Aa.
    unfold lifting_from_distr_law_data.
    cbn.
    UniMath.MoreFoundations.Tactics.show_id_type.
    use total2_paths_f.
    2: { apply homset_property. }

    (*Locate algebra_mor_eq.*)
(*    + assumption. *)
    cbn.
    apply functor_id.
  - intros Aa Bb Cc f g.
    unfold lifting_from_distr_law_data.
    cbn.
    UniMath.MoreFoundations.Tactics.show_id_type.
    use total2_paths_f.
    2: { apply homset_property. }
    cbn.
    apply functor_comp.
Qed.

Definition lifting_from_distr_law {C D: category} {F: functor C C} {G: functor D D} {H: functor C D} (lambda : DistrLaw G F H H): functor (FunctorAlg F) (FunctorAlg G).
Proof.
  use tpair.
  - apply (lifting_from_distr_law_data lambda).
  - apply is_functor_lifting_from_distr_law_data.
Defined.

Lemma lifting_from_distr_law_is_lifting {C D: category} {F: functor C C} {G: functor D D} (H: functor C D) (lambda : DistrLaw G F H H):
  is_lifting H (lifting_from_distr_law lambda ).
Proof.
  unfold is_lifting.
  set (Hλ := lifting_from_distr_law lambda).
  (*UniMath.MoreFoundations.Tactics.show_id_type.*)
  (*Locate "⟶".*)
  apply functor_eq.
  - apply D.
  - apply idpath.
Qed.

(** a simple preparation for the next lemma - strictly speaking, not even needed *)
Ltac get_sides_of_eq := match goal with |- @paths _ ?L ?R => set (left := L); set (right := R) end.

Arguments idtomor {_ _ _ } _.

(** unnamed result by Hinze & Wu, mentioned in their Sect. 3.2.1 *)
Lemma liftings_from_distr_laws_compose {C C' C'': category}
      {F: functor C C} {F': functor C' C'} {F'': functor C'' C''}
      {H: functor C C'} {H': functor C' C''}
      (lambda : DistrLaw F' F H H)(lambda' : DistrLaw F'' F' H' H'):
  lifting_from_distr_law lambda ∙ lifting_from_distr_law lambda' =
  lifting_from_distr_law (H := H ∙ H') (comp_distr_laws lambda' lambda).
Proof.
  (* UniMath.MoreFoundations.Tactics.show_id_type. *)
  apply functor_eq.
  { apply homset_property. }
  simpl.
  (* UniMath.MoreFoundations.Tactics.show_id_type. *)
  get_sides_of_eq.
  (* we have to read the expressions back, so as to get functor_data between precategories: *)
  set (left' := functor_composite_data (lifting_from_distr_law_data lambda)
            (lifting_from_distr_law_data lambda')).
  set (right' := lifting_from_distr_law_data (comp_distr_laws lambda' lambda)
   : functor_data (FunctorAlg F) (FunctorAlg F'')).
  transparent assert (okonobs: (functor_on_objects left' ~ functor_on_objects right')).
  { intro alg.
    cbn. unfold lifting_from_distr_law_data_on_ob. cbn.
    (* UniMath.MoreFoundations.Tactics.show_id_type. *)
    apply (maponpaths (λ p, tpair _ (H' (H (alg_carrier F alg))) p )).
    abstract ( repeat rewrite id_left; rewrite id_right; rewrite <- assoc; apply maponpaths; apply functor_comp ).
  }
  (* UniMath.MoreFoundations.Tactics.show_id_type. *)
  apply (functor_data_eq_from_nat_trans _ _ _ _ okonobs).
  red.
  intros alg1 alg2 m.
  (* UniMath.MoreFoundations.Tactics.show_id_type. *)
  apply algebra_mor_eq.
(*  { assumption. } *)
  simpl.
  (* UniMath.MoreFoundations.Tactics.show_id_type. *)
  etrans.
  { apply cancel_precomposition.
    UniMath.MoreFoundations.Tactics.show_id_type.
    apply (idtomor_FunctorAlg_commutes _ _ _ (okonobs alg2)).
  }
  etrans.
  2: {
    apply cancel_postcomposition.
    UniMath.MoreFoundations.Tactics.show_id_type.
    apply pathsinv0.
    apply (idtomor_FunctorAlg_commutes _ _ _ (okonobs alg1)).
  }
  assert (Hyp: (idtomor (maponpaths (alg_carrier F'') (okonobs alg1)) = identity _) ×
               (idtomor (maponpaths (alg_carrier F'') (okonobs alg2)) = identity _)).
  { unfold okonobs; split.
    - etrans.
      { apply maponpaths.
        apply (maponpathscomp (λ p :
       C'' ⟦ F'' (H' (H (alg_carrier F alg1))), H' (H (alg_carrier F alg1)) ⟧,
       tpair (fun X: C'' => C'' ⟦ F'' X, X ⟧)
             (H' (H (alg_carrier F alg1))) p)
                              (alg_carrier F'')).
      }
      unfold funcomp.
      simpl.
      rewrite UniMath.MoreFoundations.PartA.maponpaths_for_constant_function.
      apply idpath.
    - etrans.
      { apply maponpaths.
        apply (maponpathscomp (λ p :
       C'' ⟦ F'' (H' (H (alg_carrier F alg2))), H' (H (alg_carrier F alg2)) ⟧,
       tpair (fun X: C'' => C'' ⟦ F'' X, X ⟧)
             (H' (H (alg_carrier F alg2))) p)
                              (alg_carrier F'')).
      }
      unfold funcomp.
      simpl.
      rewrite UniMath.MoreFoundations.PartA.maponpaths_for_constant_function.
      apply idpath.
  }
  induction Hyp as [Hyp1 Hyp2].
  rewrite Hyp1. rewrite Hyp2.
  rewrite id_right.
  apply pathsinv0.
  apply id_left.
Qed.

End Liftings.

Section AdjointFolds.

(* the conclusion of the following theorem is done after the example of [UniMath.SubstitutionSystems.GenMendlerIteration], and its proof is divided in the same way *)

Local Notation "↓ f" := (mor_from_algebra_mor _ f) (at level 3, format "↓ f").
(* in Agda mode \downarrow *)

Context {C D: category}
  {L: functor D C} {R: functor C D}  (h : are_adjoints L R) {CC: functor C C} {DD: functor D D}
  (μDD_Initial : Initial (FunctorAlg DD))
  {σ: DistrLaw L L DD CC} {τ: DistrLaw DD CC R R} (hh: are_conjugates h h σ τ)
  {B: C} (b: CC B --> B).

Let AF := FunctorAlg CC.

Definition AlgConstr (A : C) (a : CC A --> A) : AF.
Proof.
  exists B.
  exact b.
Defined.

Let μDD: D := alg_carrier _ (InitialObject μDD_Initial).
(* Locate InitialObject. *)
Let inDD: DD(μDD) --> μDD := alg_map _ (InitialObject μDD_Initial).

Definition traho_of_Hinze_Wu : L μDD --> B.
Proof.
  set (x := φ_adj_inv h ↓(InitialArrow μDD_Initial (lifting_from_distr_law τ (AlgConstr B b)))).
  exact x.
Defined.

Definition φ_adj_traho_of_Hinze_Wu : algebra_mor DD (InitialObject μDD_Initial)
                                                 ((lifting_from_distr_law τ) (AlgConstr B b)).
Proof.
  use tpair.
  - exact (φ_adj h traho_of_Hinze_Wu).
  - red.
    unfold traho_of_Hinze_Wu.
    rewrite φ_adj_after_φ_adj_inv.
    apply (algebra_mor_commutes _ _ _ (InitialArrow μDD_Initial (lifting_from_distr_law_data_on_ob τ (AlgConstr B b)))).
Defined.

Lemma traho_of_Hinze_Wu_ok : #L inDD · traho_of_Hinze_Wu =
                             nat_trans_data_from_nat_trans σ μDD · # CC traho_of_Hinze_Wu · b.
Proof.
  etrans.
  apply pathsinv0.
  use φ_adj_inv_after_φ_adj .
  exact R.
  exact h.
  apply pathsinv0.
  etrans.
  apply pathsinv0.
  use φ_adj_inv_after_φ_adj .
  exact R.
  exact h.
  apply maponpaths.

  etrans.
  use φ_adj_natural_postcomp.
  apply pathsinv0.
  etrans.
  use φ_adj_natural_precomp.
  apply pathsinv0.
  etrans.
  apply cancel_postcomposition.
  use hh .

  rewrite <- assoc.
  (*
  set (n := nat_trans_data_from_nat_trans τ B · # R b).
  set (m := alg_map DD ((lifting_from_distr_law hsC hsD τ) (AlgConstr' B b))).
  simpl in m.
  change (nat_trans_data_from_nat_trans τ B · # R b) with m.
   *)
  change (nat_trans_data_from_nat_trans τ B · # R b) with
      (alg_map DD ((lifting_from_distr_law τ) (AlgConstr B b))).
  (*Locate InitialArrow.*)

  apply pathsinv0.
  apply  (algebra_mor_commutes DD _ _ φ_adj_traho_of_Hinze_Wu).
Qed.

Definition φ_adj_h_x (x : C ⟦ L μDD, B ⟧)
  (Hyp: # DD (φ_adj h x) · alg_map DD ((lifting_from_distr_law τ)(AlgConstr B b)) =
        inDD · φ_adj h x):
  algebra_mor DD (InitialObject μDD_Initial) ((lifting_from_distr_law τ) (AlgConstr B b)).
Proof.
  use tpair.
  - exact (φ_adj h x).
  - red.
    apply pathsinv0.
    apply Hyp.
Defined.

Lemma φ_adj_h_x_equals_initial_arrow (x : C ⟦ L μDD, B ⟧) :
  # DD (φ_adj h x) · alg_map DD((lifting_from_distr_law τ)(AlgConstr B b)) =
  inDD · φ_adj h x ->
  φ_adj h x = ↓ (InitialArrow μDD_Initial ((lifting_from_distr_law τ) (AlgConstr B b))).
Proof.
  intro Hyp.
  set (aux := InitialArrowUnique μDD_Initial _ (φ_adj_h_x x Hyp)).
  (* UniMath.MoreFoundations.Tactics.show_id_type. *)
  set (aux' := mor_from_algebra_mor _ (φ_adj_h_x x Hyp)).
  simpl in aux'.
  change (φ_adj h x) with (mor_from_algebra_mor _ (φ_adj_h_x x Hyp)).
  rewrite aux.
  apply idpath.
Qed.

(** The following formalizes Theorem 5.2 (Adjoint folds) of Hinze and Wu. *)
Theorem TheoremOfHinzeAndWu :
  iscontr (∑ x : L μDD --> B, #L inDD · x = nat_trans_data_from_nat_trans σ μDD · # CC x · b).
Proof.
  red.
  exists (traho_of_Hinze_Wu,, traho_of_Hinze_Wu_ok).

  intro t.
  induction t as [x hyp].
  assert (same: x = traho_of_Hinze_Wu).
  2: {
    apply subtypePath.
    + intro.
      simpl.
      apply C.
    + simpl.
      exact same.
  }

  etrans.
  { apply pathsinv0.
    apply (φ_adj_inv_after_φ_adj h).
  }
  etrans.
  2: {
    apply (φ_adj_inv_after_φ_adj h).
  }
  apply maponpaths.
  unfold traho_of_Hinze_Wu.
  rewrite (φ_adj_after_φ_adj_inv h).

  apply φ_adj_h_x_equals_initial_arrow.
  simpl.

  etrans.
  { rewrite assoc.
    apply cancel_postcomposition.
    apply pathsinv0.
    apply hh.
  }
  etrans.
  { apply pathsinv0.
    apply φ_adj_natural_postcomp.
  }
  etrans.
  2 : {
    apply φ_adj_natural_precomp.
  }
  apply maponpaths.
  apply pathsinv0.
  exact hyp.

Defined.

End AdjointFolds.


Require Import List.
Require Import String.
Require Import ZArith.

Open Scope list_scope.
Open Scope string_scope.
Open Scope Z_scope.

Require Import StructTactics.
Require Import ImpSyntax.
Require Import ImpCommon.
Require Import ImpEval.
Require Import ImpInterp.
Require Import ImpInterpNock.
Require Import ImpInterpProof.
Require Import ImpInterpNockProof.
Require Import ImpVerif.
Require Import ImpSemanticsFacts.

Import ListNotations.

Definition sum_body :=
  (Sseq
  (Sset "i" (Eval (Vint 0)))
  (Sseq
  (Sset "result" (Eval (Vint 0)))
  (Swhile (Eop2 Olt (Evar "i") (Elen (Evar "a")))
    (Sseq
    (Sset "result" (Eop2 Oadd (Evar "result") (Eidx (Evar "a") (Evar "i"))))
    (Sset "i" (Eop2 Oadd (Evar "i") (Eval (Vint 1)))))))).

Definition sum_ret :=
  (Evar "result").

Definition sum_func :=
  (Func "sum" ("a" :: nil)
      sum_body
      sum_ret).

(* Carefully designed to match control flow of loop body above. *)
Fixpoint sum_Zlist (acc : Z) (l : list Z) : Z :=
  match l with
  | [] => acc
  | z :: l => sum_Zlist (acc + z) l
  end.

Lemma skipn_none :
  forall A (l : list A),
    skipn (List.length l) l = [].
Proof. induction l; simpl; auto using f_equal. Qed.

Lemma skipn_nth_error_unroll :
  forall A n (l : list A) a,
    nth_error l n = Some a ->
    skipn n l = a :: skipn (S n) l.
Proof.
  induction n; destruct l; simpl; intros; try congruence.
  erewrite IHn by eauto. destruct l; auto.
Qed.

Lemma sum_spec :
  forall env s h s' h' a_val contents,
    lkup s "a" = Some (Vaddr a_val) ->
    array_at a_val contents h ->
    eval_s env s h sum_body s' h' ->
    h = h' /\
    lkup s' "result" = Some (Vint (sum_Zlist 0 contents)).
Proof.
  intros env s h s' h' a_val contents Ha Harr Heval.
  unfold sum_body in *.
  repeat (step_forward; break_eval_expr).
  pose proof (array_at_read_length _ _ _ Harr).
  eapply eval_stmt_while_elim
  with (I := fun s h => h = h0 /\
    exists i_val acc,
      lkup s "a" = Some (Vaddr a_val) /\
      lkup s "i" = Some (Vint i_val) /\
      0 <= i_val <= Zlength contents /\
      lkup s "result" = Some (Vint acc) /\
      sum_Zlist acc (skipn (Z.to_nat i_val) contents) = sum_Zlist 0 contents)
    in H7.
  - (* loop invariant /\ false -> postcondition *)
    break_and. break_exists. break_and.
    break_eval_expr.
    repeat find_rewrite.
    repeat find_injection.
    unfold imp_lt, pred_of_dec in *. break_if; try discriminate.
    assert (i1 = Zlength contents) by omega. subst.
    rewrite Zlength_correct, Nat2Z.id, skipn_none in *.
    auto using f_equal.
  - (* precondition -> loop invariant *)
    split; auto.
    exists 0, 0.
    rewrite !lkup_update_neq by discriminate.
    rewrite !lkup_update_same.
    intuition.
    rewrite Zlength_correct. zify. auto.
  - (* condition = true -> loop body preserves invariant *)
    match goal with
    | [ H : eval_s _ _ _ _ _ _ |- _ ] => clear H
    end.
    intros.
    break_and. subst.
    break_exists. break_and.
    break_eval_expr.
    step_forward.
    step_forward.
    break_eval_expr.
    step_forward.
    break_eval_expr.
    repeat find_rewrite.
    repeat find_injection.
    break_eval_expr.
    split; auto.
    rewrite !lkup_update_neq in * by discriminate.
    rewrite !lkup_update_same in *.
    repeat find_rewrite.
    repeat find_injection.
    exists (i0 + 1), (acc + i3).
    intuition.
    + unfold imp_lt in *.
      find_apply_lem_hyp pred_of_dec_true_elim.
      omega.
    + rewrite !lkup_update_neq in * by discriminate.
      rewrite !lkup_update_same in *.
      auto.
    + rewrite Z.add_1_r.
      rewrite Z2Nat.inj_succ by auto.
      unfold imp_lt, pred_of_dec in *. break_if; try discriminate.
      find_eapply_lem_hyp  array_at_read_nth_error; eauto.
      erewrite skipn_nth_error_unroll in * by eauto.
      cbn [sum_Zlist] in *. auto.
Qed.

Lemma sum_total_spec :
  forall env s h a_val contents,
    lkup s "a" = Some (Vaddr a_val) ->
    array_at a_val contents h ->
    after env s h sum_body (fun s' h' =>
      h' = h /\
      lkup s' "result" = Some (Vint (sum_Zlist 0 contents))).
Proof.
  intros.
  unfold sum_body.

  apply after_seq.
  eapply after_set; eauto.

  apply after_seq.
  eapply after_set; eauto.

  apply after_while
  with (I := fun s0 h0 =>
             h0 = h /\
             lkup s0 "a" = Some (Vaddr a_val) /\
             exists i_val acc,
               lkup s0 "i" = Some (Vint i_val) /\
               0 <= i_val <= Zlength contents /\
               lkup s0 "result" = Some (Vint acc) /\
               sum_Zlist acc (skipn (Z.to_nat i_val) contents) = sum_Zlist 0 contents)
       (f := fun s0 =>
             match lkup s0 "i" with
             | Some (Vint i) =>
               Z.to_nat (Zlength contents - i)
             | _ => 0%nat
             end).
  - (* I -> condition safety *)
    intuition.
    break_exists. break_and.
    subst.
    eauto 10 using array_at_read_length.
  - (* precondition *)
    intuition.
    exists 0, 0.
    rewrite !lkup_update_neq by discriminate.
    rewrite !lkup_update_same.
    intuition.
    rewrite Zlength_correct.
    zify. omega.
  - (* body obligation *)
    intuition. subst.
    break_exists.
    break_and.
    break_eval_expr.
    repeat find_rewrite.
    repeat find_injection.
    unfold imp_lt in *.
    find_eapply_lem_hyp pred_of_dec_true_elim.
    apply after_seq.
    eapply after_set.
    eauto 10 using array_at_read_length, array_at_read_nth with *.

    eapply after_set.
    eauto.

    rewrite !lkup_update_neq by discriminate.
    rewrite !lkup_update_same.
    rewrite !lkup_update_neq by discriminate.
    rewrite !lkup_update_same.
    intuition.
    + do 2 eexists.
      intuition eauto.
      omega.
      omega.
      erewrite skipn_nth_error_unroll with (a := nth (Z.to_nat i1) contents 0) in *|-.
      * cbn [sum_Zlist] in *.
        etransitivity; [|eauto].
        f_equal.
        f_equal.
        zify. rewrite !Z2Nat.id by omega. omega.
      * apply nth_nth_error.
        rewrite Zlength_correct in *.
        zify.
        rewrite Z2Nat.id in * by auto.
        omega.
    + rewrite Zlength_correct in *.
      zify. rewrite !Z2Nat.id in * by omega. omega.
- (* postcondition *)
  intuition.
  break_exists. break_and. subst.
  break_eval_expr.
  repeat find_rewrite.
  repeat find_injection.
  unfold imp_lt in *.
  find_apply_lem_hyp pred_of_dec_false_elim.
  assert (i1 = Zlength contents) by omega.
  subst.
  rewrite Zlength_correct in *.
  rewrite Nat2Z.id in *.
  rewrite skipn_none in *.
  cbn [sum_Zlist] in *.
  congruence.
Qed.


(** This file collects general purpose definitions and theorems on
lists of numbers that are not in the Coq standard library. *)
From stdpp Require Export list.
From stdpp Require Import options.

(** * Definitions *)
(** [seqZ m n] generates the sequence [m], [m + 1], ..., [m + n - 1]
over integers, provided [0 ≤ n]. If [n < 0], then the range is empty. **)
Definition seqZ (m len: Z) : list Z :=
  (λ i: nat, Z.add i m) <$> (seq 0 (Z.to_nat len)).
Arguments seqZ : simpl never.

Definition sum_list_with {A} (f : A → nat) : list A → nat :=
  fix go l :=
  match l with
  | [] => 0
  | x :: l => f x + go l
  end.
Notation sum_list := (sum_list_with id).

Definition max_list_with {A} (f : A → nat) : list A → nat :=
  fix go l :=
  match l with
  | [] => 0
  | x :: l => f x `max` go l
  end.
Notation max_list := (max_list_with id).

(** * Properties *)
(** ** Properties of the [seq] function *)
Section seq.
  Implicit Types m n i j : nat.

  Lemma fmap_add_seq j j' n : Nat.add j <$> seq j' n = seq (j + j') n.
  Proof.
    revert j'. induction n as [|n IH]; intros j'; csimpl; [reflexivity|].
    by rewrite IH, Nat.add_succ_r.
  Qed.
  Lemma fmap_S_seq j n : S <$> seq j n = seq (S j) n.
  Proof. apply (fmap_add_seq 1). Qed.
  Lemma imap_seq {A B} (l : list A) (g : nat → B) i :
    imap (λ j _, g (i + j)) l = g <$> seq i (length l).
  Proof.
    revert i. induction l as [|x l IH]; [done|].
    csimpl. intros n. rewrite <-IH, <-plus_n_O. f_equal.
    apply imap_ext; simpl; auto with lia.
  Qed.
  Lemma imap_seq_0 {A B} (l : list A) (g : nat → B) :
    imap (λ j _, g j) l = g <$> seq 0 (length l).
  Proof. rewrite (imap_ext _ (λ i o, g (0 + i))); [|done]. apply imap_seq. Qed.
  Lemma lookup_seq_lt j n i : i < n → seq j n !! i = Some (j + i).
  Proof.
    revert j i. induction n as [|n IH]; intros j [|i] ?; simpl; auto with lia.
    rewrite IH; auto with lia.
  Qed.
  Lemma lookup_total_seq_lt j n i : i < n → seq j n !!! i = j + i.
  Proof. intros. by rewrite !list_lookup_total_alt, lookup_seq_lt. Qed.
  Lemma lookup_seq_ge j n i : n ≤ i → seq j n !! i = None.
  Proof. revert j i. induction n; intros j [|i] ?; simpl; auto with lia. Qed.
  Lemma lookup_total_seq_ge j n i : n ≤ i → seq j n !!! i = inhabitant.
  Proof. intros. by rewrite !list_lookup_total_alt, lookup_seq_ge. Qed.
  Lemma lookup_seq j n i j' : seq j n !! i = Some j' ↔ j' = j + i ∧ i < n.
  Proof.
    destruct (le_lt_dec n i).
    - rewrite lookup_seq_ge by done. naive_solver lia.
    - rewrite lookup_seq_lt by done. naive_solver lia.
  Qed.
  Lemma NoDup_seq j n : NoDup (seq j n).
  Proof. apply NoDup_ListNoDup, seq_NoDup. Qed.
  Lemma seq_S_end_app j n : seq j (S n) = seq j n ++ [j + n].
  Proof.
    revert j. induction n as [|n IH]; intros j; simpl in *; f_equal; [done |].
    by rewrite IH, Nat.add_succ_r.
  Qed.

  Lemma Forall_seq (P : nat → Prop) i n :
    Forall P (seq i n) ↔ ∀ j, i ≤ j < i + n → P j.
  Proof.
    rewrite Forall_lookup. split.
    - intros H j [??]. apply (H (j - i)), lookup_seq. lia.
    - intros H j x [-> ?]%lookup_seq. auto with lia.
  Qed.
End seq.

(** ** Properties of the [seqZ] function *)
Section seqZ.
  Implicit Types (m n : Z) (i j : nat).
  Local Open Scope Z.

  Lemma seqZ_nil m n : n ≤ 0 → seqZ m n = [].
  Proof. by destruct n. Qed.
  Lemma seqZ_cons m n : 0 < n → seqZ m n = m :: seqZ (Z.succ m) (Z.pred n).
  Proof.
    intros H. unfold seqZ. replace n with (Z.succ (Z.pred n)) at 1 by lia.
    rewrite Z2Nat.inj_succ by lia. f_equal/=.
    rewrite <-fmap_S_seq, <-list_fmap_compose.
    apply map_ext; naive_solver lia.
  Qed.
  Lemma seqZ_length m n : length (seqZ m n) = Z.to_nat n.
  Proof. unfold seqZ; by rewrite fmap_length, seq_length. Qed.
  Lemma fmap_add_seqZ m m' n : Z.add m <$> seqZ m' n = seqZ (m + m') n.
  Proof.
    revert m'. induction n as [|n ? IH|] using (Z_succ_pred_induction 0); intros m'.
    - by rewrite seqZ_nil.
    - rewrite (seqZ_cons m') by lia. rewrite (seqZ_cons (m + m')) by lia.
      f_equal/=. rewrite Z.pred_succ, IH; simpl. f_equal; lia.
    - by rewrite !seqZ_nil by lia.
  Qed.
  Lemma lookup_seqZ_lt m n i : i < n → seqZ m n !! i = Some (m + i).
  Proof.
    revert m i. induction n as [|n ? IH|] using (Z_succ_pred_induction 0);
      intros m i Hi; [lia| |lia].
    rewrite seqZ_cons by lia. destruct i as [|i]; simpl.
    - f_equal; lia.
    - rewrite Z.pred_succ, IH by lia. f_equal; lia.
  Qed.
  Lemma lookup_total_seqZ_lt m n i : i < n → seqZ m n !!! i = m + i.
  Proof. intros. by rewrite !list_lookup_total_alt, lookup_seqZ_lt. Qed.
  Lemma lookup_seqZ_ge m n i : n ≤ i → seqZ m n !! i = None.
  Proof.
    revert m i.
    induction n as [|n ? IH|] using (Z_succ_pred_induction 0); intros m i Hi; try lia.
    - by rewrite seqZ_nil.
    - rewrite seqZ_cons by lia.
      destruct i as [|i]; simpl; [lia|]. by rewrite Z.pred_succ, IH by lia.
    - by rewrite seqZ_nil by lia.
  Qed.
  Lemma lookup_total_seqZ_ge m n i : n ≤ i → seqZ m n !!! i = inhabitant.
  Proof. intros. by rewrite !list_lookup_total_alt, lookup_seqZ_ge. Qed.
  Lemma lookup_seqZ m n i m' : seqZ m n !! i = Some m' ↔ m' = m + i ∧ i < n.
  Proof.
    destruct (Z_le_gt_dec n i).
    - rewrite lookup_seqZ_ge by lia. naive_solver lia.
    - rewrite lookup_seqZ_lt by lia. naive_solver lia.
  Qed.
  Lemma NoDup_seqZ m n : NoDup (seqZ m n).
  Proof. apply NoDup_fmap_2, NoDup_seq. intros ???; lia. Qed.

  Lemma Forall_seqZ (P : Z → Prop) m n :
    Forall P (seqZ m n) ↔ ∀ m', m ≤ m' < m + n → P m'.
  Proof.
    rewrite Forall_lookup. split.
    - intros H j [??]. apply (H (Z.to_nat (j - m))), lookup_seqZ.
      rewrite !Z2Nat.id by lia. lia.
    - intros H j x [-> ?]%lookup_seqZ. auto with lia.
  Qed.
End seqZ.

(** ** Properties of the [sum_list] and [max_list] functions *)
Section sum_list.
  Context {A : Type}.
  Implicit Types x y z : A.
  Implicit Types l k : list A.
  Lemma sum_list_with_app (f : A → nat) l k :
    sum_list_with f (l ++ k) = sum_list_with f l + sum_list_with f k.
  Proof. induction l; simpl; lia. Qed.
  Lemma sum_list_with_reverse (f : A → nat) l :
    sum_list_with f (reverse l) = sum_list_with f l.
  Proof.
    induction l; simpl; rewrite ?reverse_cons, ?sum_list_with_app; simpl; lia.
  Qed.
  Lemma join_reshape szs l :
    sum_list szs = length l → mjoin (reshape szs l) = l.
  Proof.
    revert l. induction szs as [|sz szs IH]; simpl; intros l Hl; [by destruct l|].
    by rewrite IH, take_drop by (rewrite drop_length; lia).
  Qed.
  Lemma sum_list_replicate n m : sum_list (replicate m n) = m * n.
  Proof. induction m; simpl; auto. Qed.
  Lemma max_list_elem_of_le n ns:
    n ∈ ns → n ≤ max_list ns.
  Proof. induction 1; simpl; lia. Qed.
End sum_list.


(*
 * Licensed under the Apache License, Version 2.0 (the "License");
 * you may not use this file except in compliance with the License.
 * You may obtain a copy of the License at
 *
 * http://www.apache.org/licenses/LICENSE-2.0
 *
 * Unless required by applicable law or agreed to in writing, software
 * distributed under the License is distributed on an "AS IS" BASIS,
 * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
 * See the License for the specific language governing permissions and
 * limitations under the License.
 *)

Require Import RelationClasses.
Require Import Morphisms.
Require Import Equivalence.
Require Import Setoid.
Require Import EquivDec.

(** Definition of monoids over collections, loosely based on ideas
    from "Optimizing object queries using an effective
    calculus. Leonidas Fegaras and David Maier. In ACM Transactions on
    Database Systems (TODS) 25.4 (2000): 457-516."

    Some of the type classes structure follow from: "A Gentle
    Introduction to Type Classes and Relations in Coq. Pierre Castéran
    and Matthieu Sozeau" *)

(** #<b>Warning: This module is not used.</b> *)

Section Monoid.

  Local Open Scope equiv_scope.

  Definition associative {A} eqA `{equivA : Equivalence A eqA} (op : A->A->A)
    := forall x₁ x₂ x₃, op (op x₁ x₂) x₃ === op x₁ (op x₂ x₃).

  Definition commutative {A} eqA `{equivA : Equivalence A eqA} (op : binary_operation A)
    := forall x₁ x₂, op x₁ x₂ === op x₂ x₁.

  Definition idempotent {A} eqA `{equivA : Equivalence A eqA} (op : binary_operation A)
    := forall x, op x x === x.

  Definition anti_idempotent {A} eqA `{equivA : Equivalence A eqA} (op : binary_operation A)
    := forall x, not (op x x === x).

  Definition zero_left {A} eqA `{equivA : Equivalence A eqA} (op : binary_operation A) (z : A)
    := forall x, op z x === x.

  Definition zero_right {A} eqA `{equivA : Equivalence A eqA} (op : binary_operation A) (z : A)
    := forall x, op x z === x.

  Class Monoid (A:Type) (eqA:A->A->Prop) {equivB:Equivalence eqA}
    := {
        merge: A -> A -> A;
        z: A;

        merge_morphism :> Proper (eqA ==> eqA ==> eqA) merge ;
        z_morphism :> Proper (eqA) z;

        merge_assoc: associative eqA merge;
        z_left: zero_left eqA merge z;
        z_right: zero_right eqA merge z
      }.

  Infix "⊕" := merge (at level 70). (* ⊕ = \oplus *)
  Infix "ζ" := z (at level 70).  (* ζ = \zeta *)

  (** A collection monoid. *)

  Class CollMonoid {A U:Type}
        (eqA:A->A->Prop)
        `{monoid:Monoid A eqA}
    := {
        unit: U -> A;
        }.

  (** A commutative monoid. *)

  Class CMonoid {A:Type}
        (eqA:A->A->Prop)
        `{monoid:Monoid A eqA}
    := {
        c_merge_comm: commutative eqA merge
        }.

  (** An idempotent monoid. *)

  Class IMonoid {A:Type}
        (eqA:A->A->Prop)
        `{monoid:Monoid A eqA}
    := {
        i_merge_idem: idempotent eqA merge
        }.

  (** An anti-idempotent monoid. *)

  Class AIMonoid {A:Type}
        (eqA:A->A->Prop)
        `{monoid:Monoid A eqA}
    := {
        ai_merge_anti_idem: anti_idempotent eqA merge
        }.

  (** A commutative & idempotent monoid. *)

  Class CIMonoid {A:Type}
        (eqA:A->A->Prop)
        `{monoid:Monoid A eqA}
    := {
        ci_merge_comm: commutative eqA merge;
        ci_merge_idem: idempotent eqA merge
      }.

  (** A commutative & anti-idempotent monoid. *)

  Class CAIMonoid {A:Type}
        (eqA:A->A->Prop)
        `{monoid:Monoid A eqA}
    := {
        cai_merge_comm: commutative eqA merge;
        cai_merge_idem: anti_idempotent eqA merge
      }.

  (* Monoid homomorphisms *)
  (* TBD *)

End Monoid.

Infix "⊕" := merge (at level 70). (* ⊕ = \oplus *)
Infix "ζ" := z (at level 70).  (* ζ = \zeta *)


(** Coq coding by choukh, Oct 2021 **)

Require Import BBST.Axiom.Meta.
Require Import BBST.Axiom.Extensionality.
Require Import BBST.Axiom.Separation.
Require Import BBST.Axiom.Union.
Require Import BBST.Axiom.Pairing.
Require Import BBST.Definition.Emptyset.
Require Import BBST.Definition.Singleton.
Require Import BBST.Definition.Intersect.
Require Import BBST.Definition.BinaryUnion.
Require Import BBST.Definition.BinaryIntersect.

Definition 序偶 := λ a b, {{a,}, {a, b}}.
Notation "< a , b , .. , c >" := ( 序偶 .. ( 序偶 a b ) .. c )
  (c at level 69, format "< a ,  b ,  .. ,  c >") : 集合域.

Theorem 序偶相等 : ∀ a b c d, <a, b> = <c, d> ↔ a = c ∧ b = d.
Proof.
  split; intros.
  - apply 配对相等 in H as [[]|[]].
    + apply 单集相等 in H; subst.
      apply 配对相等 in H0 as [[]|[]]; split; congruence.
    + apply 单集配对相等 in H as []. symmetry in H0.
      apply 单集配对相等 in H0 as []. split; congruence.
  - destruct H; congruence.
Qed.

Lemma 序偶之并 : ∀ a b, ⋃<a, b> = {a, b}.
Proof with auto.
  intros. 外延.
  - apply 并集除去 in H as [A [H1 H2]]. apply 配对除去 in H1 as []; subst...
    apply 单集除去 in H2; subst...
  - apply 配对除去 in H as []; subst. apply 左并介入... apply 右并介入...
Qed.

Lemma 序偶之交 : ∀ a b, ⋂<a, b> = {a,}.
Proof with auto.
  intros. unfold 序偶. 外延.
  - apply 交集除去 in H as [_ H]. apply H...
  - apply 单集除去 in H; subst. apply 交集介入. exists {a,}...
    intros x Hx. apply 配对除去 in Hx as []; subst...
Qed.

Definition 左 := λ p, ⋃ ⋂ p.
Definition 右 := λ p, ⋃ {x ∊ ⋃ p | x ∈ ⋂ p → ⋃ p = ⋂ p}.

Theorem 左投影 : ∀ a b, 左 <a, b> = a.
Proof. intros. unfold 左. rewrite 序偶之交. now rewrite 单集之并. Qed.

Theorem 右投影 : ∀ a b, 右 <a, b> = b.
Proof.
  intros. unfold 右. rewrite 序偶之并, 序偶之交. 外延.
  - apply 并集除去 in H as [A [HA Hx]].
    apply 分离除去 in HA as [H1 H2].
    apply 配对除去 in H1 as []; subst; auto.
    pose proof (H2 (单集介入 a)). symmetry in H.
    now apply 单集配对相等 in H as [_ H]; subst.
  - eapply 并集介入; eauto. apply 分离介入; auto.
    intros. now apply 单集除去 in H0; subst.
Qed.

Global Hint Rewrite 左投影 右投影 : core.
Ltac 化简 := autorewrite with core in *; try congruence.

Definition 为序偶 := λ p, ∃ x y, p = <x, y>.

Fact 序偶为之 : ∀ x y, 为序偶 <x, y>.
Proof. intros. now exists x, y. Qed.
Global Hint Immediate 序偶为之 : core.

Definition 序偶分离 := λ A P, {p ∊ A | 为序偶 p ∧ P (左 p) (右 p)}.

Notation "{ ' < a , b > ∊ A | P }" := (序偶分离 A (λ a b, P))
  (a binder, b binder, format "{ ' < a ,  b >  ∊  A  |  P }") : 集合域.

Lemma 序偶分离介入 : ∀ A (P : 集合 → 集合 → Prop) a b,
  <a, b> ∈ A → P a b → <a, b> ∈ {'<x, y> ∊ A | P x y}.
Proof. intros. apply 分离介入; firstorder. 化简. Qed.
Global Hint Resolve 序偶分离介入 : core.

Lemma 序偶分离除去1 : ∀ A P a b, <a, b> ∈ {'<x, y> ∊ A | P x y} → <a, b> ∈ A ∧ P a b.
Proof. intros. apply 分离除去 in H as [Hp [_ H]]. 化简. easy. Qed.

Lemma 序偶分离除去2 : ∀ A P, ∀p ∈ {'<x, y> ∊ A | P x y},
  ∃ a b, <a, b> ∈ A ∧ P a b ∧ p = <a, b>.
Proof.
  intros. apply 分离除去 in H as [Hp [[a [b Heq]] H]].
  subst. 化简. firstorder.
Qed.

Tactic Notation "序偶分离" "|-" ident(H) "for" simple_intropattern(a) simple_intropattern(b) simple_intropattern(Hp) "as" simple_intropattern(L) :=
  let Heq := fresh "Heq" in apply 序偶分离除去2 in H as [a [b [Hp [L Heq]]]]; rewrite Heq in *; clear Heq; 化简.
Tactic Notation "序偶分离" "|-" ident(H) "for" simple_intropattern(a) simple_intropattern(b) simple_intropattern(Hp) :=
  序偶分离|-H for ?a ?b ?Hp as H.
Tactic Notation "序偶分离" "|-" ident(H) "as" simple_intropattern(L) :=
  first [apply 序偶分离除去1 in H as L|序偶分离|-H for ?a ?b ?Hp as L].
Tactic Notation "序偶分离" "|-" ident(H) :=
  first [apply 序偶分离除去1 in H as [?Hp H]|序偶分离 |- H for ?a ?b ?Hp as H].
Tactic Notation "序偶分离" "-|" constr(a) constr(b) :=
  match goal with |- ?x ∈ _ => cut (x = <a, b>); [
    intros ?Heq; rewrite Heq; clear Heq; apply 序偶分离介入; auto|
  ] end.
Tactic Notation "序偶分离" "-|" := apply 序偶分离介入.