Require Import compcert.lib.Coqlib.
Require Import List. Import ListNotations.
Require Import VST.floyd.functional_base.
Require Import sha.HMAC256_functional_prog.

Definition HKDF_extract (salt IKM: list byte): list byte := HMAC256 IKM salt.

Function Ti (PRK info: list byte) n:=
  match n with
  O => nil
 |S m => let prev := Ti PRK info m in
         HMAC256 (prev ++ info ++ [Byte.repr (Z.of_nat n)]) PRK
  end.

Function T (PRK info: list byte) (n:nat):list byte :=
  match n with
  O => nil
| S m => (T PRK info m) ++ (Ti PRK info n)
  end.

Definition HKDF_expand (PRK info:list byte) (L:Z):list byte :=
  if zle L 0 then nil else
  let N := Z.of_nat SHA256.DigestLength in
  let k := if zeq (L mod N) 0 then Z.div L N else (Z.div L N) + 1 in
  sublist.sublist 0 L (T PRK info (Z.to_nat k)).

Definition HKDF salt IKM info L:=
  let PRK := HKDF_extract salt IKM in
  HKDF_expand PRK info L.

(************************************ Test vectors**************************)

Require Import Coq.Strings.String.
Definition decode_hex := sha.functional_prog.hexstring_to_bytelist.

Module HKDF_test_rfc5869_A1.
Definition IKM   := decode_hex "0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b".
Definition salt  := decode_hex "000102030405060708090a0b0c".
Definition info  := decode_hex "f0f1f2f3f4f5f6f7f8f9".
Definition L     := 42.
Definition PRK   := decode_hex "077709362c2e32df0ddc3f0dc47bba6390b6c73bb50f9c3122ec844ad7c2b3e5".
Definition OKM   := decode_hex "3cb25f25faacd57a90434f64d0362f2a2d2d0a90cf1a5a4c5db02d56ecc4c5bf34007208d5b887185865".

Goal map Byte.unsigned (HKDF_extract salt IKM) = map Byte.unsigned PRK.
  vm_compute; reflexivity. Qed.
Goal map Byte.unsigned (HKDF salt IKM info L) = map Byte.unsigned OKM.
    vm_compute. reflexivity. Qed. (*6secs*)
End HKDF_test_rfc5869_A1.

Module HKDF_test_rfc5869_A2.
Definition IKM   := decode_hex "000102030405060708090a0b0c0d0e0f101112131415161718191a1b1c1d1e1f202122232425262728292a2b2c2d2e2f303132333435363738393a3b3c3d3e3f404142434445464748494a4b4c4d4e4f".
Definition salt  := decode_hex "606162636465666768696a6b6c6d6e6f707172737475767778797a7b7c7d7e7f808182838485868788898a8b8c8d8e8f909192939495969798999a9b9c9d9e9fa0a1a2a3a4a5a6a7a8a9aaabacadaeaf".
Definition info  := decode_hex "b0b1b2b3b4b5b6b7b8b9babbbcbdbebfc0c1c2c3c4c5c6c7c8c9cacbcccdcecfd0d1d2d3d4d5d6d7d8d9dadbdcdddedfe0e1e2e3e4e5e6e7e8e9eaebecedeeeff0f1f2f3f4f5f6f7f8f9fafbfcfdfeff".
Definition L     := 82.

Definition PRK   := decode_hex "06a6b88c5853361a06104c9ceb35b45cef760014904671014a193f40c15fc244".
Definition OKM   := decode_hex "b11e398dc80327a1c8e7f78c596a49344f012eda2d4efad8a050cc4c19afa97c59045a99cac7827271cb41c65e590e09da3275600c2f09b8367793a9aca3db71cc30c58179ec3e87c14c01d5c1f3434f1d87".

Goal map Byte.unsigned (HKDF_extract salt IKM) = map Byte.unsigned PRK.
     vm_compute.  reflexivity. Qed.
Goal map Byte.unsigned (HKDF salt IKM info L) = map Byte.unsigned OKM.
     vm_compute. reflexivity. Qed.
End HKDF_test_rfc5869_A2.

Module HKDF_test_rfc5869_A3.
Definition IKM   := decode_hex "0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b".
Definition salt  := decode_hex "".
Definition info  := decode_hex "".
Definition L     := 42.

Definition PRK   := decode_hex "19ef24a32c717b167f33a91d6f648bdf96596776afdb6377ac434c1c293ccb04".
Definition OKM   := decode_hex "8da4e775a563c18f715f802a063c5a31b8a11f5c5ee1879ec3454e5f3c738d2d9d201395faa4b61a96c8".

Goal map Byte.unsigned (HKDF_extract salt IKM) = map Byte.unsigned PRK.
   vm_compute.  reflexivity. Qed.
Goal map Byte.unsigned (HKDF salt IKM info L) = map Byte.unsigned OKM.
   vm_compute. reflexivity. Qed.
End HKDF_test_rfc5869_A3.

(********************************Lemmas*************************************)

Require Import VST.msl.Coqlib2.
Require Import compcert.lib.Integers.
Require Import VST.zlist.sublist.
Require Import sha.hmac_common_lemmas.

Lemma Zlength_Ti PRK INFO n: Zlength (Ti PRK INFO n) = match n with O => 0 | S k => 32 end.
Proof. destruct n; simpl. apply Zlength_nil. apply HMAC_Zlength. Qed.

Lemma Zlength_T PRK INFO n: Zlength (T PRK INFO n) = Z.of_nat (32 *n).
Proof. induction n.
apply Zlength_nil.
replace (T PRK INFO (S n)) with ((T PRK INFO n) ++ (Ti PRK INFO (S n))) by reflexivity.
rewrite Zlength_app, IHn, Zlength_Ti.
do 2 rewrite Nat2Z.inj_mul. rewrite (Nat2Z.inj_succ n), Zmult_succ_r_reverse; trivial.
Qed.

Lemma Zlength_HKDF_expand x y z rest: 0 <= 32 * z -> 0 <= rest < 32 ->
      (Zlength (HKDF_expand x y (32*z+rest)) = 32*z+rest)%Z.
Proof. unfold HKDF_expand; intros.
destruct (zle (32*z+rest) 0).
+ rewrite Zlength_nil; lia.
+ rewrite Zlength_sublist; try lia. simpl.
  rewrite Zlength_T.
  destruct (zeq rest 0).
  - subst rest. rewrite Z.add_0_r in *.
    assert (X: (32 * z) mod 32 = 0) by (rewrite Z.mul_comm; apply Z_mod_mult).
    rewrite X, if_true; trivial.
    assert (Y: (32 * z) / 32 = z). rewrite Z.mul_comm; apply Z_div_mult_full; lia.
    rewrite Y, Nat2Z.inj_mul, Z2Nat.id; simpl; lia.
  - rewrite if_false.
    * replace (32 * z + rest) with (z * 32 + rest) by lia.
      rewrite Z_div_plus_full_l, Zdiv_small, Zplus_0_r; try lia.
      rewrite Nat2Z.inj_mul, Z2Nat.id. simpl. 2: lia.
      rewrite Z.mul_add_distr_l, Z.mul_1_r. lia.
    * intros N. replace (32 * z + rest) with (rest + z * 32) in N by lia.
      rewrite Z_mod_plus, Zmod_small in N; lia.
Qed.

Lemma sublist_HKDF_expand1 prk info i r (I: 0 <= i) (R:0<=r<32):
    sublist 0 (32 * i) (HKDF_expand prk info (32*i)) =
    sublist 0 (32 * i) (HKDF_expand prk info (32*i+r)).
Proof. unfold HKDF_expand.
destruct (zle (32 * i) 0); simpl.
+ assert (i=0) by lia. subst i. simpl. rewrite Z.add_0_l.
  destruct (zle r 0); trivial.
+ destruct (zle (32 * i + r) 0); try lia.
    rewrite (Zmod_unique _ _ i 0); try lia. simpl.
    rewrite (Zdiv_unique _ _ i 0); try lia.
    rewrite (Zmod_unique _ _ i r); try lia.
    rewrite (Zdiv_unique _ _ i r); try lia.
  rewrite 2 sublist_sublist; try lia. simpl. rewrite Z.add_0_r.
  destruct (zeq r 0); simpl; trivial.
  replace (Z.to_nat (i+1)) with (S (Z.to_nat i)).
    2: rewrite Z.add_comm, Z2Nat.inj_add; try reflexivity; try lia.
  simpl. rewrite sublist_app1; trivial. lia.
      rewrite Zlength_T, Nat2Z.inj_mul, Z2Nat.id; simpl; lia.
Qed.

Lemma sublist_HKDF_expand2 prk info i (I: 0 <= i) :
    sublist 0 (32 * i) (HKDF_expand prk info (32*i)) =
    sublist 0 (32 * i) (HKDF_expand prk info (32*(i+1))).
Proof. unfold HKDF_expand.
destruct (zle (32 * i) 0); simpl.
+ assert (i=0) by lia. subst i; simpl. reflexivity.
+ destruct (zle (32 * (i + 1)) 0); try lia.
    rewrite (Zmod_unique _ _ i 0); try lia. simpl.
    rewrite (Zdiv_unique _ _ i 0); try lia.
    rewrite (Zmod_unique _ _ (i+1) 0); try lia.
    rewrite (Zdiv_unique _ _ (i+1) 0); try lia. simpl.
  rewrite 2 sublist_sublist; try lia. simpl. rewrite Z.add_0_r.
  replace (Z.to_nat (i+1)) with (S (Z.to_nat i)).
    2: rewrite Z.add_comm, Z2Nat.inj_add; try reflexivity; try lia.
  simpl. rewrite sublist_app1; trivial. lia.
  rewrite Zlength_T, Nat2Z.inj_mul, Z2Nat.id; simpl; lia.
Qed.

Lemma sublist_HKDF_expand3 prk info i rest (REST : 0 < rest < 32)
      (OLEN : 0 <= 32 * i + rest):
  sublist 0 (32 * i + rest) (HKDF_expand prk info (32 * i + 32)) =
  HKDF_expand prk info (32 * i + rest).
Proof.
            unfold HKDF_expand. simpl. destruct (zle (32 * i + 32) 0); try lia.
            destruct (zle (32 * i + rest) 0); try lia.
            rewrite sublist_sublist; try lia. rewrite 2 Z.add_0_r.
            erewrite (Zmod_unique _ _(i+1) 0); try lia. simpl.
            erewrite (Zdiv_unique _ _(i+1) 0); try lia.
            erewrite (Zmod_unique _ _ i rest); try lia. rewrite if_false; try lia.
            erewrite (Zdiv_unique _ _ i rest); try lia; trivial.
Qed.


From mathcomp Require Import all_ssreflect finmap.

Set Implicit Arguments.
Unset Strict Implicit.

(******************************************************************************)
(*                                                                            *)
(*   Extra theorems and definitions                                           *)
(*                                                                            *)
(******************************************************************************)

(******************************************************************************)
(*                                                                            *)
(*   Extra theorems about lists                                               *)
(*                                                                            *)
(******************************************************************************)

Lemma rcons_injl (A : Type) (a: seq A) : injective (rcons a).
Proof. by elim: a => /= [s1 s2 /= [] | b l IH s1 s2 [] /IH]. Qed.

Lemma rcons_injr (A : Type) (a: A) : injective (rcons ^~a).
Proof.
elim => [ [|b [|c]] //= | b s1 IH /= [/= [] -> |c s2 [] -> /IH-> //]].
by case: (s1) => // [] [].
Qed.

Lemma cat_injl (A : Type) (a: seq A) : injective (cat a).
Proof. by elim: a => // b l IH s1 s2 /= [] /IH. Qed.

Lemma cat_injr (A : Type) (a: seq A) : injective (cat ^~a).
Proof.
elim: a => [s1 s2 |b l IH s1 s2]; first by rewrite !cats0.
by rewrite -!cat_rcons => /IH; apply: rcons_injr.
Qed.

Lemma in_split (A : eqType) (a : A)  l :
  a \in l -> exists l1, exists l2, l = l1 ++ a :: l2.
Proof.
elim: l => //= b l IH; rewrite inE => /orP[/eqP<-|aIl].
  by exists [::]; exists l.
case: (IH aIl) => l1 [l2 lE].
by exists (b :: l1); exists l2; rewrite /= lE.
Qed.

Lemma split_first (A : eqType) (l : seq A) (P : pred A) :
  ~~ all [predC P] l -> {bl1l2 : (A * seq A * seq A) |
    [/\ all [predC P] bl1l2.1.2, P bl1l2.1.1 &
             l = bl1l2.1.2 ++ bl1l2.1.1 :: bl1l2.2]}.
Proof.
elim: l => //= b l IH.
rewrite negb_and negbK; case: (boolP (b \in P)) =>
      [bIP _| bNIP /= /IH [[[c l1] l2] [H1 H2 ->]]].
  by exists (b, [::], l); split.
by exists (c, b :: l1, l2); split; rewrite /= ?bNIP.
Qed.

Lemma split_last (A : eqType) (l : seq A) (P : pred A) :
  ~~ all [predC P] l  ->
  {bl1l2 | [/\  P bl1l2.1.1, all [predC  P] bl1l2.2 &
                l = bl1l2.1.2 ++ bl1l2.1.1 :: bl1l2.2]}.
Proof.
move=> lA.
case: (@split_first _ (rev l) P); first by rewrite all_rev.
move=> [[b l1] l2] [H1 H2 H3].
exists (b, rev l2, rev l1); split => //; first by rewrite all_rev.
by rewrite -{1}[l]revK H3 rev_cat /= rev_cons cat_rcons.
Qed.

Lemma split_head (A : eqType) (a b : A) l1 l2 l3 l4 :
  l1 ++ a :: l2 = l3 ++ b :: l4 ->
  [\/ [/\ l1 = l3, a = b & l2 = l4],
      exists l5, l3 = l1 ++ a :: l5 |
      exists l5, l1 = l3 ++ b :: l5].
Proof.
elim: l1 l3 => /= [[[<- <-]|c l3 [<- ->]] /= | c l1 IH [[<- <-]|d l3 /= [<-]]].
- by apply: Or31.
- by apply: Or32; exists l3.
- by apply: Or33; exists l1.
move=> /IH[[<- <- <-]|[l5 ->]|].
- by apply: Or31.
- by apply: Or32; exists l5.
by case=> l5 ->; apply: Or33; exists l5.
Qed.

Lemma split_tail (A : eqType) (a b : A) l1 l2 l3 l4 :
  l1 ++ a :: l2 = l3 ++ b :: l4 ->
  [\/ [/\ l1 = l3, a = b & l2 = l4],
      exists l5, l4 = l5 ++ a :: l2 |
      exists l5, l2 = l5 ++ b :: l4].
Proof.
elim/last_ind : l2 l4 => [l4|l2 c IH l4].
  case: (lastP l4) => /= [|l5 c].
    rewrite !cats1 => /rcons_inj[<- <-].
    by apply: Or31.
  rewrite cats1 -rcons_cons -rcons_cat => /rcons_inj[-> <-].
  by apply: Or32; exists l5; rewrite cats1.
case: (lastP l4) => /= [|l5 d].
  rewrite cats1 -rcons_cons -rcons_cat => /rcons_inj[<- ->].
  by apply: Or33; exists l2; rewrite cats1.
rewrite -!rcons_cons -!rcons_cat =>
   /rcons_inj[/IH [[<- <- <-]|[l6 ->]|[l6 ->]]] <-.
- by apply: Or31.
- by apply: Or32; exists l6; rewrite -rcons_cat.
by apply: Or33; exists l6; rewrite -rcons_cat.
Qed.

(******************************************************************************)
(* We develop a twisted version of split that fills 'I_{m + n} with           *)
(* first the element of 'I_n (x -> x) then the element of m (x -> x + n)      *)
(* This is mostly motivated to naturally get an element of 'I_n from 'I_n.+1  *)
(* by removing max_ord                                                        *)
(******************************************************************************)

Lemma tlshift_subproof m n (i : 'I_m) : i + n < m + n.
Proof. by rewrite ltn_add2r. Qed.
Lemma trshift_subproof m n (i : 'I_n) : i < m + n.
Proof. by apply: leq_trans (valP i) _; apply: leq_addl. Qed.

Definition tlshift m n (i : 'I_m) := Ordinal (tlshift_subproof n i).
Definition trshift m n (i : 'I_n) := Ordinal (trshift_subproof m i).

Lemma tlshift_inj m n : injective (@tlshift m n).
Proof. by move=> ? ? /(f_equal val) /addIn /val_inj. Qed.

Lemma trshift_inj m n : injective (@trshift m n).
Proof. by move=> ? ? /(f_equal val) /= /val_inj. Qed.

Lemma trshift_lift n (i : 'I_ n) : trshift 1 i = lift ord_max i.
Proof. by apply/val_eqP; rewrite /= /bump leqNgt ltn_ord. Qed.

Lemma tsplit_subproof m n (i : 'I_(m + n)) : i >= n -> i - n < m.
Proof. by move/subSn <-; rewrite leq_subLR [n + m]addnC. Qed.

Definition tsplit {m n} (i : 'I_(m + n)) : 'I_m + 'I_n :=
  match ltnP (i) n with
  | LtnNotGeq lt_i_n =>  inr _ (Ordinal lt_i_n)
  | GeqNotLtn ge_i_n =>  inl _ (Ordinal (tsplit_subproof ge_i_n))
  end.

Variant tsplit_spec m n (i : 'I_(m + n)) : 'I_m + 'I_n -> bool -> Type :=
  | TSplitLo (j : 'I_n) of i = j :> nat : tsplit_spec i (inr _ j) true
  | TSplitHi (k : 'I_m) of i = k + n :> nat : tsplit_spec i (inl _ k) false.

Lemma tsplitP m n (i : 'I_(m + n)) : tsplit_spec i (tsplit i) (i < n).
Proof.
set lt_i_n := i < n; rewrite /tsplit.
by case: {-}_ lt_i_n / ltnP; [left |right; rewrite subnK].
Qed.

Definition tunsplit {m n} (jk : 'I_m + 'I_n) :=
  match jk with inl j => tlshift n j | inr k => trshift m k end.

Lemma ltn_tunsplit m n (jk : 'I_m + 'I_n) : (n <= tunsplit jk) = jk.
Proof.
by case: jk => [j|k]; rewrite /= ?ltn_ord ?leq_addl // leqNgt ltn_ord.
Qed.

Lemma tsplitK {m n} : cancel (@tsplit m n) tunsplit.
Proof. by move=> i; apply: val_inj; case: tsplitP. Qed.

Lemma tunsplitK {m n} : cancel (@tunsplit m n) tsplit.
Proof.
move=> jk; have:= ltn_tunsplit jk; rewrite leqNgt.
by do [case: tsplitP; case: jk => //= i j] => [|/addIn] => /ord_inj->.
Qed.

(******************************************************************************)
(*                                                                            *)
(*   Extra theorems about fset                                                *)
(*                                                                            *)
(******************************************************************************)

Open Scope fset_scope.

Definition sint a b : {fset nat} :=
   [fset @nat_of_ord _ i | i in 'I_b & a <= i].

Lemma mem_sint a b i : i \in sint a b = (a <= i < b).
Proof.
apply/imfsetP/idP => [[j /= aLj ->]|/andP[aLi iLb]].
  by rewrite ltn_ord andbT.
by exists (Ordinal iLb).
Qed.

Lemma sint_sub a b c : a <= c ->
   [fset i in  (sint a b) | c <= i] = sint c b.
Proof.
move=> aLc.
apply/fsetP => i.
rewrite mem_sint.
apply/imfsetP/idP => [[j /=]|/andP[cLi iLb]].
  rewrite inE mem_sint => /andP[/andP[aLj jLb] cLj] ->.
  by rewrite cLj.
by exists i; rewrite //= inE mem_sint cLi iLb (leq_trans aLc).
Qed.

Lemma sintSl a b : sint a.+1 b = sint a b `\ a.
Proof.
apply/fsetP => /= i; rewrite !inE !mem_sint.
by do 2 case: ltngtP.
Qed.

Lemma sintSr a b : sint a b.+1 `\ b = sint a b.
Proof.
apply/fsetP => /= i; rewrite !inE !mem_sint ltnS.
by do 2 case: ltngtP.
Qed.

Lemma sint_split a b : sint a b = sint 0 b `\` sint 0 a.
Proof.
by apply/fsetP => /= i; rewrite !inE !mem_sint /= -leqNgt.
Qed.

Lemma card_sint a b : #|`sint a b| = (b - a).
Proof.
elim: b => [|b IH].
  apply/eqP; rewrite cardfs_eq0; apply/eqP/fsetP=> i.
  by rewrite mem_sint andbF inE.
have [aLb|bLa] := leqP a b; last first.
  rewrite (_ : _ - _ =  0); last first.
    by apply/eqP; rewrite subn_eq0.
  apply/eqP; rewrite cardfs_eq0; apply/eqP/fsetP=> i; rewrite mem_sint inE ltnS.
  by apply/idP => /andP[H1 /(leq_trans H1)]; rewrite leqNgt bLa.
rewrite (cardfsD1 b) (_ : _ \in _); last by rewrite mem_sint aLb /=.
by rewrite sintSr IH subSn.
Qed.

Notation "`[ n ]" := (sint 0 n) (format "`[ n ]").

Lemma sint0_set0 : `[0] = fset0.
Proof.  by apply/fsetP=> i; rewrite mem_sint inE; case: ltngtP. Qed.

Definition s2f n (s : {set 'I_n}) := [fset nat_of_ord i | i in s].

Lemma mem_s2f n (s : {set 'I_n}) (i : 'I_n) : (i : nat) \in s2f s = (i \in s).
Proof.
apply/imfsetP/idP => /= [[j jIs iEj]|iIs]; last by exists i.
by rewrite (_ : i = j) //; apply: val_inj.
Qed.

Lemma s2f_set0 n : s2f (set0 : {set 'I_n}) = fset0.
Proof.
apply/fsetP => i; rewrite inE.
by apply/idP => /imfsetP[j /=]; rewrite inE.
Qed.

Lemma s2f_setT n : s2f (setT : {set 'I_n}) = sint 0 n.
Proof.
apply/fsetP => i; rewrite mem_sint /=.
apply/imfsetP/idP => /= [[j _ -> //]| iLn].
by exists (Ordinal iLn).
Qed.

Lemma s2fD n (s1 s2 : {set 'I_n}) : s2f (s1 :\: s2)  = s2f s1 `\` s2f s2.
Proof.
apply/fsetP => j; rewrite !inE.
apply/imfsetP/andP => /= [[k]|[jDi /imfsetP[/= k kIs jEk]]].
  by rewrite !inE -!mem_s2f => /andP[kDi kIs] ->.
by exists k => //; rewrite !inE kIs -mem_s2f -jEk jDi.
Qed.

Lemma s2fU n (s1 s2 : {set 'I_n}) : s2f (s1 :|: s2)  = s2f s1 `|` s2f s2.
Proof.
apply/fsetP => j; rewrite !inE.
apply/imfsetP/orP => /= [[k]|[] /imfsetP[/= k]].
- by rewrite !inE -!mem_s2f => /orP[] kIs ->; [left|right].
- by move => kIs1 ->; exists k; rewrite // inE kIs1.
by move => kIs2 ->; exists k; rewrite // inE kIs2 orbT.
Qed.

Lemma s2fI n (s1 s2 : {set 'I_n}) : s2f (s1 :&: s2)  = s2f s1 `&` s2f s2.
Proof.
apply/fsetP => j; rewrite !inE.
apply/imfsetP/andP => /= [[k]|[jDi /imfsetP[/= k kIs jEk]]].
  by rewrite !inE -!mem_s2f => /andP[kDi kIs] ->.
by exists k => //; rewrite !inE kIs -mem_s2f -jEk jDi.
Qed.

Lemma s2f1 n (i : 'I_n) : s2f [set i] = [fset (nat_of_ord i)].
Proof.
apply/fsetP => j; rewrite !inE.
apply/imfsetP/eqP => /= [[k]|->]; first by rewrite inE => /eqP ->.
by exists i; rewrite ?inE.
Qed.

Lemma s2f_pred n (s : {set 'I_n}) (P : pred nat) :
   s2f [set i in s | P i] = [fset i in (s2f s) | P i].
Proof.
apply/fsetP=> i; rewrite !inE /=.
apply/imfsetP/andP => /= [[j]|].
  rewrite !inE => /andP[jIs jP] ->; split => //.
  by apply/imfsetP; exists j.
move=> [/imfsetP[/= j jIs ->] jP]; exists j => //.
by rewrite inE jIs.
Qed.

Lemma s2fD1 n (s : {set 'I_n}) i : s2f (s :\ i) = s2f s `\ (nat_of_ord i).
Proof. by rewrite s2fD s2f1. Qed.

Lemma card_s2f n (s : {set 'I_n}) : #|` s2f s| = #|s|.
Proof.
have [m sLm] := ubnP #|s|; elim: m => // m IH s sLm in s sLm *.
 case: (set_0Vmem s) => [->|[i iIs]]; first by rewrite s2f_set0 cards0.
rewrite (cardsD1 i) iIs /= -IH //; last first.
  by move: sLm; rewrite (cardsD1 i) iIs.
rewrite [LHS](cardfsD1 (nat_of_ord i)) (_ : _ \in _); last first.
  by rewrite mem_s2f.
by rewrite s2fD1.
Qed.

(* initial section of an ordinal *)
Definition isO n t := [set i | (i : 'I_n) < t].

Lemma isOE n t : t <= n -> s2f (isO n t) = sint 0 t.
Proof.
move=> tLn.
apply/fsetP => i; rewrite mem_sint.
apply/imfsetP/idP => /= [[j]|iLt]; first by rewrite inE => jLt ->.
have iLn : i < n by apply: leq_trans tLn.
by exists (Ordinal iLn); rewrite // inE.
Qed.

Lemma mem_isO n t i : (i \in isO n t) = (i < t).
Proof. by rewrite inE. Qed.

Lemma isOE_ge n t : n <= t -> isO n t = setT.
Proof.
by move=> nLt; apply/setP => í; rewrite !inE (leq_trans _ nLt).
Qed.

Lemma isOE_le n t : t < n.+1 -> isO n.+1 t = [set inord i | i : 'I_t].
Proof.
move=> tLn; apply/setP=> i; rewrite !inE.
apply/idP/imsetP => [iLt| [j _ ->]].
  by exists (Ordinal iLt); rewrite //=; apply/val_eqP; rewrite /= inordK.
by rewrite inordK // (leq_trans _ tLn) // ltnS // ltnW.
Qed.

Lemma card_isO n t : #|isO n t| = minn n t.
Proof.
apply/sym_equal.
case: (leqP n t) => [nLt|tLn].
  by rewrite isOE_ge //= cardsT card_ord.
case: n tLn => // n tLn.
rewrite isOE_le // card_imset // => [|i j /val_eqP/eqP /=].
  by rewrite card_ord.
by rewrite !inordK ?(leq_trans _ tLn) ?ltnS 1?ltnW // => /eqP/val_eqP.
Qed.

Lemma s2fD_isO n (s : {set 'I_n}) t : s2f (s :\: isO n t)  = s2f s `\` sint 0 t.
Proof.
apply/fsetP => j; rewrite !inE.
apply/imfsetP/andP => /= [[k]|[jDi /imfsetP[/= k kIs jEk]]].
  by rewrite !inE -!mem_s2f mem_sint /= => /andP[kDi kIs] ->.
move: jDi; rewrite mem_sint /= -leqNgt => jDi.
by exists k; rewrite // !inE -leqNgt kIs -jEk jDi.
Qed.

(******************************************************************************)
(*                                                                            *)
(*              Specific theorems for shanoi                                  *)
(*                                                                            *)
(******************************************************************************)

Open Scope nat_scope.

Lemma codom_subC (A : finType) (B : finType) (f : {ffun A -> B})
          (p1 p2 : B) :
  (codom f \subset [:: p1; p2]) = (codom f \subset [:: p2; p1]).
Proof.
by apply/subsetP/subsetP; move => sB i /sB; rewrite !inE orbC.
Qed.

Lemma inord_eq0 n k : k = 0 -> inord k = ord0 :> 'I_n.+1.
Proof. by move=> -> /=; apply/val_eqP; rewrite /= inordK. Qed.

Lemma mod3_0 a : (3 * a) %% 3 = 0.
Proof. by rewrite modnMr. Qed.

Lemma mod3_1 a : (3 * a).+1 %% 3 = 1.
Proof. by rewrite mulnC -addn1 modnMDl. Qed.

Lemma mod3_2 a : (3 * a).+2 %% 3 = 2.
Proof. by rewrite mulnC -addn2 modnMDl. Qed.

Definition mod3E := (mod3_0, mod3_1, mod3_2).

Lemma div3_0 a : (3 * a) %/ 3 = a.
Proof. by rewrite mulKn. Qed.

Lemma div3_1 a : (3 * a).+1 %/ 3 = a.
Proof. by rewrite mulnC -addn1 divnMDl // divn_small // addn0. Qed.

Lemma div3_2 a : (3 * a).+2 %/ 3 = a.
Proof. by rewrite mulnC -addn2 divnMDl // divn_small // addn0. Qed.

Definition div3E := (div3_0, div3_1, div3_2).

Lemma sum3E n (f : nat -> nat) :
  \sum_(i < 3 * n) f i =
  \sum_(i < n) (f (3 * i) + f (3 * i).+1 + f (3 * i).+2).
Proof.
elim: n => [|n IH]; first by rewrite !big_ord0.
by rewrite mulnS !big_ord_recr /= IH !addnA.
Qed.

Lemma Ival_eq n (x y : 'I_n) : (x == y) = (val x == val y).
Proof. by apply/eqP/val_eqP. Qed.

Lemma oddS n : odd n.+1 = ~~ odd n.
Proof. by []. Qed.

Lemma even_halfMl k m :
  ~~ odd m -> (k * m)./2 = k * m./2.
Proof.
move=> mE.
have := odd_double_half m; rewrite (negPf mE) add0n => {1}<-.
by rewrite -doubleMr doubleK.
Qed.

Lemma even_halfMr k m :
  ~~ odd m -> (m * k)./2 = m./2 * k.
Proof.
move=> mE.
have := odd_double_half m; rewrite (negPf mE) add0n => {1}<-.
by rewrite -doubleMl doubleK.
Qed.

Lemma even_halfD m n :
  ~~ odd m -> ~~ odd n -> (m + n)./2 = (m./2 + n./2).
Proof.
move=> mE nE.
have := odd_double_half m; rewrite (negPf mE) add0n => {1}<-.
have := odd_double_half n; rewrite (negPf nE) add0n => {1}<-.
by rewrite -doubleD doubleK.
Qed.

Lemma even_halfB m n :
  ~~ odd m -> ~~ odd n -> (m - n)./2 = m./2 - n./2.
Proof.
move=> mE nE.
have := odd_double_half m; rewrite (negPf mE) add0n => {1}<-.
have := odd_double_half n; rewrite (negPf nE) add0n => {1}<-.
by rewrite -doubleB doubleK.
Qed.

Lemma leq_pred2 m n : m <= n -> m.-1 <= n.-1.
Proof. by case: m; case: n => //=. Qed.

Lemma subn_minr : left_distributive subn minn.
Proof.
move=> m n p; rewrite /minn; case: leqP => [nLm|mLn].
  by rewrite ltnNge leq_sub2r.
have [nLp|pLn] := leqP n p; last by rewrite ltn_sub2r.
apply/eqP; move: (nLp); rewrite -subn_eq0 => /eqP->.
by rewrite ltnNge //= subn_eq0 (leq_trans (ltnW mLn)).
Qed.

Lemma subn_maxr : left_distributive subn maxn.
Proof.
move=> m n p; rewrite /maxn; case: leqP => [nLm|mLn].
  by rewrite ltnNge leq_sub2r.
have [nLp|pLn] := leqP n p; last by rewrite ltn_sub2r.
apply/eqP; move: (nLp); rewrite -subn_eq0 => /eqP->.
by rewrite ltnNge //= eq_sym subn_eq0 (leq_trans (ltnW mLn)).
Qed.

Lemma leq_minn2r m n p : m <= n -> minn m p <= minn n p.
Proof.
move=> mLn; rewrite /minn.
case: leqP => pLm; case: leqP => //.
  by rewrite ltnNge (leq_trans pLm).
by move=> _; rewrite ltnW.
Qed.

Lemma leq_minn2l m n p : m <= n -> minn p m <= minn p n.
Proof.
move=> mLn; rewrite /minn.
case: leqP => pLm; case: leqP => //.
by move=> _; rewrite (leq_trans (ltnW pLm)).
Qed.

(******************************************************************************)
(* Definiion of discrete convex and concave version                           *)
(*  it contains just what is needed for shanoi4                               *)
(******************************************************************************)

Section Convex.

Definition increasing (f : nat -> nat) := forall n, f n <= f n.+1.

Definition decreasing (f : nat -> nat) := forall n, f n.+1 <= f n.

Lemma increasing_ext f1 f2 : f1 =1 f2 -> increasing f1 -> increasing f2.
Proof. by move=> fE fI i; rewrite -!fE. Qed.

Lemma increasingE f m n : increasing f -> m <= n -> f m <= f n.
Proof.
move=> fI mLn; rewrite -(subnK mLn).
elim: (_ - _) => //= d fL.
by apply: leq_trans (fI (d + m)).
Qed.

Lemma decreasingE f m n : decreasing f -> m <= n -> f n <= f m.
Proof.
move=> fI mLn; rewrite -(subnK mLn).
elim: (_ - _) => //= d fL.
by apply: leq_trans (fI _) fL.
Qed.

Definition delta (f : nat -> nat) n := f n.+1 - f n.

Lemma delta_ext f1 f2 : f1 =1 f2 -> delta f1 =1 delta f2.
Proof. by move=> fE i; rewrite /delta !fE. Qed.

Definition fnorm (f : nat -> nat) n := f n - f 0.

Lemma increasing_fnorm f : increasing f -> increasing (fnorm f).
Proof. by move=> fI n; rewrite leq_sub2r. Qed.

Lemma delta_fnorm f n : increasing f -> delta (fnorm f) n = delta f n.
Proof.
by move=> fI; rewrite /delta /fnorm -subnDA addnC subnK // increasingE.
Qed.

Lemma sum_delta f n :
increasing f -> fnorm f n = \sum_(i < n) delta (fnorm f) i.
Proof.
move=> iF.
elim: n => [|n IH]; first by rewrite [LHS]subnn big_ord0.
by rewrite big_ord_recr /= -IH addnC subnK // increasing_fnorm.
Qed.

(* we restrict this to increasing function because of the behavior -*)
Definition convex f :=
  increasing f /\ increasing (delta f).

(* we restrict this to increasing function because of the behavior -*)
Definition concave f :=
  increasing f /\ decreasing (delta f).

Lemma concaveE f :
  increasing f -> (forall i, f i + f i.+2 <= (f i.+1).*2) -> concave f.
Proof.
move=> fI fH; split => // i.
rewrite /delta.
rewrite -(leq_add2r (f i.+1 + f i)) addnA subnK // addnCA subnK //.
by rewrite addnn addnC.
Qed.

Lemma concaveEk f i k :
  concave f -> k <= i -> f (i - k) + f (i + k) <= (f i).*2.
Proof.
move=> [fI dfD].
elim: k => /= [kLi|k IH kLi]; first by rewrite subn0 addn0 addnn.
have H : i - k.+1 <= i + k.
  by apply: leq_trans (leq_subr _ _) (leq_addr _ _).
have fk1Lfk : f (i - k.+1) <= f (i - k).
  by apply/(increasingE fI)/leq_sub2l.
have := leq_add (decreasingE dfD H) (IH (ltnW kLi)).
rewrite /delta [f (i - k) + _]addnC addnA subnK ?fU // addnC.
rewrite -subSn // subSS addnBAC // leq_subRL.
  by rewrite addnCA leq_add2l addnS.
by apply: leq_trans fk1Lfk (leq_addr _ _).
Qed.

Lemma concaveEk1 (f : nat -> nat) (i k1 k2 : nat) :
  concave f -> f (i + k1 + k2) + f i <= f (i + k2) + f (i + k1).
Proof.
move=> fC; have [fI dfD] := fC.
elim: k2 k1 i => [k1 i|k2 IHH k1 i]; first by rewrite !addn0 addnC.
rewrite !addnS -(subnK (fI _)) -[X in _ <= X + _](subnK (fI _)).
rewrite -addnA -[X in _ <= X]addnA leq_add //.
by apply: (decreasingE dfD); rewrite addnAC leq_addr.
Qed.

Lemma convexE f :
  increasing f -> (forall i, (f i.+1).*2 <= f i + f i.+2) -> convex f.
Proof.
move=> fI fH; split => // i.
rewrite /delta.
rewrite -(leq_add2r (f i.+1 + f i)) [_ + f i]addnC addnA subnK //.
by rewrite addnn [f i + _]addnC addnA subnK // addnC.
Qed.

Lemma convexEk f i k :
  convex f -> k <= i -> (f i).*2 <= f (i - k) + f (i + k).
Proof.
move=> [fI dfI].
elim: k => /= [kLi|k IH kLi]; first by rewrite subn0 addn0 addnn.
have H : i - k.+1 <= i + k.
  by apply: leq_trans (leq_subr _ _) (leq_addr _ _).
have fk1Lfk : f (i - k.+1) <= f (i - k).
  by apply/(increasingE fI)/leq_sub2l.
have := leq_add (increasingE dfI H) (IH (ltnW kLi)).
rewrite /delta [f (i - k) + _]addnC addnA subnK ?fU // addnC.
by rewrite -subSn // subSS addnS addnBA // leq_subLR addnA leq_add2r.
Qed.

(* Ad-hoc bigmin operator *)

Fixpoint bigmin f n :=
 if n is n1.+1 then minn (f n) (bigmin f n1)
 else f 0.

Notation "\min_ ( i <= n ) F" := (bigmin (fun i => F) n)
 (at level 41, F at level 41, i, n at level 50,
  format "\min_ ( i  <=  n )  F").

Lemma bigmin_constD  f n k :
 \min_(i <= n) (f i + k) =  (\min_(i <= n) f i) + k.
Proof. by elim: n => //=  n ->; rewrite addn_minl. Qed.

Lemma bigmin_constB  f n k :
 \min_(i <= n) (f i - k) =  (\min_(i <= n) f i) - k.
Proof. by elim: n => //=  n ->; rewrite subn_minr. Qed.

Lemma eq_bigmin f n : {i0 : 'I_n.+1 | \min_(i <= n) f i = f i0}.
Proof.
elim: n => /= [|n [i ->]]; first by exists ord0.
rewrite /minn; case: leqP => H.
  by exists (inord i); rewrite inordK // (leq_trans (ltn_ord i)).
by exists ord_max.
Qed.

Lemma bigmin_leqP f n m :
  reflect (forall i, i <= n -> m <= f i)
          (m <= \min_(i <= n) f i).
Proof.
elim: n => /= [|n IH].
  by apply: (iffP idP) => [mLf0 [|i] //|->].
apply: (iffP idP) => [|H].
  rewrite leq_min => /andP[mLf mLmin] i.
  case: ltngtP => // [iLn _|-> _ //].
  by rewrite ltnS in iLn; move: i iLn; apply/IH.
rewrite leq_min H //=.
by apply/IH => i iLn; rewrite H // (leq_trans iLn).
Qed.

Lemma bigmin_inf f n i0 m :
  i0 <= n -> f i0 <= m -> \min_(i <= n) f i <= m.
Proof.
move=> i0Ln fi0Lm; apply: leq_trans fi0Lm.
elim: n i0Ln => /= [|n IH]; first by case: i0.
by case: ltngtP => // [i0Ln _| -> _]; rewrite geq_min ?leqnn ?IH ?orbT.
Qed.

Lemma bigmin_fnorm f n : \min_(i <= n) fnorm f i = fnorm (bigmin f) n.
Proof. by elim: n => //= n ->; rewrite -subn_minr. Qed.

Lemma bigmin_ext f1 f2 n :
  (forall i, i <= n -> f1 i = f2 i) -> \min_(i <= n) f1 i = \min_(i <= n) f2 i.
Proof.
elim: n => /= [->//|n IH H].
by rewrite H // IH // => i iH; rewrite H // (leq_trans iH).
Qed.

Lemma bigminMr  f n k :
 \min_(i <= n) (f i * k) =  (\min_(i <= n) f i) * k.
Proof. by elim: n => //= n ->; rewrite  minnMl. Qed.

(* Convolution *)

Definition conv (f g : nat -> nat) n :=
  \min_(i <= n) (f i + g (n - i)).

Lemma conv0 f g : conv f g 0 = f 0 + g 0.
Proof. by []. Qed.

Lemma conv1 f g :
  conv f g 1 = minn (f 1 + g 0) (f 0 + g 1).
Proof. by []. Qed.

Lemma conv_fnorm f g :
  increasing f -> increasing g ->
  conv (fnorm f) (fnorm g) =1 fnorm (conv f g).
Proof.
move=> fI gI i.
rewrite /fnorm /conv /= -bigmin_constB subnn.
apply: bigmin_ext => j.
by rewrite addnBA ?increasingE // addnBAC ?increasingE // subnDA.
Qed.

Lemma conv_ext f1 g1 f2 g2 : f1 =1 f2 -> g1 =1 g2 -> conv f1 g1 =1 conv f2 g2.
Proof. by move=> fE gE i; apply: bigmin_ext => j; rewrite fE gE. Qed.

Lemma convC f g : conv f g =1 conv g f.
Proof.
move=> n; apply/eqP; rewrite /conv eqn_leq; apply/andP; split.
  apply/bigmin_leqP => i iLn.
  rewrite -{1}(subKn iLn) addnC.
  by apply: bigmin_inf (leq_subr _ _) (leqnn _).
apply/bigmin_leqP => i iLn.
rewrite -{1}(subKn iLn) addnC.
by apply: bigmin_inf (leq_subr _ _) (leqnn _).
Qed.

Lemma increasing_conv f g :
  increasing f -> increasing g -> increasing (conv f g).
Proof.
move=> fI gI i.
apply/bigmin_leqP => j.
case: ltngtP => // [jLi | ->] _.
  by apply: bigmin_inf (_ : j <= i) _; rewrite // leq_add2l subSn.
rewrite subnn.
by apply: bigmin_inf (leqnn i) _; rewrite subnn leq_add2r.
Qed.

(* merging increasing functions *)

Fixpoint fmerge_aux (f g : nat -> nat) i j n :=
 if n is n1.+1 then
   if f i < g j then fmerge_aux f g i.+1 j n1
   else fmerge_aux f g i j.+1 n1
 else minn (f i) (g j).

Definition fmerge f g n := fmerge_aux f g 0 0 n.

Lemma fmerge_aux_ext f1 f2 g1 g2 i j : f1 =1 f2 -> g1 =1 g2 ->
  fmerge_aux f1 g1 i j =1 fmerge_aux f2 g2 i j.
Proof.
move=> fE gE n; elim: n i j => /= [i1 j1|n IH i j]; first by rewrite fE gE.
by rewrite !(fE, gE, IH).
Qed.

Lemma fmerge_ext f1 f2 g1 g2 : f1 =1 f2 -> g1 =1 g2 ->
  fmerge f1 g1 =1 fmerge f2 g2.
Proof. by move=> fE gE n; apply: fmerge_aux_ext. Qed.

Lemma fmerge_aux_correct f g i j n :
  increasing f -> increasing g ->
  (forall k, k <= n ->
     minn (f (i + k)) (g (j + (n - k))) <=
     fmerge_aux f g i j n).
Proof.
move=> fI gI.
elim: n i j => /= [i j [|] // _|n IH i j k kLn].
  by rewrite !addn0.
case: leqP => [gLf|fLg].
  move: kLn; rewrite leq_eqVlt => /orP[/eqP->|kLn].
    rewrite subnn addn0 (minn_idPr _); last first.
      by rewrite (leq_trans gLf) // increasingE // leq_addr.
    apply: leq_trans (IH _ _ _ (leqnn _)).
    rewrite subnn addn0 leq_min increasingE // andbT (leq_trans gLf) //.
    by rewrite increasingE // leq_addr.
  by rewrite subSn // -addSnnS IH.
case: k kLn => [_ | k kLn].
  rewrite addn0 subn0 (minn_idPl _); last first.
    by rewrite (leq_trans (ltnW fLg)) // increasingE // leq_addr.
  apply: leq_trans (IH i.+1 j 0 isT).
  rewrite addn0 leq_min increasingE //= (leq_trans (ltnW fLg)) //.
  by rewrite increasingE // leq_addr.
by rewrite subSS -addSnnS IH.
Qed.

Lemma fmerge_aux_exist f g i j n :
  exists2 k, k <= n & fmerge_aux f g i j n = minn (f (i + k)) (g (j + (n - k))).
Proof.
elim: n i j => /= [i j | n IH i j]; first by exists 0; rewrite //= !addn0.
case: (leqP (g j) (f i)) => [gLf|fLg]; last first.
  by case: (IH i.+1 j) => k kLn ->; exists k.+1; rewrite // addnS subSS.
case: (IH i j.+1) => [] [|k] kLn ->.
  by exists 0; rewrite // addn0 !subn0 addnS.
by exists k.+1; rewrite ?(leq_trans kLn) // addSnnS -subSn.
Qed.

Lemma fmergeE (f g : nat -> nat) n :
 increasing f -> increasing g ->
 fmerge f g n = \max_(i < n.+1) minn (f i) (g (n - i)).
Proof.
move=> fI gI.
apply/eqP; rewrite /fmerge eqn_leq; apply/andP; split.
  case: (@fmerge_aux_exist f g 0 0 n) => // i1 i1Ln ->.
  by apply: (@leq_bigmax_cond _ _ _ (Ordinal (i1Ln : i1 < n.+1))).
apply/bigmax_leqP => /= i _.
by apply: fmerge_aux_correct; rewrite -1?ltnS.
Qed.

Lemma increasing_fmerge f g :
  increasing f -> increasing g -> increasing (fmerge f g).
Proof.
move=> fI gI n; rewrite !fmergeE //.
apply/bigmax_leqP => /= i _.
apply: leq_trans (leq_bigmax_cond _ (isT : xpredT (inord i : 'I_n.+2))).
rewrite inordK ?(leq_trans (ltn_ord _)) //.
rewrite leq_min geq_minl /= (leq_trans (geq_minr _ _)) //.
apply: increasingE gI _.
by rewrite leq_sub2r.
Qed.

Lemma fmerge0 f g : fmerge f g 0 = minn (f 0) (g 0).
Proof. by []. Qed.

Fixpoint sum_fmerge_aux (f g : nat -> nat) i j n :=
 if n is n1.+1 then
   if f i < g j then f i + sum_fmerge_aux f g i.+1 j n1
   else g j + sum_fmerge_aux f g i j.+1 n1
 else minn (f i) (g j).

Definition sum_fmerge f g n := sum_fmerge_aux f g 0 0 n.

Lemma sum_fmerge_aux_correct f g n i j :
  sum_fmerge_aux f g i j n = \sum_(k < n.+1) fmerge_aux f g i j k.
Proof.
elim: n i j => //= [i j|n IH i j]; first by rewrite big_ord_recr big_ord0.
by rewrite big_ord_recl /= /minn; case: leqP; rewrite IH.
Qed.

Lemma sum_fmerge_correct f g n :
  sum_fmerge f g n = \sum_(k < n.+1) fmerge f g k.
Proof. by apply: sum_fmerge_aux_correct. Qed.

Lemma sum_fmerge_aux_conv_correct f g i j n :
  increasing f -> increasing g ->
  (forall k, k <= n.+1 ->
    sum_fmerge_aux f g i j n <=
    \sum_(l < k) f (i + l) + \sum_(l < n.+1 - k) g (j + l)).
Proof.
move=> fI gI.
elim: n i j => /= [i j [_|[_|]]//|n IH i j k kLn].
- by rewrite big_ord_recr !big_ord0 /= !addn0 !add0n geq_minr.
- by rewrite big_ord_recr !big_ord0 /= !addn0 !add0n geq_minl.
case: leqP => [gLf|fLg].
  move: kLn; case: ltngtP => // [kLn _ |-> _]; last first.
    rewrite subnn big_ord0 addn0 big_ord_recl addn0 /=.
    apply: leq_add => //.
    rewrite /bump /=.
    apply: leq_trans (IH _ _ _ (leqnn _)) _.
    rewrite subnn big_ord0 addn0 leq_sum // => l _.
    by apply: increasingE; rewrite // addnCA leq_addl.
  rewrite subSn // big_ord_recl addn0 addnCA leq_add2l.
  apply: leq_trans (IH _ _ _ (kLn : k <= n.+1)) _.
  rewrite leq_add2l leq_sum // => l _.
  by rewrite increasingE //= /bump addnCA add1n.
move: kLn; case: ltngtP => // [kLn _ |-> _]; last first.
  rewrite subnn big_ord0 addn0 big_ord_recl addn0 /= leq_add2l /bump /=.
  apply: leq_trans (IH _ _ _ (leqnn _)) _.
  rewrite subnn big_ord0 addn0 leq_sum // => l _.
  by rewrite increasingE // addnCA add1n.
case: k kLn => [_|k kLn]; last first.
  rewrite subSS.
  apply: leq_trans (leq_add  (leqnn _) (IH i.+1 j k _)) _ .
    by rewrite -ltnS ltnW.
  rewrite addnA leq_add2r big_ord_recl addn0 leq_add2l leq_sum // => l _.
  by rewrite addnCA.
rewrite big_ord0 add0n subn0.
apply: leq_trans (leq_add  (leqnn _) (IH i.+1 j 0 isT)) _ .
rewrite big_ord0 add0n subn0 [X in _ <= X]big_ord_recr addnC leq_add //.
apply: leq_trans (ltnW fLg) _.
by rewrite increasingE // leq_addr.
Qed.

Lemma leq_sum_fmerge_conv f g k n :
  increasing f -> increasing g -> k <= n ->
  \sum_(i < n) fmerge f g i <= \sum_(i < k) f i + \sum_(i < n - k) g i.
Proof.
move=> fI gI; case: n => [|n kLn].
  by case: k; rewrite // !big_ord0.
rewrite -sum_fmerge_correct.
exact: (sum_fmerge_aux_conv_correct 0 0 fI gI kLn).
Qed.

Lemma sum_fmerge_aux_exist f g i j n :
  exists2 k, k <= n.+1 &
  sum_fmerge_aux f g i j n =
  \sum_(l < k) f (i + l) + \sum_(l < n.+1 - k) g (j + l).
Proof.
elim: n i j => /= [i j | n IH i j].
  rewrite /minn; case: leqP => [gLf|fLg].
    by exists 0; rewrite // big_ord_recl !big_ord0 !(add0n, addn0).
  by exists 1; rewrite // subnn big_ord_recl !big_ord0 !(add0n, addn0).
case: (leqP (g j) (f i)) => [gLf|fLg].
  case: (IH i j.+1) => k kLn ->.
  exists k; first by apply: leq_trans kLn _.
  rewrite (subSn kLn) big_ord_recl addn0 addnCA.
  by congr (_ + (_ + _)); apply: eq_bigr => l _; rewrite addnCA.
case: (IH i.+1 j) => k kLn ->; exists k.+1; first by apply: leq_trans kLn _.
rewrite big_ord_recl addn0 subSS -addnA.
by congr (_ + (_ + _)); apply: eq_bigr => l _; rewrite addnCA.
Qed.

Lemma sum_fmerge_exist f g n :
  exists2 k, k <= n &
  \sum_(i < n) fmerge f g i = \sum_(i < k) f i + \sum_(i < n - k) g i.
Proof.
case: n => [|n]; first by exists 0; rewrite // !big_ord0.
case: (sum_fmerge_aux_exist f g 0 0 n) => k kLn sE.
by exists k; rewrite // -sum_fmerge_correct [LHS]sE.
Qed.

Lemma sum_fmerge_conv f g n :
  increasing f -> increasing g ->
  \sum_(i < n) (fmerge f g) i  =
     conv (fun n => \sum_(i < n) f i) (fun n => \sum_(i < n) g i) n.
Proof.
move=> fI gI.
apply/eqP; rewrite eqn_leq; apply/andP; split; last first.
  case: (sum_fmerge_exist f g n) => k kLn ->.
  by apply: (bigmin_inf _ (leqnn _)).
apply/bigmin_leqP => k kLn.
by apply: leq_sum_fmerge_conv.
Qed.

(* This is 3.2 *)
Lemma delta_conv f g :
  convex f -> convex g -> delta (conv f g) =1 fmerge (delta f) (delta g).
Proof.
move=> [fI dfI] [gI dgI] n.
rewrite -delta_fnorm; last by apply: increasing_conv.
rewrite -(delta_ext (conv_fnorm _ _)) //.
have/delta_ext-> : conv (fnorm f) (fnorm g) =1
         conv (fun n => \sum_(i < n) (delta (fnorm f)) i)
              (fun n => \sum_(i < n) (delta (fnorm g)) i).
  by apply: conv_ext => i; apply: sum_delta.
have/delta_ext-> :
  (conv (fun n : nat => \sum_(i < n) delta (fnorm f) i)
        (fun n : nat => \sum_(i < n) delta (fnorm g) i)) =1
  (fun n => \sum_(i < n) (fmerge (delta (fnorm f)) (delta (fnorm g))) i).
  move=> k; rewrite -sum_fmerge_conv //.
    by apply: increasing_ext dfI => i; rewrite delta_fnorm.
  by apply: increasing_ext dgI => i; rewrite delta_fnorm.
rewrite /delta big_ord_recr /= addnC addnK.
by apply: fmerge_aux_ext => i; apply: delta_fnorm.
Qed.

Lemma convex_conv f g : convex f -> convex g -> convex (conv f g).
Proof.
move=> [fI dfI] [gI dgI]; split; first by apply: increasing_conv.
apply: increasing_ext => [i|]; first by apply/sym_equal/delta_conv.
by apply: increasing_fmerge.
Qed.

End Convex.

Notation "\min_ ( i <= n ) F" := (bigmin (fun i => F) n)
 (at level 41, F at level 41, i, n at level 50,
  format "\min_ ( i  <=  n )  F").

(* Mimic AC match for leq_trans *)
Ltac is_num term :=
 match term with
 | 0 => true
 | S ?X => is_num X
 | _ => false
end.

Ltac split_term term :=
 match term with
 | ?X * ?Y => match is_num X with true =>  constr:((X, Y))
              | false =>
              let v := once (split_term X) in constr:((fst v, snd v * Y))
              end
 | ?X => match is_num X with true => constr:((X, 1))
                             | _ => constr:((1, X)) end
 | _ => false
end.

Ltac delta_term n1 n2 t2 :=
  let n :=  constr:(n1 - n2) in
  let n1 := eval compute in n in
  let vt2 := eval lazy delta [fst snd] iota beta in t2 in
  let r :=
    match n1 with
    | 0 => constr:(0)
    | 1 => constr:(t2)
    | ?X  =>
    match vt2 with | 1 => X | _ => constr:(X * vt2) end
    end in
   eval lazy delta [fst snd] iota beta in r.

Ltac delta_lterm2 n1 t1 lt2 :=
 match lt2 with
 |  ?X2 + ?Y2 =>
     let v2 := split_term Y2 in
     let n2 := constr:(fst v2) in
     let t2 := constr:(snd v2) in
     let t := constr:((t1, t2)) in
     let vt := eval lazy delta [fst snd] iota beta in t in
     match vt with
     | (?X, ?X) => delta_term n1 n2 t2
     |  _  => delta_lterm2 n1 t1 X2
     end
 |   ?Y2 =>
     let v2 := split_term Y2 in
     let n2 := constr:(fst v2) in
     let t2 := constr:(snd v2) in
     let t := constr:((t1, t2)) in
     let vt := eval lazy delta [fst snd] iota beta in t in
     match vt with
     | (?X, ?X) => delta_term n1 n2 t2
     |  _  => delta_term n1 0 t1
     end
end.

Ltac make_sum t1 t2 :=
  match t1 with 0 => t2 | _ =>
  match t2 with 0 => t1 | _ => constr:(t1 + t2) end end.

Ltac delta_lterm1 lt1 lt2 :=
 match lt1 with
 |  ?X1 + ?Y1 =>
     let v1 := split_term Y1 in
     let n1 := constr:(fst v1) in
     let t1 := constr:(snd v1) in
     let r1 := delta_lterm1 X1 lt2 in
     let r2 := delta_lterm2 n1 t1 lt2 in make_sum r1 r2

 |   ?Y1 =>
     let v1 := split_term Y1 in
     let n1 := constr:(fst v1) in
     let t1 := constr:(snd v1) in delta_lterm2 n1 t1 lt2
end.

Ltac test t1 t2 := let xx := delta_lterm1 t1 t2 in pose kk := xx.

Ltac applyr H :=
  rewrite -?mul2n in H |- *;
  match goal with
  H: is_true (leq _ ?X) |- is_true (leq _ ?Y) =>
    ring_simplify X Y in H;
    ring_simplify X Y; rewrite ?[nat_of_bin _]/= in H |- *
  end;
  let Z := fresh "Z" in
  match goal with
  H: is_true (leq _ ?X1) |- is_true (leq _ ?Y1) =>
    let v := delta_lterm1 Y1 X1 in
    (try (rewrite [Z in _ <= Z](_ : _ = v + X1)));
    [ apply: leq_trans (leq_add (leqnn _) H); rewrite {H}// ?(add0n,addn0)
     | ring]
  end.

Ltac applyl H :=
  rewrite -?mul2n in H |- *;
  match goal with
  H: is_true (leq ?X _) |- is_true (leq ?Y _) =>
    ring_simplify X Y; ring_simplify X Y in H;
    rewrite ?[nat_of_bin _]/= in H |- *
  end;
  let Z := fresh "Z" in
  match goal with
  H: is_true (leq ?X1 _) |- is_true (leq ?Y1 _) =>
    let v := delta_lterm1 Y1 X1 in
    (try rewrite [Z in Z <= _](_ : Y1 = v + X1));
    [apply: leq_trans (leq_add (leqnn _) H) _;
     rewrite {H}// ?(add0n,addn0) | ring]
  end.

Ltac gsimpl :=
  rewrite -?mul2n in |- *;
  match goal with
  |- is_true (leq ?X ?Y) =>
    ring_simplify X Y; rewrite ?[nat_of_bin _]/=
  end;
  let Z := fresh "Z" in
  match goal with
    |- is_true (leq ?X1 ?Y1) =>
    let v := delta_lterm1 Y1 X1 in
    match v with
    | 0 =>
    let v := delta_lterm1 X1 Y1 in
    let v1 := delta_lterm1 X1 v in
    let v2 := delta_lterm1 Y1 v1 in
    (try (rewrite [Z in _ <= Z](_ : Y1 = v2 + v1); last by ring));
    (try (rewrite [Z in Z <= _](_ : X1 = v + v1); last by ring));
    rewrite ?leq_add2r
    | _ =>
    let v1 := delta_lterm1 Y1 v in
    let v2 := delta_lterm1 X1 v1 in
    (try (rewrite [Z in _ <= Z](_ : Y1 = v + v1); last by ring));
    (try (rewrite [Z in Z <= _](_ : X1 = v2 + v1); last by ring));
    rewrite ?leq_add2r
  end
  end.

Ltac sring := rewrite -!mul2n; ring.
Ltac changel t :=
  let X := fresh "X" in
  rewrite [X in X <= _](_ : _ = t); last by (ring || sring).
Ltac changer t :=
  let X := fresh "X" in
  rewrite [X in _ <= X](_ : _ = t); last by (ring || sring).


(** ** Reduction and Values *)

Require Export ARS Coq.Program.Equality.
Require Import core fintype.
Import ScopedNotations.
From Chapter9 Require Export stlc.
Set Implicit Arguments.
Unset Strict Implicit.

Ltac inv H := dependent destruction H.
Hint Constructors star.

(** *** Single-step reduction *)
Inductive step {n} : tm n -> tm n -> Prop :=
| step_beta A b t : step (app (lam A b) t) (b[t..])
| step_abs A b1 b2 : @step (S n) b1 b2 -> step (lam A b1) (lam A b2)
| step_appL s1 s2 t : step s1 s2 -> step (app s1 t) (app s2 t)
| step_appR s t1 t2 : step t1 t2 -> step (app s t1) (app s t2).

Hint Constructors step.

Lemma step_beta' n A b (t t': tm n):
  t' = b[t..] -> step (app (lam A b) t) t'.
Proof. intros ->. now constructor. Qed.

(** *** Multi-step reduction *)

Lemma mstep_lam n A (s t : tm (S n)) :
  star step s t -> star step (lam A s) (lam A t).
Proof. induction 1; eauto. Qed.

Lemma mstep_app n (s1 s2 : tm n) (t1 t2 : tm n) :
  star step s1 s2 -> star step t1 t2 -> star step (app s1 t1) (app s2 t2).
Proof with eauto.
  intros ms. induction 1. induction ms... auto...
Qed.

(** *** Substitutivity *)

Lemma step_inst {m n} (f : fin m -> tm n) (s t : tm m) :
  step s t -> step (subst_tm f s) (subst_tm f t).
Proof.
   intros st. revert n f.  induction st as  [m b s t |m A b1 b2 _ ih|m s1 s2 t _ ih|m s t1 t2 _ ih]; intros n f; cbn.
  - apply step_beta'. now asimpl.
  - apply step_abs. eapply ih.
  - apply step_appL, ih.
  - apply step_appR, ih.
Qed.

Lemma mstep_inst m n (f : fin m -> tm n) (s t : tm m) :
  star step s t -> star step (s[f]) (t[f]).
Proof. induction 1; eauto using step_inst. Qed.

Lemma mstep_subst m n (f g : fin m -> tm n) (s t : tm m) :
  star step s t -> (forall i, star step (f i) (g i)) ->
  star step (s[f]) (t[g]).
Proof with eauto.
  intros st fg.
  apply star_trans with (y := t[f]); [eauto using mstep_inst|].
  clear s st. revert n f g fg.
  induction t; eauto using mstep_app; intros; simpl.
  - cbn. apply mstep_lam. apply IHt. intros [i|]; [|constructor].
    + asimpl.  cbn. unfold funcomp. substify. now apply mstep_inst.
Qed.

Lemma mstep_beta n (s1 s2 : tm (S n)) (t1 t2 : tm n) :
  star step s1 s2 -> star step t1 t2 ->
  star step (s1 [t1..]) (s2 [t2..]).
Proof.
  intros st1 st2. apply mstep_subst; [assumption|].
  now intros [|].
Qed.

Lemma step_naturality m n (M: tm m) (rho: fin m -> fin n) M' :
  step (M ⟨rho⟩) M' -> exists M'', step M M'' /\ M' = (M'' ⟨rho⟩).
Proof.
  intros H.
  dependent induction H.
  - destruct M; try inversion x. subst.
    destruct M1; try inversion H0. subst.
    exists (M1[M2..]). split. eauto.
    asimpl. reflexivity.
  - destruct M; inversion x. subst.
    edestruct (IHstep _ M) as (?&?&?); [reflexivity|].
    subst. eexists; eauto.
  - destruct M; inversion x. subst.
    edestruct (IHstep _ M1) as (?&?&?); [reflexivity|].
    subst. eexists; eauto.
  - destruct M; inversion x. subst.
    edestruct (IHstep _ M2) as (?&?&?); [reflexivity|].
    subst. eexists; eauto.
Qed.

Definition value {m} (e : tm m) : Prop :=
  match e with
  | lam  _ _ => True
  | _ => False
  end.

Lemma value_anti {m n} (xi : fin m -> fin n) (s : tm m) :
  value (s⟨xi⟩) -> value s.
Proof.
  destruct s; eauto.
Qed.


Require Export CatSem.CAT.category_hom_transport.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Transparent Obligations.
Unset Automatic Introduction.

(** Func - the Functorial structure on Fobj and Fmor *)
Section Functors.

Variables obC obD:Type.
Variable morC : obC -> obC -> Type.
Variable morD : obD -> obD -> Type.

Class  Functor_struct {C : Cat_struct morC} {D : Cat_struct morD}
   (Fobj: obC -> obD)
   (Fmor: forall a b: obC, morC a b -> morD (Fobj a) (Fobj b)) := {

  functor_map_morphism :> forall a b,
          Proper (equiv ==> equiv)(Fmor a b) ;
  preserve_ident: forall a,
            Fmor a a (id a) == id (Fobj a);
  preserve_comp : forall a b c (f : morC a b) (g : morC b c),
    Fmor a c (f ;; g) == (Fmor a b f) ;; Fmor b c g
}.

(** packaging of a functor *)

Variable C: Cat_struct morC.
Variable D: Cat_struct morD.

Record Functor := {
  Fobj :> obC -> obD;
  Fmor : forall a b: obC, morC a b -> morD (Fobj a) (Fobj b);
  Func_struct :> Functor_struct Fmor
}.

Existing Instance Func_struct.

Variable F: Functor.

Notation "#" := (Fmor) (at level 40).

Lemma Foid a b (f g: morC a b) :
        f == g -> #F f == #F g.
Proof.
  intros.
  rewrite H.
  cat.
Qed.

Lemma FId a : #F (id a)  == id (F a).
Proof.
  apply preserve_ident.
Qed.

Lemma FComp a b c (f: morC a b) (g: morC b c) :
        #F (f ;; g) == #F f ;; #F g.
Proof.
  apply preserve_comp.
Qed.

End Functors.

Existing Instance Func_struct.

(*
Notation "F ` a" := (Fobj F a) (at level 50).
*)

Notation "#" := (Fmor) (at level 40).

(** easier access to functor properties *)

Hint Resolve FComp FId : cat.
Hint Rewrite FComp FId : cat.

Section eqFunctor.
Variables obC obD: Type.
Variable morC: obC -> obC -> Type.
Variable morD: obD -> obD -> Type.
Variable C: Cat_struct morC.
Variable D: Cat_struct morD.

(** EXTensional heterogeneous equality on functors is an
       equivalence relation *)

(** later we'll show that F and G are equal
 if they are extensionally equal on the morphisms
       wrt to Equal_hom, the heterogeneous equality on morphisms *)

Definition EXT_Functor: relation (Functor C D) :=
     fun F G => forall a b: obC, forall f: morC a b,
                  #F f === #G f.

Lemma eq_Functor_equiv: @Equivalence (Functor C D)
         (fun F G => forall a b: obC, forall f: morC a b,
                  #F f === #G f).
Proof.
  split.
  unfold Reflexive.
  intros.
  apply Equal_hom_refl.
  unfold Symmetric.
  intros.
  apply Equal_hom_sym; auto.
  unfold Transitive.
  intros x y z H H' a b f.
  simpl.
  apply (@Equal_hom_trans _ _ _ _ _ _ _ _ _
          (#x f)
             (#y f)
             (#z f)); auto.
Qed.

Definition EXT_Functor_oid := Build_Setoid eq_Functor_equiv.

End eqFunctor.

(** first example of a functor: the Identity Functor *)

Section Id_Comp_Functor.

Variable obC : Type.
Variable morC : obC -> obC -> Type.
Variable C: Cat_struct morC.

Obligation Tactic := cat.

Program Instance Id_Fs : Functor_struct
   (Fobj := fun x => x) (fun a b f => f).
Next Obligation.
Proof.
  unfold Proper;
  red; auto.
Qed.

Definition Id : Functor C C := Build_Functor Id_Fs.

(** Composition of functors *)

Variables obD obE: Type.
Variable morD: obD -> obD -> Type.
Variable morE: obE -> obE -> Type.
Variable D: Cat_struct morD.
Variable E: Cat_struct morE.

Variables (F : Functor C D) (G: Functor D E).

Instance Comp_functor_map_morphism: forall a b,
             Proper (equiv ==> equiv)(fun x: morC a b => #G (#F x)).
Proof.
  intros a b.
  unfold Proper.
  red.
  intros x y H;
  rewrite H.
  cat.
Qed.

Lemma Comp_preserve_ident: forall a,
           #G (#F (id a)) == id (G (F a)).
Proof.
  cat.
Qed.

Lemma Comp_preserve_comp : forall a b c (f : morC a b)
           (g : morC b c),
    #G (#F (f ;; g)) == #G (#F f) ;; #G (#F g).
Proof.
  cat.
Qed.

Obligation Tactic := cat.

Program Instance CompFs : Functor_struct
  (Fobj := fun x => G  (F  x))
  (fun a b => fun x: morC a b => #G (#F x)).
Next Obligation.
Proof.
  apply Comp_functor_map_morphism.
Qed.

Definition CompF := Build_Functor CompFs.

End Id_Comp_Functor.

(** Equivalence on Functors *)

Existing Instance EXT_Functor_oid.

(** Properties of Composition and Id wrt "eq_Functor", our
     equivalence on Functors *)

Section Functor_Comp_Id.

Variable obC : Type.
Variable morC : obC -> obC -> Type.
Variable C: Cat_struct morC.
Variables obD : Type.
Variable morD: obD -> obD -> Type.
Variable D: Cat_struct morD.

Lemma IdF_unit_l (F : Functor C D) : CompF (Id C) F == F.
Proof.
  simpl.
  intros F a b f.
  apply Build_Equal_hom.
  cat.
Qed.

Lemma IdF_unit_r (F : Functor C D) :  CompF F (Id D) ==  F.
Proof.
  simpl.
  intros F a b f.
  apply Build_Equal_hom.
  cat.
Qed.

Variables obE obE' : Type.
Variable morE : obE -> obE -> Type.
Variable morE' : obE' -> obE' -> Type.
Variable E : Cat_struct morE.
Variable E' : Cat_struct morE'.
Variables (F : Functor C D)(G: Functor D E) (H: Functor E E').

Lemma CompF_assoc : CompF F  (CompF G H) == CompF (CompF F G)  H.
Proof.
  simpl.
  intros a b f.
  apply Build_Equal_hom.
  cat.
Qed.

(*
Lemma F_equal_helper (*F: Functor C D*) : forall a b (f g: morC a b),
             f == g ->  #F f === #F g.
Proof.
  intros a b f g H'.
  apply Build_Equal_hom.
  rewrite H'.
  cat.
Qed.
*)

Lemma F_equal_helper2 (F' G': Functor C D): forall a b (f g: morC a b),
           f == g ->
      (forall x y (r: morC x y), #F' r === #G' r) ->
                    #F' f === #G' g.
Proof.
  intros F' G' a b f g H1 H2.
  apply (@Equal_hom_trans _ _ _ _ _ _ _ _ _
                       (#F' f) (#G' f) (#G' g)).
    apply H2.

    apply Build_Equal_hom.
    rewrite H1.
    cat.
Qed.

Lemma F_equal_helper3 (*F' : Functor C D*):
     forall a b a' b' (f: morC a b) (g:morC a' b'),
          f === g -> #F f === #F g.
Proof.
  intros a b a' b' f g H'.
  assert (Ha:= Equal_hom_src H').
  assert (Hb:= Equal_hom_tgt H').
  inversion Ha as [ha].
  inversion Hb as [hb].
  generalize dependent f.
  subst.
  intros.
  assert (H1:= Equal_hom_imp_setoideq2 H').
  constructor.
  rewrite H1.
  cat.
Qed.

End Functor_Comp_Id.

Obligation Tactic := idtac.

Program Instance Cat_CAT: Cat_struct (fun C D : Cat => Functor C D) := {
   mor_oid C D := EXT_Functor_oid C D;
   id C := Id C;
   comp a b c F G := CompF F G
}.
Next Obligation.
Proof.
  intros C D E.
  unfold Proper; repeat red; simpl.
  intros F G H K L H' x y f.
  apply (@Equal_hom_trans _ _ _ _ _ _ _ _  _
    (#K (#F f))
    (#K (#G f))
    (#L (#G f)) ); auto.
  intros;
  apply F_equal_helper3.
  auto.
Qed.
Next Obligation.
Proof.
  intros C D F.
  assert (H:=IdF_unit_r).
  simpl in *.
  apply H.
Qed.
Next Obligation.
Proof.
  intros C D F.
  assert (H:=IdF_unit_l).
  simpl in *.
  apply H.
Qed.
Next Obligation.
Proof.
  intros a b c d f g h.
  apply (CompF_assoc f g h).
Qed.

Existing Instance Cat_CAT.
Notation "G 'O' F" := (CompF F G) (at level 70).


Require Import Basic_Notations_Set.
Require Import Basic_Lemmas.
Require Import Relation_Properties.
Require Import Functions_Mappings.
Require Import Dedekind.
Require Import Logic.IndefiniteDescription.

Module main (def : Relation).
Import def.
Module Basic_Lemmas := Basic_Lemmas.main def.
Module Relation_Properties := Relation_Properties.main def.
Module Functions_Mappings := Functions_Mappings.main def.
Module Dedekind := Dedekind.main def.
Import Basic_Lemmas Relation_Properties Functions_Mappings Dedekind.

(** %
\section{I-点}
\subsection{I-点の定義}
\begin{screen}
Dedekind 圏における域 $X$ のI-点 $x$ とは, 関数 $x:I \rel X$ のことであり, 記号 $x \dot{\in} X$ によって表される. また関係 $\rho :I \rel X$ とI-点 $x:I \rel X$ に対して, 記号 $x \dot{\in} \rho$ で $x \sqsubseteq \rho$ を表すものとする. \\
ちなみにI-点の定義 $x \dot{\in} X$ は $x \dot{\in} \nabla_{IX}$ と言い換えることも可能である.
\end{screen}
% **)
Definition point_inc {X : eqType} (x rho : Rel i X) := function_r x /\ x ⊆ rho.
Definition point {X : eqType} (x : Rel i X) := point_inc x (∇ i X).

(** %
\subsection{I-点の性質}
\begin{screen}
\begin{lemma}[point\_property1]
Let $x,y \dot{\in} X$. Then,
$$
x = y \Leftrightarrow x \cdot y^\sharp = id_I.
$$
\end{lemma}
\end{screen}
% **)
Lemma point_property1 {X : eqType} {x y : Rel i X}:
 point x -> point y -> (x = y <-> x ・ y # = Id i).
Proof.
move => H H0.
split; move => H1.
apply inc_antisym.
rewrite unit_identity_is_universal.
apply inc_alpha_universal.
rewrite H1.
apply H0.
apply Logic.eq_sym.
apply function_inc.
apply H0.
apply H.
rewrite -(@comp_id_l _ _ y) -H1 comp_assoc.
apply comp_inc_compat_ab_a.
apply H0.
Qed.

(** %
\begin{screen}
\begin{lemma}[point\_property2a, point\_property2b]
Let $\rho :I \rel X$ be a total relation. Then,
$$
\rho \cdot \rho^\sharp = \rho \cdot \nabla_{XI} = id_I.
$$
\end{lemma}
\end{screen}
% **)
Lemma point_property2a {X : eqType} {rho : Rel i X}:
 total_r rho -> rho ・ rho # = Id i.
Proof.
move => H.
apply inc_antisym.
rewrite unit_identity_is_universal.
apply inc_alpha_universal.
apply H.
Qed.

Lemma point_property2b {X : eqType} {rho : Rel i X}:
 total_r rho -> rho ・ rho # = rho ・ ∇ X i.
Proof.
move => H.
apply inc_antisym.
apply comp_inc_compat_ab_ab'.
apply inc_alpha_universal.
rewrite (point_property2a H) unit_identity_is_universal.
apply inc_alpha_universal.
Qed.

(** %
\begin{screen}
\begin{lemma}[point\_property3]
Let $\rho :I \rel X$. Then,
$$
\exists x \dot{\in} \rho \Rightarrow \mbox{``$\rho$ is total''} \land \rho \neq \phi_{IX}.
$$
\end{lemma}
\end{screen}
% **)
Lemma point_property3 {X : eqType} {rho : Rel i X}:
 (exists x : Rel i X, point_inc x rho) -> total_r rho /\ rho <> φ i X.
Proof.
elim => x H.
assert (total_r rho).
elim H => H0 H1.
elim H0 => H2 H3.
apply (@inc_trans _ _ _ _ _ H2).
apply comp_inc_compat.
apply H1.
apply (@inc_inv _ _ _ _ H1).
split.
apply H0.
move => H1.
rewrite /total_r in H0.
rewrite H1 comp_empty_l in H0.
apply unit_identity_not_empty.
apply inc_antisym.
apply H0.
apply inc_empty_alpha.
Qed.

(** %
\begin{screen}
\begin{lemma}[point\_property4]
$$
\exists x \dot{\in} X \Rightarrow \mbox{``$\nabla_{IX}$ is total''} \land \nabla_{IX} \neq \phi_{IX}.
$$
\end{lemma}
\end{screen}
% **)
Lemma point_property4 {X : eqType}:
 (exists x : Rel i X, point x) -> total_r (∇ i X) /\ (∇ i X) <> φ i X.
Proof.
move => H.
apply (@point_property3 _ (∇ i X) H).
Qed.

(** %
\section{I-点に関する諸公理}
\subsection{点公理}
\begin{screen}
この ``点公理'' を使えば, I-点に関する様々な定理や補題が導出できる.
\begin{lemma}[point\_axiom]
Let $\rho :I \rel X$. Then,
$$
\rho = \sqcup_{x \dot{\in} \rho} x.
$$
\end{lemma}
\end{screen}
% **)
Lemma lemma_for_PA {X : eqType} {rho : Rel i X}:
 (((rho = φ i X) -> False) -> False) -> rho = φ i X.
Proof.
move => H.
case (@unit_empty_or_universal (rho ・ rho #)) => H0.
apply inc_antisym.
apply (@inc_trans _ _ _ _ _ (relation_rel_inv_rel)).
rewrite H0 comp_empty_l.
apply inc_refl.
apply inc_empty_alpha.
apply False_ind.
apply H.
move => H1.
rewrite H1 comp_empty_l in H0.
apply (unit_empty_not_universal H0).
Qed.

Lemma point_axiom {X : eqType} {rho : Rel i X}:
 rho = ∪_{fun x : Rel i X => point_inc x rho} id.
Proof.
apply inc_antisym.
apply bool_lemma2.
assert ((exists x : Rel i X, point_inc x ((∪_{fun x : Rel i X => point_inc x rho} id) ∩ (∪_{fun x : Rel i X => point_inc x rho} id) ^)) -> False).
move => H.
move : (point_property3 H) => H0.
apply H0.
apply cap_complement_empty.
assert ((exists x : Rel i X, point_inc x (rho ∩ (∪_{fun x : Rel i X => point_inc x rho} id) ^)) -> False).
move => H0.
apply H.
elim H0 => x H1.
exists x.
split.
apply H1.
apply inc_cap.
split.
assert (point_inc x rho).
split.
apply H1.
elim H1 => H2 H3.
apply inc_cap in H3.
apply H3.
clear H1.
move : x H2.
apply inc_cupP.
apply inc_refl.
elim H1 => H2 H3.
apply inc_cap in H3.
apply H3.
apply lemma_for_PA.
move => H1.
apply H0.
apply axiom_of_choice.
rewrite /total_r.
remember (rho ∩ (∪_{fun x : Rel i X => point_inc x rho} id) ^) as rho'.
case (@unit_empty_or_universal (rho' ・ rho' #)) => H2.
apply False_ind.
apply H1.
apply inc_antisym.
apply (@inc_trans _ _ _ _ _ (relation_rel_inv_rel)).
rewrite H2 comp_empty_l.
apply inc_refl.
apply inc_empty_alpha.
rewrite H2.
apply inc_alpha_universal.
apply inc_cupP.
move => beta H.
apply H.
Qed.

(** %
\begin{screen}
\begin{lemma}[PA\_corollary1]
$$
\nabla_{IX} = \sqcup_{x \dot{\in} X} x.
$$
\end{lemma}
\end{screen}
% **)
Lemma PA_corollary1 {X : eqType}: ∇ i X = ∪_{point} id.
Proof.
apply point_axiom.
Qed.

(** %
\begin{screen}
\begin{lemma}[PA\_corollary2]
$$
id_X = \sqcup_{x \dot{\in} X} x^\sharp \cdot x.
$$
\end{lemma}
\end{screen}
% **)
Lemma PA_corollary2 {X : eqType}:
 Id X = ∪_{point} (fun x : Rel i X => x # ・ x).
Proof.
rewrite -(@cap_universal _ _ (Id X)) -lemma_for_tarski2 PA_corollary1.
rewrite comp_cupP_distr_l cap_cupP_distr_l.
apply cupP_eq.
move => alpha H.
apply inc_antisym.
rewrite cap_comm.
apply (@inc_trans _ _ _ _ _ (dedekind2)).
rewrite comp_id_l cap_comm cap_universal.
apply inc_refl.
apply inc_cap.
split.
apply H.
apply comp_inc_compat_ab_a'b.
apply inc_alpha_universal.
Qed.

(** %
\begin{screen}
\begin{lemma}[PA\_corollary3]
Let $\alpha , \beta :X \rel Y$. Then,
$$
(\forall x \dot{\in} X, x \cdot \alpha = x \cdot \beta) \Rightarrow \alpha = \beta.
$$
\end{lemma}
\end{screen}
% **)
Lemma PA_corollary3 {X Y : eqType} {alpha beta : Rel X Y}:
 (forall x : Rel i X, point x -> x ・ alpha = x ・ beta) -> alpha = beta.
Proof.
move => H.
rewrite -(@comp_id_l _ _ alpha) -(@comp_id_l _ _ beta) PA_corollary2.
rewrite comp_cupP_distr_r comp_cupP_distr_r.
apply cupP_eq.
move => gamma H0.
by [rewrite comp_assoc comp_assoc (H gamma H0)].
Qed.

(** %
\begin{screen}
\begin{lemma}[PA\_corollary4]
Let $\alpha :X \rel Y$. Then,
$$
\mbox{``$\alpha$ is total''} \Leftrightarrow \forall x \dot{\in} X, \mbox{``$x \cdot \alpha$ is total''}.
$$
\end{lemma}
\end{screen}
% **)
Lemma PA_corollary4 {X Y : eqType} {alpha : Rel X Y}:
 total_r alpha <-> forall x : Rel i X, point x -> total_r (x ・ alpha).
Proof.
split; move => H.
move => x H0.
apply total_comp.
apply H0.
apply H.
rewrite /total_r.
rewrite PA_corollary2.
apply inc_cupP.
move => x H0.
move : (H x H0) => H1.
apply (@inc_trans _ _ _ ((x # ・ ((x ・ alpha) ・ (x ・ alpha) #)) ・ x)).
apply comp_inc_compat_ab_a'b.
apply (comp_inc_compat_a_ab H1).
rewrite comp_inv -comp_assoc -comp_assoc -comp_assoc.
rewrite comp_assoc (@comp_assoc _ _ _ _ (x # ・ x)).
apply (@inc_trans _ _ _ ((x # ・ x) ・ (alpha ・ alpha #))).
apply comp_inc_compat_ab_a.
apply H0.
apply comp_inc_compat_ab_b.
apply H0.
Qed.

(** %
\begin{screen}
\begin{lemma}[PA\_corollary5]
Let $\alpha :X \rel Y$. Then,
$$
\mbox{``$\alpha$ is univalent''} \Leftrightarrow \forall x \dot{\in} X, \mbox{``$x \cdot \alpha$ is univalent''}.
$$
\end{lemma}
\end{screen}
% **)
Lemma PA_corollary5 {X Y : eqType} {alpha : Rel X Y}:
 univalent_r alpha <-> forall x : Rel i X, point x -> univalent_r (x ・ alpha).
Proof.
split; move => H.
move => x H0.
apply univalent_comp.
apply H0.
apply H.
rewrite /univalent_r.
rewrite -(@comp_id_r _ _ (alpha #)) PA_corollary2.
rewrite comp_cupP_distr_l comp_cupP_distr_r.
apply inc_cupP.
move => x H0.
move : (H x H0) => H1.
rewrite -comp_assoc -comp_inv comp_assoc.
apply H1.
Qed.

(** %
\subsection{全域性公理}
\begin{screen}
\begin{lemma}[total\_axiom]
Let $\rho :I \rel X$. Then,
$$
\rho \neq \phi_{IX} \Rightarrow id_I = \rho \cdot \rho^\sharp.
$$
\end{lemma}
\end{screen}
% **)
Lemma total_axiom {X : eqType} {rho : Rel i X}:
 rho <> φ i X -> Id i = rho ・ rho #.
Proof.
move => H.
case (@unit_empty_or_universal (rho ・ rho #)) => H0.
apply False_ind.
apply H.
apply inc_antisym.
apply (@inc_trans _ _ _ _ _ (relation_rel_inv_rel)).
rewrite H0 comp_empty_l.
apply inc_refl.
apply inc_empty_alpha.
by [rewrite H0 unit_identity_is_universal].
Qed.

(** %
\begin{screen}
\begin{lemma}[Tot\_corollary1]
Let $\rho :I \rel X$ and $x \dot{\in} X$. Then,
$$
\rho \sqsubseteq x \Rightarrow \rho = \phi_{IX} \lor \rho = x.
$$
\end{lemma}
\end{screen}
% **)
Lemma Tot_corollary1 {X : eqType} {rho x : Rel i X}:
 point x -> rho ⊆ x -> rho = φ i X \/ rho = x.
Proof.
move => H H0.
case (@unit_empty_or_universal (rho ・ rho #)) => H1.
left.
apply inc_antisym.
apply (@inc_trans _ _ _ _ _ (relation_rel_inv_rel)).
rewrite H1 comp_empty_l.
apply inc_refl.
apply inc_empty_alpha.
right.
apply inc_antisym.
apply H0.
rewrite -(@comp_id_l _ _ x) unit_identity_is_universal -H1 comp_assoc.
apply (@inc_trans _ _ _ (rho ・ (x # ・ x))).
apply comp_inc_compat_ab_ab'.
apply comp_inc_compat_ab_a'b.
apply (@inc_inv _ _ _ _ H0).
apply comp_inc_compat_ab_a.
apply H.
Qed.

(** %
\begin{screen}
\begin{lemma}[Tot\_corollary2]
Let $x,y \dot{\in} X$. Then,
$$
x \neq y \Leftrightarrow x \cdot y^\sharp = \phi_{II}.
$$
\end{lemma}
\end{screen}
% **)
Lemma Tot_corollary2 {X : eqType} {x y : Rel i X}:
 point x -> point y -> (x <> y <-> x ・ y # = φ i i).
Proof.
move => H H0.
assert (x = y <-> x ・ y # <> φ i i).
rewrite (point_property1 H H0).
split; move => H1.
rewrite H1.
apply unit_identity_not_empty.
case (@unit_empty_or_universal (x ・ y #)) => H2.
apply False_ind.
apply (H1 H2).
by [rewrite H2 unit_identity_is_universal].
rewrite H1.
split; move => H2.
apply (lemma_for_PA H2).
move => H3.
apply (H3 H2).
Qed.

(** %
\begin{screen}
\begin{lemma}[Tot\_corollary3]
Let $f:(I \rel X) \to (I \rel Y)$. Then,
$$
(\forall x \dot{\in} X, \mbox{``$f(x)$ is a function''}) \Rightarrow \mbox{``$\sqcup_{x \dot{\in} X} x^\sharp \cdot f(x)$ is a function''}.
$$
\end{lemma}
\end{screen}
% **)
Lemma Tot_corollary3 {X Y : eqType} {f : Rel i X -> Rel i Y}:
 (forall x : Rel i X, point x -> function_r (f x)) -> function_r (∪_{point} (fun x : Rel i X => x # ・ f x)).
Proof.
move => H.
assert (forall x : Rel i X, point x -> x ・ (∪_{point} (fun x0 : Rel i X => x0 # ・ f x0)) = f x).
move => x H0.
assert (x ・ x # = Id i).
apply inc_antisym.
rewrite unit_identity_is_universal.
apply inc_alpha_universal.
apply H0.
rewrite -(@comp_id_l _ _ (f x)) -H1.
apply inc_antisym.
rewrite comp_cupP_distr_l.
apply inc_cupP.
move => y H2.
rewrite -comp_assoc.
case (@unit_empty_or_universal (x ・ y #)) => H3.
rewrite H3 comp_empty_l.
apply inc_empty_alpha.
rewrite -unit_identity_is_universal in H3.
apply (point_property1 H0 H2) in H3.
rewrite H3.
apply inc_refl.
rewrite comp_assoc.
apply comp_inc_compat_ab_ab'.
clear H1.
move : x H0.
apply inc_cupP.
apply inc_refl.
split.
rewrite PA_corollary4.
move => x H1.
rewrite (H0 x H1).
apply (H x H1).
rewrite PA_corollary5.
move => x H1.
rewrite (H0 x H1).
apply (H x H1).
Qed.

(** %
\subsection{その他の公理}
\begin{screen}
\begin{lemma}[nonempty\_axiom]
Let $\rho :I \rel X$. Then,
$$
\rho \neq \phi_{IX} \Rightarrow \exists x \dot{\in} \rho.
$$
\end{lemma}
\end{screen}
% **)
Lemma nonempty_axiom {X : eqType} {rho : Rel i X}:
 rho <> φ i X -> exists x : Rel i X, point_inc x rho.
Proof.
move : (@axiom_of_choice _ _ rho) => H.
move => H0.
apply H.
rewrite /total_r.
rewrite (total_axiom H0).
apply inc_refl.
Qed.

(** %
\begin{screen}
\begin{lemma}[axiom\_of\_subobjects2]
Let $\rho :I \rel X$. Then,
$$
\exists S, \exists j:S \rel X, \rho = \nabla_{IS} \cdot j \land j \cdot j^\sharp = id_S.
$$
\end{lemma}
\end{screen}
% **)
Lemma axiom_of_subobjects2 {X : eqType} {rho : Rel i X}:
 exists (S : eqType)(j : Rel S X), rho = ∇ i S ・ j /\ j ・ j # = Id S.
Proof.
elim (@rationality _ _ rho) => R.
elim => f.
elim => g.
elim => H.
elim => H0.
elim => H1 H2.
exists R.
exists g.
split.
rewrite H1.
apply inc_antisym.
apply comp_inc_compat_ab_a'b.
apply inc_alpha_universal.
apply comp_inc_compat_ab_a'b.
apply (@inc_trans _ _ _ (∇ i R ・ (f ・ f #))).
apply comp_inc_compat_a_ab.
apply H.
rewrite -comp_assoc.
apply comp_inc_compat_ab_b.
rewrite unit_identity_is_universal.
apply inc_alpha_universal.
rewrite -H2 cap_comm inc_def1.
assert ((f # ・ g) ⊆ rho).
rewrite H1.
apply inc_refl.
apply (function_move1 H) in H3.
apply (@inc_trans _ _ _ ((f ・ rho) ・ (f ・ rho) #)).
apply comp_inc_compat.
apply H3.
apply (@inc_inv _ _ _ _ H3).
rewrite comp_inv comp_assoc -(@comp_assoc _ _ _ _ rho).
apply comp_inc_compat_ab_ab'.
apply comp_inc_compat_ab_b.
rewrite unit_identity_is_universal.
apply inc_alpha_universal.
Qed.

(** %
\section{その他の補題}
\begin{screen}
\begin{lemma}[point\_atomic]
Let $x \dot{\in} X$, then $x$ is atomic.
\end{lemma}
\end{screen}
% **)
Lemma point_atomic {X : eqType} {x : Rel i X}: point x -> atomic x.
Proof.
move => H.
split.
move : (@point_property3 X x) => H0.
apply H0.
exists x.
split.
apply H.
apply inc_refl.
move => beta.
apply (Tot_corollary1 H).
Qed.

(** %
\begin{screen}
\begin{lemma}[point\_atomic2]
Let $x \dot{\in} X$ and $y \dot{\in} Y$, then $x^\sharp \cdot y$ is atomic.
\end{lemma}
\end{screen}
% **)
Lemma point_atomic2 {X Y : eqType} {x : Rel i X} {y : Rel i Y}:
 point x -> point y -> atomic (x # ・ y).
Proof.
move => H H0.
split.
move => H1.
assert (Id i = (x ・ x #) ・ (y ・ y #)).
apply inc_antisym.
rewrite -(@comp_id_l _ _ (Id i)).
apply comp_inc_compat.
apply H.
apply H0.
rewrite unit_identity_is_universal.
apply inc_alpha_universal.
rewrite comp_assoc -(@comp_assoc _ _ _ _ (x #)) in H2.
rewrite H1 comp_empty_l comp_empty_r in H2.
apply (unit_identity_not_empty H2).
move => beta H1.
case (@unit_empty_or_universal ((∇ i X ・ beta) ・ ∇ Y i)) => H2.
left.
apply inc_antisym.
replace (φ X Y) with ((∇ X i ・ φ i i) ・ ∇ i Y).
rewrite -H2 -comp_assoc -comp_assoc unit_universal.
rewrite comp_assoc unit_universal.
apply (@inc_trans _ _ _ (∇ X X ・ beta)).
apply comp_inc_compat_b_ab.
apply inc_alpha_universal.
apply comp_inc_compat_a_ab.
apply inc_alpha_universal.
by [rewrite comp_empty_r comp_empty_l].
apply inc_empty_alpha.
right.
apply inc_antisym.
apply H1.
assert (beta <> φ X Y).
move => H3.
rewrite H3 comp_empty_r comp_empty_l in H2.
apply (unit_empty_not_universal H2).
apply (@inc_trans _ _ _ (x # ・ (x ・ beta))).
apply comp_inc_compat_ab_ab'.
assert ((x ・ beta) ⊆ y).
apply (@inc_trans _ _ _ (x ・ (x # ・ y))).
apply (comp_inc_compat_ab_ab' H1).
rewrite -comp_assoc.
apply comp_inc_compat_ab_b.
rewrite unit_identity_is_universal.
apply inc_alpha_universal.
apply inc_def1 in H1.
rewrite H1 in H3.
assert (x # ・ ((x ・ beta) ∩ y) <> φ X Y).
move => H5.
apply H3.
apply inc_antisym.
rewrite cap_comm.
apply (@inc_trans _ _ _ _ _ (dedekind1)).
rewrite cap_comm inv_invol H5.
apply inc_refl.
apply inc_empty_alpha.
case (Tot_corollary1 H0 H4) => H6.
rewrite H6 cap_comm cap_empty comp_empty_r in H5.
apply False_ind.
by [apply H5].
rewrite H6.
apply inc_refl.
rewrite -comp_assoc.
apply comp_inc_compat_ab_b.
apply H.
Qed.

End main.


(*
(C) Copyright 2010, COQTAIL team

Project Info: http://sourceforge.net/projects/coqtail/

This library is free software; you can redistribute it and/or modify it
under the terms of the GNU Lesser General Public License as published by
the Free Software Foundation; either version 2.1 of the License, or
(at your option) any later version.

This library is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public
License for more details.

You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301,
USA.
*)

Require Import Plus.
Require Import Le.
Require Import Compare.
Open Scope nat_scope.

(* begin hide *)
Lemma plus_1_r : forall n, n+1=S n.
induction n.
auto with arith.
simpl.
rewrite IHn.
reflexivity.
Qed.
(* end hide *)

(** * Definition of kth-successor and generalized AND hypothesis *)

Fixpoint kth_S (k : nat) (n : nat) {struct k} : nat:=
match k with
| 0 => S n
| S k' => S(kth_S k' n)
end.

Fixpoint next_P_k (k : nat) (delta : nat) (P : nat -> Prop) {struct k} : Prop:=
match k with
| 0 => P delta
| S k' => P (kth_S delta k') /\ next_P_k k' delta P
end.

(** * Properties of [next_P_k] and [kth_S] *)
(** [next_P_k] upper weakening *)
Lemma next_P_k_strong : forall k delta P,
  next_P_k (S k) delta P -> next_P_k k delta P.
induction k.
intros.
unfold next_P_k.
unfold next_P_k in H.
destruct H.
exact H0.

intros.
unfold next_P_k. fold next_P_k.
unfold next_P_k in H. fold next_P_k in H.
destruct H.
destruct H0.
split.
exact H0.
exact H1.
Qed.

(** commutativity of nested [kth_S] *)
Lemma kth_S_comm : forall delta gamma n,
  kth_S delta (kth_S gamma n) = kth_S gamma (kth_S delta n).
induction delta.
intros.
induction gamma.
compute. reflexivity.
unfold kth_S. fold kth_S.
unfold kth_S in IHgamma. fold kth_S in IHgamma.
rewrite IHgamma.
reflexivity.

intros.
unfold kth_S. fold kth_S.
rewrite IHdelta.
induction gamma.
compute. reflexivity.
unfold kth_S. fold kth_S.
rewrite IHgamma.
reflexivity.
Qed.

(** special case of [kth_S] *)
Lemma kth_S_special : forall k, kth_S k 0 = S k.
Proof.
induction k.
compute. reflexivity.
unfold kth_S. fold kth_S.
rewrite IHk.
reflexivity.
Qed.

(** [next_P_k] to [P] weakening *)
Lemma next_P_k_special: forall k delta P,
  next_P_k k delta P -> P delta.
Proof.
induction k.
intros. exact H.
intros. apply IHk.
apply next_P_k_strong.
exact H.
Qed.

(** symmetry of [kth_S] *)
Lemma kth_S_sym : forall k n, kth_S k n = kth_S n k.
Proof.
induction k.
intro.
rewrite kth_S_special.
reflexivity.

intro.
unfold kth_S. fold kth_S.
rewrite IHk.
induction n.
compute. reflexivity.
unfold kth_S. fold kth_S.
rewrite IHn.
reflexivity.
Qed.

(** relation between [kth_S] and [plus] *)
Lemma kth_S_plus : forall k n, kth_S k n = n + k + 1.
Proof.
induction k.
intro.
unfold kth_S.
rewrite plus_0_r.
rewrite plus_1_r.
reflexivity.
intro.
unfold kth_S. fold kth_S.
rewrite IHk.
assert (n + S k + 1=S k + n +1).
auto with arith.
rewrite H. clear H.
simpl.
auto with arith.
Qed.

(** introduction of [next_P_k] *)
Theorem next_P_k_correct : forall k delta, forall P : nat -> Prop,
  P delta -> (forall x, x < k -> P (kth_S delta x)) -> next_P_k k delta P.
Proof.
induction k.
intros.
simpl.
exact H.
intros.
simpl.
split.
apply H0.
auto with arith.
apply IHk.
exact H.
intros.
apply H0.
auto with arith.
Qed.

(** elimination of [next_P_k] *)
Theorem next_P_k_complete : forall k delta P,
  next_P_k k delta P -> P delta /\ (forall x, x < k -> P (kth_S delta x)).
Proof.
induction k.
intros.
split.
simpl in H.
auto.
intros.
inversion H0.
intros.
assert (P delta /\ forall x, x<k -> P(kth_S delta x)).
apply IHk.
apply next_P_k_strong.
auto.
split.
destruct H0.
auto.
intros.
apply le_le_S_eq in H1.
destruct H1.
apply H0.
auto with arith.
apply eq_add_S in H1.
rewrite H1.
simpl in H.
destruct H.
apply H.
Qed.

(** [next_P_k] lower weakening *)
Lemma next_P_k_strong2 : forall k delta P,
  next_P_k (S k) delta P -> next_P_k k (S delta) P.
Proof.
induction k.
intros.
unfold next_P_k. fold next_P_k.
unfold next_P_k in H. rewrite kth_S_special in H.
destruct H. exact H.

intros.
unfold next_P_k. fold next_P_k.
split.
unfold next_P_k in H. fold next_P_k in H.
unfold kth_S. fold kth_S.
destruct H.
rewrite kth_S_sym in H.
unfold kth_S in H. fold kth_S in H.
rewrite kth_S_sym in H.
exact H.
apply IHk.
unfold next_P_k in H. fold next_P_k in H.
destruct H.
exact H0.
Qed.

(** * Inductions on [nat] *)

(** Generalized n-step induction *)
Theorem nat_k_ind : forall k P,
  next_P_k k 0 P -> (forall n, P n -> P(kth_S k n)) -> forall n, P n.
Proof.
intros.
assert (forall n:nat, next_P_k (S k) n P).
apply nat_ind.
unfold next_P_k. fold next_P_k.
split.
unfold kth_S.
assert (kth_S k 0=S k).
apply kth_S_special.
rewrite <- H1.
apply H0.
apply next_P_k_special with k.
exact H.

exact H.

intros.
unfold next_P_k. fold next_P_k.
split.
rewrite kth_S_sym.
apply H0.
apply next_P_k_strong2 in H1.
apply next_P_k_special with k.
exact H1.
apply next_P_k_strong2.
exact H1.
destruct H1 with n.
fold next_P_k in H3.
apply next_P_k_special with k.
exact H3.
Qed.

(** Simple nat induction is a special case *)
Lemma nat_simple_ind : forall P : nat -> Prop,
   P 0 -> (forall n:nat, P n -> P(S n)) -> forall n, P n.
Proof.
exact (nat_k_ind 0).
Qed.

(** Double-step nat induction is a special case *)
Lemma nat_double_ind : forall P : nat -> Prop,
   P 0 -> P 1 -> (forall n, P n -> P(S(S n))) -> forall n, P n.
Proof.
intros P H0 H1 Hind.
apply nat_k_ind with 1.
compute.
split.
exact H1. exact H0.
exact Hind.
Qed.

(** Triple-step nat induction is a special case *)
Lemma nat_triple_ind : forall P : nat -> Prop,
   P 0 -> P 1 -> P 2-> (forall n, P n -> P(S (S (S n)))) -> forall n, P n.
Proof.
intros P H0 H1 H2 Hind.
apply nat_k_ind with 2.
compute.
split.
exact H2. split.
exact H1. exact H0.
exact Hind.
Qed.

(** Strong induction on [nat] *)
Lemma nat_strong_ind : forall P : nat -> Prop,
  P 0 -> (forall n, (forall k, k<=n -> P k) -> P(S n)) -> forall n, P n.
intros.
assert (forall n, (forall k, k<=n -> P k)).
apply (nat_ind (fun n=>forall k, k<=n -> P k)).
intros.
apply le_n_O_eq in H1.
rewrite <- H1.
exact H.
intros.
apply le_le_S_eq in H2.
destruct H2.
apply H1.
auto with arith.
rewrite H2.
apply H0.
exact H1.
apply H1 with n.
auto with arith.
Qed.


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

Require Import List Permutation Arith Omega.

Require Import utils.

Set Implicit Arguments.

(** * Intuionistic Linear Logic *)

Definition ill_vars := nat.

Inductive ill_conn := ll_with | ll_limp | ll_times | ll_plus.
Inductive ill_cst := ll_one | ll_bot | ll_top.

Inductive ill_form : Set :=
  | ill_var  : ill_vars -> ill_form
  | ill_zero : ill_cst  -> ill_form
  | ill_bang : ill_form -> ill_form
  | ill_bin  : ill_conn -> ill_form -> ill_form -> ill_form.

(* Symbols for cut&paste ⟙   ⟘   𝝐  ﹠ ⊗  ⊕  ⊸  ❗   ‼  ∅  ⊢ *)

Notation "⟙" := (ill_zero ll_top).
Notation "⟘" := (ill_zero ll_bot).
Notation 𝝐 := (ill_zero ll_one).

Infix "&" := (ill_bin ll_with) (at level 50, only parsing).
Infix "﹠" := (ill_bin ll_with) (at level 50).

Infix "⊗" := (ill_bin ll_times) (at level 50).
Infix "⊕" := (ill_bin ll_plus) (at level 50).

Infix "-o" := (ill_bin ll_limp) (at level 51, right associativity).

Notation "'!' x" := (ill_bang x) (at level 52).

Definition ill_lbang := map (fun x => !x).

Notation "'!l' Γ" := (ill_lbang Γ) (at level 52, only parsing).
Notation "‼ Γ" := (ill_lbang Γ) (at level 52).

Notation "£" := ill_var.

Notation "∅" := nil (only parsing).


(**************************************************************************)
(**   Mechanised Framework for Local Interactions & Distributed Algorithms
      T. Balabonski, P. Courtieu, R. Pelle, L. Rieg, X. Urbain

      PACTOLE project

      This file is distributed under the terms of the CeCILL-C licence
                                                                          *)
(**************************************************************************)

Require Import Rbase SetoidDec.
Require Import Pactole.Util.Coqlib.
Require Pactole.Core.Identifiers.
Set Implicit Arguments.

Class Graph (V E : Type) := {
  V_Setoid :> Setoid V;
  E_Setoid :> Setoid E;
  V_EqDec :> EqDec V_Setoid;
  E_EqDec :> EqDec E_Setoid;

  src : E -> V; (* source and target of an edge *)
  tgt : E -> V;
  threshold : E -> R; (* TODO: use [strict_ratio] instead? *)
  threshold_pos : forall e, (0 < threshold e < 1)%R;
  src_compat :> Proper (equiv ==> equiv) src;
  tgt_compat :> Proper (equiv ==> equiv) tgt;
  threshold_compat :> Proper (equiv ==> Logic.eq) threshold;

  find_edge : V -> V -> option E;
  find_edge_compat :> Proper (equiv ==> equiv ==> opt_eq equiv) find_edge;
  find_edge_None : forall a b : V, find_edge a b == None <-> forall e : E, ~(src e == a /\ tgt e == b);
  find_edge_Some : forall v1 v2 e, find_edge v1 v2 == Some e <-> v1 == src e /\ v2 == tgt e }.

Global Opaque threshold_pos src_compat tgt_compat threshold_compat find_edge_compat find_edge_None find_edge_Some.

(** A finite graph ia a graph where the set [V] of vertices is a prefix of N. *)
(* FIXME: nothing prevents E from being infinite! *)
(* TODO: Maybe we should reuse the type used for robot names *)
Definition finite_node n := {m : nat | m < n}.

(* We explictely define the setoid here to avoid using proj1_Setoid instead. *)
Instance finite_node_Setoid n : Setoid (finite_node n) := eq_setoid _.
Instance finite_node_EqDec n : EqDec (finite_node_Setoid n) := @Identifiers.subset_dec n.

Definition FiniteGraph (n : nat) E := Graph (finite_node n) E.
Existing Class FiniteGraph.
Global Identity Coercion proj_graph : FiniteGraph >-> Graph.


(* ====================================================================
 * We start by loading a few libraries and declaring some
 * propositional variables.
 * ==================================================================== *)

Require Import ssreflect.

Parameter A B C D : Prop.

(* ====================================================================
 * Introducing the "move" tactic
 * ==================================================================== *)

(* `move` allows giving a name to the first (top) assumption of
 * the current goal. For example: *)

Lemma move_ex : A -> B -> A.
Proof.
(* Introduce the assumptions `A` & `B` with respective names
 * `hA` and `hB`. *)
move=> hA hB.
Abort.

(* ====================================================================
 * Introducing the "assumption" tactic
 * ==================================================================== *)

(* `assumption` closes a goal when it can be discharged from an
 * assumption. For example: *)

Lemma assumption_ex : A -> B -> A.
Proof.
(* Introduce the assumptions `A` & `B` with respective
 * names `hA` and `hB`. *)
move=> hA hB.
(* The goal can be solved by `hA` *)
(* If the goal is already in your context, you can use the assumption tactic to immediately prove the goal. *)
assumption.
Qed.

(* It is also possible to close the goal by explicitly giving the name
 * of the assumption, using `apply`: *)

Lemma apply_ex : A -> B -> A.
Proof.
(* Introduce the assumptions `A` & `B` with respective names
 * `hA` and `hB`. *)
move=> hA hB.
(* The goal can be solved by `hA` *)
apply hA.
Qed.

(* ====================================================================
 * Some basic propositional reasonning
 * ==================================================================== *)

Lemma ex0 : A -> A.
move => a.
trivial.
Qed.

Lemma ex1 : forall A : Prop, A -> A.
Proof.
move => a.
move => a0.
apply a0.
Qed.

Lemma ex2 : (A -> B) -> (B -> C) -> A -> C.
Proof.
move => ab.
move => bc.
move => a.
(* Here we prove from backward *)
apply bc.
apply ab.
apply a.
Qed.

Lemma ex3 : (A -> B -> C) -> (B -> A) -> B -> C.
Proof.
move => abc.
move => ba.
move => b.

apply abc.
- apply ba. apply b.
- apply b.
Qed.

(* ====================================================================
 * With conjunctions
 * ==================================================================== *)

(* examples *)

Lemma demo_conj1 : (A /\ B) -> A.
Proof.
move=> h.
case: h => [a b].
(* For conjuctions we use case: h => [a b] *)
exact a.
Qed.

Lemma demo_conj2 : A -> B -> A /\ B.
Proof.
move=> a b; split.
- trivial.
- trivial.
Qed.

(* your turn *)

Lemma conj_ex1: A /\ B <-> B /\ A.
Proof.
(* We split iff into => and <= situation *)
split.

(* split can also split the assumption into 2 parts *)
(* Case 1 *)
+ move => ab. split.
case: ab => [a b]. (* discuss ab into the case a and case b *)
exact b.
case: ab => [a b].
exact a.

(* Case 2 *)
+ move => ba. split.
case: ba => [b a]. exact a.
case: ba => [b a]. exact b.
Qed.

(* ====================================================================
 * With disjunctions
 * ==================================================================== *)

(* examples *)

Lemma demo_disj1 : A -> A \/ B.
Proof.
move=> a. left. trivial.
Qed.

Lemma demo_disj2 : B -> A \/ B.
Proof.
move=> a. right. trivial.
Qed.

Lemma demo_disj3 : A \/ B -> C.
move=> h. case: h => [a | b].    (* here we use h => [a | b] into 2 parts, gives two subgoals *)
Abort.

(* Your turn *)

Lemma disj_ex1 :  A \/ B <-> B \/ A.
Proof.
split. (* We seperate into 2 cases and prove => and <= *)

+ move => ab.
case: ab => [a | b].
right. trivial. (* We here use right to consider the right situation of A \/ B *)
left. trivial.

+ move => ba.
case: ba => [a | b].
right. trivial.
left. trivial.
Qed.

Lemma disj_ex2 : A /\ B -> A \/ B.
Proof.
move => ab.
case: ab => [a b].
right. trivial.
Qed.

(* ====================================================================
 * For negations.
 * ==================================================================== *)

Print not.  (* not A (or ~A) is a shorthand for (A -> False) *)

(* examples *)

Lemma demo_not1 : False -> A.
Proof.
(* We can prove any goal from False *)
move=> h. case: h.
Qed.

(* Your turn *)

Lemma not_ex1 : A -> ~(~A).
Proof.
move => a.
move => not_a.
apply not_a.
apply a.
Qed.

Lemma not_ex2 :  (A -> B) -> ~B -> ~A.
Proof.
move => ab.
move => not_b.
move => a.

apply not_b. (* Here not_b is false *)
apply ab.
apply a.
Qed.

Lemma not_ex3 : ~ ~(A \/ ~A).
Proof.
move => h.
apply h.
right.
move => a.
apply h.
left.
apply a.
Qed.

Lemma not_ex4 :  (A \/ B) /\ C <-> (A /\ C) \/ (B /\ C).
Proof.
split. (* split the lemma into two direction *)

+ move => abc.
case: abc => [ab c].
case: ab => [a | b].
left. split. apply a. apply c.
right. split. apply b. apply c.

+ move => acbc.
case: acbc => [ac | bc].
case: ac => [a c].
split. left. apply a. apply c.
case: bc => [b c].
split. right. apply b. apply c.
Qed.

Lemma not_ex5 : (A /\ B) \/ C <-> (A \/ C) /\ (B \/ C).
Proof.
split.

+ move => abc.
split.
case: abc => [ab | c].
case: ab => [a b].
left. apply a.
right. apply c.

case: abc => [ab | c].
case: ab => [a b].
left. apply b.
right. apply c.

+ move => acbc.
case: acbc => [ac bc].
case: ac => [a | c].
case bc => [b | c].
left. split. apply a. apply b.
right. apply c.
right. apply c.
Qed.