(** This file is part of CoqEAL, the Coq Effective Algebra Library.
(c) Copyright INRIA and University of Gothenburg, see LICENSE *)
(*
    This proof is from:

    Linear Algebra and its Applications

    Volume 184, 15 April 1993, Pages 79–82

    A bijective proof of Muir's identity and the Cauchy-Binet formula

    Jiang Zeng

    Département de Mathématiques Université Louis-Pasteur 7, rue René
    Descartes 67000 Strasbourg Cedex, France

    Received 30 March 1992. Available online 25 March 2002.
    Submitted by Richard A. Brualdi.
*)
From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat div seq path.
From mathcomp Require Import ssralg fintype perm choice finfun.
From mathcomp Require Import matrix  bigop zmodp mxalgebra fingroup.
Require Import minor.

Import GRing.Theory.

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

Open Scope ring_scope.

Section BinetCauchy.
Variable R : comRingType.
Variable k l : nat.

Let Z := ({ffun 'I_k -> 'I_l} * ('S_k))%type.

Variable A : 'M[R]_(k,l).
Variable B : 'M[R]_(l,k).

Definition weight (f: {ffun 'I_k -> 'I_l}) (s : 'S_k) :=
  ((-1) ^+ s) * \prod_(i : 'I_k) (A i (f i) * B (f i) (s i)).

Lemma split_sumZ_sf (P : Z -> R) (C : pred {ffun 'I_k -> 'I_l}):
  \sum_(fz : Z | C fz.1) (P fz) =
  \sum_(s: 'S_k) (\sum_(f: {ffun 'I_k -> 'I_l} | C f) (P (f,s))).
Proof.
rewrite exchange_big pair_big /=.
by apply/eq_big; case=> //= [f s]; rewrite andbT.
Qed.

Lemma split_sumZ_fs (P : Z -> R) (C : pred {ffun 'I_k -> 'I_l}):
  \sum_(fz : Z | C fz.1) (P fz) =
  \sum_(f: {ffun 'I_k -> 'I_l} | C f) (\sum_(s: 'S_k) (P (f,s))).
Proof.
rewrite pair_big /=.
by apply/eq_big; case=>//= [f s]; rewrite andbT.
Qed.

Lemma detAB_weight : \det (A *m B) = \sum_(fz : Z) (weight fz.1 fz.2).
Proof.
rewrite /determinant /weight.
rewrite (split_sumZ_sf _ xpredT) /=.
apply/eq_big => // s _.
rewrite -big_distrr /=; congr (_ * _).
set F := fun n m => A n m * B m (s n).
rewrite -(bigA_distr_bigA F) /=.
apply/eq_big => // i _.
by rewrite !mxE.
Qed.

Definition tilt (i j: 'I_k) (z: 'S_k) := (tperm i j * z)%g.

Lemma tiltK (i j: 'I_k) : involutive (tilt i j).
Proof. by move => s; apply/permP => x; rewrite !permM tpermK. Qed.

Lemma tilt_bij (i j: 'I_k) : bijective (tilt i j).
Proof. by apply inv_bij; apply tiltK. Qed.

Lemma tilt_inj (i j : 'I_k) : injective (tilt i j).
Proof. by apply bij_inj; apply tilt_bij. Qed.

Lemma sign_tilt2 (z: 'S_k) (i j: 'I_k) : i != j ->
  (-1)^+(tilt i j z) = -1* ((-1) ^+ z) :>R.
Proof.
move => hij.
rewrite odd_mul_tperm hij /= mulNr mul1r.
by case: (odd_perm z); rewrite /= expr0 expr1 ?opprK.
Qed.

Lemma sig_tilt (z: 'S_k) (i j: 'I_k) : i != j ->
  ~~ odd_perm (tilt i j z) = odd_perm z.
Proof. by move => hij; rewrite odd_mul_tperm hij negbK /=. Qed.

Lemma reindex_with_tilt (P: 'S_k -> R) (i j: 'I_k) : i != j ->
 \sum_(z : 'S_k) (P z) =
 \sum_(z: 'S_k | odd_perm z) (P z + P (tilt i j z)).
Proof.
move => hij.
rewrite (bigID (fun z:'S_k => odd_perm z)) big_split /=; congr (_ + _).
pose C := fun z => ~~ odd_perm z.
pose D := fun z => odd_perm z.
pose D' := fun z => C _ (tilt i j z).
have hD : D _ =1 D' by move=> p; rewrite /D /D' /C sig_tilt.
by rewrite (eq_bigl _ _ hD) /D' -(reindex_inj (@tilt_inj i j)).
Qed.

Lemma fz_tilt_0 (i j: 'I_k) (f: {ffun 'I_k -> 'I_l}) z:
  i != j -> f i = f j ->  weight f z + weight f (tilt i j z) = 0.
Proof.
rewrite /weight => hij hf.
rewrite sign_tilt2 // !mulNr mul1r -mulrBr.
set b1 := \big[*%R/1]_( _ < _ ) _.
set b2 := \big[*%R/1]_( _ < _ ) _.
suff -> : b1 = b2 by rewrite subrr mulr0.
rewrite /b1 {b1} /b2 {b2} (bigD1 j) //= (bigD1 i) //=.
rewrite [RHS](bigD1 j) //= [X in _ = _ * X](bigD1 i) //=.
rewrite !permM tpermR tpermL hf !mulrA.
congr (_ * _).
  by rewrite -!mulrA; congr (_ * _); rewrite mulrC -mulrA mulrCA.
by apply/eq_big => // x /andP [h1 h2]; rewrite permM tpermD // eq_sym.
Qed.

Lemma sum_bad : \sum_(fz : Z | ~~ injectiveb fz.1) (weight fz.1 fz.2) = 0.
Proof.
rewrite (split_sumZ_fs _ (fun x => ~~ injectiveb x)).
apply/big1 => f /injectivePn [x [y hxy hf]] /=.
rewrite (reindex_with_tilt _ hxy).
by apply/big1 => s _; rewrite fz_tilt_0.
Qed.

Definition strictf (p q: nat) (f: 'I_p -> 'I_q) :=
  [forall x : 'I_p, [forall y : 'I_p, (x < y) == (f x < f y)]].

Lemma inj_strictf (p q : nat) (f: 'I_p -> 'I_q) : strictf f -> injective f.
Proof.
move/forallP=> /= hf x y heq.
move/forallP: (hf x) => /= hfx.
move/forallP: (hf y) => /= hfy.
case: (ltngtP x y)=> [||h]; last by apply/ord_inj.
  by rewrite (eqP (hfx y)) heq ltnn.
by rewrite (eqP (hfy x)) heq ltnn.
Qed.

Lemma inj_strictf_ffun (p q : nat) (f: {ffun 'I_p -> 'I_q}) :
  strictf f -> injective f.
Proof. by move=> h; apply: inj_strictf. Qed.

Remark trans_ltn : ssrbool.transitive ltn.
Proof. by move => x y z; apply (@ltn_trans x y z).  Qed.

Lemma sorted_enum  n (P : pred 'I_n): sorted ltn (map val (enum P)).
Proof.
apply (@subseq_sorted _ ltn trans_ltn _ (map val (enum 'I_n))).
- by apply: map_subseq; rewrite {1}/enum_mem enumT filter_subseq.
by rewrite val_enum_ord iota_ltn_sorted.
Qed.

Lemma path_drop : forall (s: seq nat) (i j d x : nat), path ltn x s ->
  i < j -> path ltn (nth d (x :: s) i) (drop i.+1 (x :: s)).
Proof.
elim => [ | hd tl hi] //= [ | i] j d x /andP [hx hp] hij /=.
- by rewrite hx.
by apply: (hi _ j.-1 _ hd) => //; move: hij; case: j.
Qed.

Lemma path_ordered_nth (i j d d' x : nat) (s: seq nat): path ltn x s ->
  i < j -> i < size (x::s) -> j < size (x::s) ->
  nth d (x::s) i < nth d' (x::s) j.
Proof.
move => hp hij h1 h2.
have hin : nth d' (x :: s) j \in (drop i.+1 (x :: s)).
- move=> {hp}/=.
  elim : s x d' i j hij h1 h2 => [ | hd tl hi] x d' [ | i] [ | j] hij //=.
  + rewrite -[j.+1]add1n -[(size tl).+1]add1n ltn_add2l => _ h.
    by rewrite mem_nth.
  rewrite -[i.+1]add1n -[(size tl).+1]add1n -[j.+1]add1n !ltn_add2l =>
    h1 h2.
  by apply: hi.
move/(order_path_min trans_ltn)/allP: (path_drop d hp hij)=> h.
by apply: (h _ hin).
Qed.

Lemma sorted_ordered_nth i j d d' (s: seq nat): sorted ltn s ->
  i < j -> i < size s -> j < size s -> nth d s i < nth d' s j.
Proof.
case: s => [ | hd tl] //= /path_ordered_nth => h h1 h2 h3.
by apply: h.
Qed.

Lemma nth_change_default: forall (s: seq nat) d d' n, n < size s ->
  nth d s n = nth d' s n.
Proof.
elim => [ | hd tl hi] d d' [ | n] //=.
rewrite -[n.+1]add1n -[(size tl).+1]add1n ltn_add2l => h.
by apply: hi.
Qed.

Lemma sorted_ordered_nth_gen (i j d d' x : nat) (s: seq nat):
  sorted ltn s ->
  i < size s -> j < size s -> nth d s i < nth d' s j -> i < j.
Proof.
move => h hi hj hltn.
case: (ltngtP i j) => // [hji|heq].
- have hgtn := sorted_ordered_nth d d' h hji hj hi.
  rewrite -(ltnn (nth d s i)).
  apply: (ltn_trans hltn).
  by rewrite (nth_change_default d' d hj) (nth_change_default d d' hi).
by move: hltn; rewrite heq (nth_change_default d' d hj) ltnn.
Qed.

Lemma tool_nth : forall (s: seq 'I_l) (n:nat) (x: 'I_n) (d: 'I_l),
 nth (val d) (map val s) x = val (nth d s x).
Proof.
elim => [ | hd tl hi] //= n x d.
- by rewrite !nth_nil.
case: n x => [[] // | n].
rewrite [n.+1]/(1 + n)%nat => x.
case: (splitP x) => [j | j -> /=].
- by rewrite [j]ord1 => ->.
exact: hi.
Qed.

Lemma cast0 (f: {ffun 'I_k -> 'I_l}) : size (enum (codom f)) = #|codom f|.
Proof. by rewrite cardE. Qed.

Lemma cast1 (f: {ffun 'I_k -> 'I_l}) : injective f -> k = #|codom f|.
Proof.
move => hf.
by rewrite (card_codom hf) cardT /= size_enum_ord.
Qed.

Lemma step_weight (g f: {ffun 'I_k -> 'I_l}) (pi: 'S_k) (hf : injective f)
  (phi : 'S_k) : (forall x, f x = g (phi x)) ->
  let: sigma :=  (phi^-1 * pi)%g in
    weight f pi = ((-1)^+ phi * \prod_i (A i (g (phi i)))) *
                  ((-1)^+ sigma * \prod_i (B (g i) (sigma i))).
Proof.
move => heq.
rewrite mulrAC mulrA -signr_addb -odd_permM mulgA mulgV mul1g -mulrA.
rewrite /weight big_split /=.
congr (_ * _); rewrite mulrC.
congr (_ * _); last first.
- apply/eq_big => // i _.
  by rewrite heq.
have hinf : injective phi by apply: perm_inj.
rewrite [X in _ = X](reindex_inj  hinf) /=.
apply/eq_big => // i _.
by rewrite -permM mulgA mulgV mul1g heq.
Qed.

(* need the trunk this codom has changed since 1.3 (maybe backward
   compatible, but I couldn't try *)

Definition same_codomb m n (f g: {ffun 'I_m -> 'I_n}) : bool :=
  [forall x, (x \in codom f) == (x \in codom g)].
Definition same_codom m n (f g: {ffun 'I_m -> 'I_n}) :=
  forall x, (x \in codom f) = (x \in codom g).

Lemma same_codomP m n (f g : {ffun 'I_m -> 'I_n}) :
  reflect (same_codom f g) (same_codomb f g).
Proof.
apply: (iffP forallP) => h x.
- by rewrite (eqP (h x)).
by rewrite (h x).
Qed.

Definition good (g: {ffun 'I_k -> 'I_l}) : pred {ffun 'I_k -> 'I_l} :=
 fun f => injectiveb f && (same_codomb f g).

Lemma goodP (g f: {ffun 'I_k -> 'I_l}) :
  reflect (injective f /\ same_codom f g) (good g f).
Proof.
(* TODO: `andPP` is only available in Coq 8.15+ *)
(* by apply: andPP; [exact: injectiveP | exact: same_codomP]. *)
apply: (iffP andP).
- case => /injectiveP h1 /forallP h2.
  split => // x.
  by rewrite (eqP (h2 x)).
case => h1 h2.
split; first by apply/injectiveP.
by apply/forallP => x; rewrite (h2 x).
Qed.

Lemma mem_same_codom (f g: {ffun 'I_k -> 'I_l}) :
  same_codom f g -> forall x, f x \in codom g.
Proof. by move => h x; rewrite -h codom_f. Qed.

(* g^-1 (f x) *)
Definition inv_g_of_fx (g f: {ffun 'I_k -> 'I_l}) :=
  if same_codomP f g isn't ReflectT b then finfun id
  else finfun (fun x => iinv (mem_same_codom b x)).

Lemma inv_g_of_fxE (g f: {ffun 'I_k -> 'I_l}) :
  same_codom f g ->
  forall x, g (inv_g_of_fx g f x) = f x.
Proof.
rewrite /inv_g_of_fx => heq.
- case: same_codomP => h x.
  by rewrite !ffunE f_iinv.
by case: h.
Qed.

Lemma inv_g_of_fx_inj (g f: {ffun 'I_k -> 'I_l}): injective f ->
  same_codom f g -> injectiveb (inv_g_of_fx g f).
Proof.
move => hf hc.
apply/injectiveP => x y heq.
apply: hf.
by rewrite -!(inv_g_of_fxE hc) heq.
Qed.

(* forall g f, if g and f have the same image and f is injective,
   there is a permutation p such that g = f p.

   we build this p from g and f
*)
Definition perm_f (g f: {ffun 'I_k -> 'I_l}) :=
  if goodP g f isn't ReflectT b then 1%g
  else Perm (inv_g_of_fx_inj (proj1 b) (proj2 b)).

Lemma perm_fE  (g f: {ffun 'I_k -> 'I_l}) : injective f ->
  same_codom f g -> forall x, f x = g ((perm_f g f) x).
Proof.
move => hf hc /= x.
rewrite /perm_f PermDef.fun_of_permE /=.
case: goodP => [/= _|[]] //.
by rewrite inv_g_of_fxE.
Qed.

Lemma codom_perm (g: {ffun 'I_k -> 'I_l}) (p: 'S_k) :
  forall x, (x \in codom (finfun (g \o p))) = (x \in codom g).
Proof.
move => x.
apply/imageP/imageP.
 - case => /= y h1; rewrite ffunE => h2.
   by exists (p y).
case => y h1 h2.
exists (p^-1 y)%g => //=.
by rewrite ffunE /= permKV.
Qed.

Lemma from_good_to_perm (g: {ffun 'I_k -> 'I_l})
  (P : {ffun 'I_k -> 'I_l} -> R) :  injective  g ->
  \sum_(f | good g f) P f = \sum_(phi : 'S_k) (P (finfun (g \o phi))).
Proof.
move => hg.
rewrite (reindex_onto (fun p:'S_k => finfun (g \o p)) (perm_f g)) /=.
- apply/eq_big => // p.
  have hinj : injective (finfun (g \o p)).
  + have htemp : injective (g \o p)
      by apply: inj_comp => //; apply: perm_inj.
    move => x y; rewrite !ffunE => heq.
    exact: htemp.
  have hcodom : forall x,
    (x \in codom (finfun (g \o p))) = (x \in codom g)
    by move => x; rewrite codom_perm.
  apply/andP; split.
  + apply/andP; split; first exact/injectiveP.
    apply/forallP => x; by rewrite hcodom.
  apply/eqP/permP => x.
  have := perm_fE hinj hcodom x.
  by rewrite ffunE => /hg ->.
move => /= f.
case/goodP => h1 h2.
apply/ffunP => /= x.
by rewrite ffunE (perm_fE h1 h2).
Qed.

Lemma one_step (g : {ffun 'I_k -> 'I_l}) : injective g ->
  minor id g A * minor g id B =
  \sum_(fz : Z | good g fz.1) weight fz.1 fz.2.
Proof.
move => hg.
rewrite split_sumZ_fs from_good_to_perm //=.
pose sigma (phi pi: 'S_k) : 'S_k := (phi^-1 * pi)%g.
transitivity (\sum_(phi: 'S_k) \sum_(pi : 'S_k)
  (
    ((-1)^+ phi * \prod_i (A i (g (phi i)))) *
    ((-1)^+ (sigma phi pi) * \prod_i (B (g i) (sigma phi pi i)))
  )
); last first.
- apply/eq_big => // phi _.
  apply/eq_big => // pi _.
  have hinj : injective (finfun (g \o phi)).
  + have htemp : injective (g \o phi)
      by apply: inj_comp => //; apply: perm_inj.
    move => x y; rewrite !ffunE => heq.
    by apply: htemp.
  rewrite (@step_weight g (finfun (g \o phi)) pi hinj phi) //.
  by move => x; rewrite ffunE.
transitivity( \sum_(phi: 'S_k)
         ((-1) ^+ phi * \big[*%R/1]_i A i (g (phi i)) * (
      \big[+%R/0]_pi
          ((-1) ^+ sigma phi pi * \big[*%R/1]_i B (g i) ((sigma phi pi) i)))));
  last first.
- apply/eq_big => // phi _.
  by rewrite -big_distrr /=.
rewrite big_distrl /=.
apply/eq_big => // phi _.
congr ( _ * _).
- by congr (_ * _); apply/eq_big => // i _; rewrite mxE.
have inj_s : injective (sigma phi).
- rewrite /sigma => p1 p2 /permP heq.
  apply/permP => x.
  move: (heq (phi x)).
  by rewrite !permE /= /invg /= permK.
rewrite /minor /determinant.
rewrite (reindex_inj inj_s) /=.
apply/eq_big => // pi _.
congr (_ * _).
apply/eq_big => // i _.
by rewrite !mxE.
Qed.

Lemma gather_by_strictness :
  \sum_(g : {ffun 'I_k -> 'I_l} | strictf g)
     \sum_(fz : Z | good g fz.1) weight fz.1 fz.2 =
  \sum_(g : {ffun 'I_k -> 'I_l} | strictf g)
     (minor id g A) * (minor g id B).
Proof.
apply/eq_big => // g hg.
rewrite one_step //.
by apply/inj_strictf.
Qed.

(* from any injective function f, builds a strictly increasing function
   g with the same image ( == enum_val)
*)
Definition strict_from (f: {ffun 'I_k -> 'I_l}) (hf: injective f) :=
  finfun (fun x => @enum_val _ (mem (codom f)) (cast_ord (cast1 hf) x)).

Lemma strict_fromP (f: {ffun 'I_k -> 'I_l}) (hf: injective f):
  strictf (strict_from hf) /\ same_codom f (strict_from hf).
Proof.
split.
- apply/forallP => x.
  apply/forallP => y.
  have hsorted : sorted ltn (map val (enum (codom f)))
    by apply: sorted_enum.
  apply/eqP.
  rewrite !ffunE /enum_val -!tool_nth.
  apply/idP/idP => [ hxy | ].
  + apply: sorted_ordered_nth => //.
    * by rewrite size_map cast0 ltn_ord.
    by rewrite size_map cast0 ltn_ord.
  apply: sorted_ordered_nth_gen => //=.
  + by rewrite size_map cast0 -(cast1 hf) ltn_ord.
  by rewrite size_map cast0 -(cast1 hf) ltn_ord.
have h1 : enum (codom f) =i codom f by move => y; rewrite mem_enum.
move => y.
apply/imageP/imageP.
- case => x hx hy.
  have hy' : y \in (enum (codom f))
    by rewrite h1 hy codom_f.
  have hi : index y (enum (codom f)) < #|codom f|
    by rewrite -cast0 index_mem.
  have hi' : index y (enum (codom f)) < k
    by move: hi; rewrite -cast1.
  exists (Ordinal hi') => //.
  by rewrite !ffunE /enum_val /= nth_index.
case => /= x hx.
rewrite !ffunE => hy.
have : (y \in codom f) by rewrite hy; apply/enum_valP.
case/imageP => x' _ hx'.
by exists x'.
Qed.

Lemma strictf_lift m n (f: {ffun 'I_m.+1 -> 'I_n}) :
  strictf f -> strictf (finfun (fun x => f (lift 0 x))).
Proof.
move/forallP => hf.
apply/forallP => /= x.
apply/forallP => /= y.
rewrite !ffunE.
move/forallP : (hf (lift 0 x)) => hf'.
by rewrite -(eqP (hf' (lift 0 y))).
Qed.

(* such a function is unique :
   two stricly increasing function with the same image are pointwise
   equal
*)
Lemma strictf_uniq : forall m n (f g: {ffun 'I_m -> 'I_n}),
  strictf f -> strictf g -> same_codom f g -> f = g.
Proof.
clear A B Z R k l.
elim => [ | m hi] n f g hf hg hsame; apply/ffunP; first by case.
move/forallP : (hf) => hf1.
move/forallP : (hg) => hg1.
rewrite [m.+1]/(1 + m)%nat => x.
case: (ltngtP (f 0) (g 0)) => h.
- have h1 : f 0 \in codom g by rewrite -hsame codom_f.
  have [x' heq] : { x' | f 0 = g x'} by exists (iinv h1); rewrite f_iinv.
  move: h; rewrite heq.
  move/forallP : (hg1 x') => hg'.
  by rewrite -(eqP (hg' 0)) ltn0.
- have h1 : g 0 \in codom f by rewrite hsame codom_f.
  have [x' heq] : { x' | g 0 = f x'} by exists (iinv h1); rewrite f_iinv.
  move: h; rewrite heq.
  move/forallP : (hf1 x') => hf'.
  by rewrite -(eqP (hf' 0)) ltn0.
case: (splitP x) => y.
- rewrite [y]ord1 => hy.
  have {x hy}-> : x = 0 by apply/ord_inj.
  by apply/ord_inj.
move => hy.
have {x hy}-> : x = lift 0 y by apply/ord_inj.
set f' := finfun (fun x => f (lift 0 x)).
set g' := finfun (fun x => g (lift 0 x)).
have hsame' : forall x, (x \in codom f') = (x \in codom g').
- move => z.
  apply/imageP/imageP.
  + case => /= a _; rewrite ffunE => hz.
    have : z \in codom g by rewrite -hsame hz codom_f.
    case/imageP; rewrite [m.+1]/(1 + m)%nat => x' _.
    case: (splitP x') => j.
    * rewrite [j]ord1 => hx'.
      have {x' hx'}-> : x' = 0 by apply/ord_inj.
      move => h'.
      have : f (lift 0 a) = f 0
        by apply/ord_inj; rewrite -hz h h'.
      by move/(inj_strictf hf).
    move => hx'.
    have {x' hx'}-> : x' = lift 0 j by apply/ord_inj.
    move => hz'.
    by exists j => //; rewrite ffunE.
  case => /= a _; rewrite ffunE => hz.
    have : z \in codom f by rewrite hsame hz codom_f.
    case/imageP; rewrite [m.+1]/(1 + m)%nat => x' _.
    case: (splitP x') => j.
    * rewrite [j]ord1 => hx'.
      have {x' hx'}-> : x' = 0 by apply/ord_inj.
      move => h'.
      have : g (lift 0 a) = g 0
        by apply/ord_inj; rewrite -hz -h h'.
      by move/(inj_strictf hg).
    move => hx'.
    have {x' hx'}-> : x' = lift 0 j by apply/ord_inj.
    move => hz'.
    by exists j => //; rewrite ffunE.
move/ffunP : (hi n f' g' (strictf_lift hf) (strictf_lift hg) hsame')
  => heq.
by move: (heq y); rewrite !ffunE => ->.
Qed.

Definition strict_from_f (fz :Z) :=
  if injectiveP fz.1 is ReflectT h then strict_from h else fz.1.

Lemma strict_from_fP (fz : Z) : injective fz.1 ->
  strictf (strict_from_f fz) /\ same_codom fz.1 (strict_from_f fz).
Proof.
move => hf.
rewrite /strict_from_f.
case: injectiveP => [hinj | []] //; exact: strict_fromP.
Qed.

Lemma BinetCauchy:
  \det (A *m B) = \sum_(f : {ffun 'I_k -> 'I_l} | strictf f)
                       (minor id f A * minor f id B).
Proof.
pose cond := fun fz : Z => injectiveb fz.1.
pose ffstrictf := fun (f: {ffun 'I_k -> 'I_l}) => strictf f.
rewrite detAB_weight (bigID cond) /= sum_bad addr0.
rewrite -gather_by_strictness (partition_big strict_from_f ffstrictf) /=.
- apply/eq_big => // g hg.
  apply/congr_big => //.
  case => f pi; rewrite /cond /good /=.
  apply/andP/andP; case => /injectiveP h1.
  + rewrite /strict_from_f /=.
    case: injectiveP => [hinj | []] //.
    move/eqP => heq; split => //.
    case: (strict_fromP hinj) => hlt hrt.
    apply/forallP => x.
    by rewrite -heq (hrt x).
  move/forallP => hsame.
  have hcodom : forall x, (x \in codom f) = (x \in codom g)
    by move => x; rewrite (eqP (hsame x)).
  split; first by apply/injectiveP.
  case: (@strict_from_fP (f,pi) h1) => hstrict hcodom2.
  rewrite (strictf_uniq hstrict hg) // => x.
  by rewrite -hcodom2 hcodom.
move => fz /injectiveP hf.
by case: (strict_from_fP hf).
Qed.

End BinetCauchy.


(** * Basic theory of complete lattices  *)

Require Export Setoid Morphisms.
Set Implicit Arguments.

(** * Class of complete lattices
    we require all operations rather than deriving them from least upper bounds:
    this way we can map them to the natural operations in the various instances *)

Class CompleteLattice (X: Type) := {
  weq: relation X;
  leq: relation X;
  (* sup: (I -> Prop) -> X; *)
  (* inf: (X -> Prop) -> X; *)
  sup': forall I, (I -> Prop) -> (I -> X) -> X;
  inf': forall I, (I -> Prop) -> (I -> X) -> X;
  cup: X -> X -> X;
  cap: X -> X -> X;
  bot: X;
  top: X;
  PreOrder_leq:> PreOrder leq;
  weq_spec: forall x y, weq x y <-> (leq x y /\ leq y x);
  (* sup_spec: forall P z, leq (sup P) z <-> forall x, P x -> leq x z; *)
  (* inf_spec: forall P z, leq z (inf P) <-> forall x, P x -> leq z x; *)
  sup_spec: forall I P f z, leq (@sup' I P f) z <-> forall i, P i -> leq (f i) z;
  inf_spec: forall I P f z, leq z (@inf' I P f) <-> forall i, P i -> leq z (f i);
  cup_spec: forall x y z, leq (cup x y) z <-> (leq x z /\ leq y z);
  cap_spec: forall x y z, leq z (cap x y) <-> (leq z x /\ leq z y);
  leq_bx: forall x, leq bot x;
  leq_xt: forall x, leq x top
                                  }.
Declare Scope lattice.
Open Scope lattice.
Infix "==" := weq (at level 70): lattice.
Infix "<=" := leq: lattice.
Notation sup P := (sup' P id).
Notation inf P := (inf' P id).
Global Hint Extern 0 => reflexivity: core.
Global Hint Resolve leq_bx leq_xt: core.

(** * Concrete instances *)

(** Prop is a complete lattice *)
#[export] Program Instance CompleteLattice_Prop: CompleteLattice Prop :=
  {| weq:=iff;
     leq:=Basics.impl;
     sup' I P f:=exists2 i, P i & f i;
     inf' I P f:=forall i, P i -> f i;
     cup:=or;
     cap:=and;
     bot:=False;
     top:=True |}.
Next Obligation. firstorder. Qed.
Next Obligation. firstorder. Qed.
Next Obligation. firstorder. Qed.
Next Obligation. firstorder. Qed.
Next Obligation. firstorder. Qed.
Next Obligation. firstorder. Qed.
Next Obligation. firstorder. Qed.

(** Dependent functions into complete lattices *)
Definition dpointwise_relation A (X: A -> Type) (R: forall {a}, relation (X a)): relation (forall a, X a)
  := fun f g => forall a, R (f a) (g a).
Arguments dpointwise_relation [_] {_} _ /.
Program Definition CompleteLattice_dfun A (X: A -> Type) (L: forall a, CompleteLattice (X a)): CompleteLattice (forall a, X a) :=
  {| weq := dpointwise_relation (fun _ => weq);
     leq := dpointwise_relation (fun _ => leq);
     sup' I P f a := sup' P (fun i => f i a);
     inf' I P f a := inf' P (fun i => f i a);
     cup f g a := cup (f a) (g a);
     cap f g a := cap (f a) (g a);
     bot a := bot;
     top a := top
  |}.
Next Obligation.
  constructor.
   now intros f x.
   intros f g h H H' x. now transitivity (g x).
Qed.
Next Obligation. setoid_rewrite weq_spec. firstorder. Qed.
Next Obligation. setoid_rewrite sup_spec. firstorder. Qed.
Next Obligation. setoid_rewrite inf_spec. firstorder. Qed.
Next Obligation. setoid_rewrite cup_spec. firstorder. Qed.
Next Obligation. setoid_rewrite cap_spec. firstorder. Qed.

(** Functions into a complete lattice *)
#[export] Instance CompleteLattice_fun {A X} {L: CompleteLattice X}: CompleteLattice (A -> X) :=
  CompleteLattice_dfun (fun _ => X) (fun _ => L).

(** Dual lattice *)
Program Definition Dual {X} {L: CompleteLattice X}: CompleteLattice X :=
  {| weq:=weq;
     leq x y :=leq y x;
     sup':=inf';
     inf':=sup';
     cup:=cap;
     cap:=cup;
     bot:=top;
     top:=bot
  |}.
Next Obligation. split. now intro. intros ? x ???. now transitivity x. Qed.
Next Obligation. rewrite weq_spec. tauto. Qed.
Next Obligation. apply inf_spec. Qed.
Next Obligation. apply sup_spec. Qed.
Next Obligation. apply cap_spec. Qed.
Next Obligation. apply cup_spec. Qed.

(** * Utilities  *)

(** tactics to solve goals by duality *)
Ltac dual t := apply (t _ (Dual)).

(** any monotone function preserves equality  *)
Lemma op_leq_weq_1 {X Y} {LX: CompleteLattice X} {LY: CompleteLattice Y} {f: X -> Y}
  {Hf: Proper (leq ==> leq) f}: Proper (weq ==> weq) f.
Proof. intros x y. rewrite 2weq_spec. intro E; split; apply Hf; apply E. Qed.

Lemma op_leq_weq_2 {X Y Z} {LX: CompleteLattice X} {LY: CompleteLattice Y} {LZ: CompleteLattice Z} {f: X -> Y -> Z}
  {Hf: Proper (leq ==> leq ==> leq) f}: Proper (weq ==> weq ==> weq) f.
Proof.
  intros x y E x' y' E'. rewrite weq_spec in E. rewrite weq_spec in E'.
  apply weq_spec. split; apply Hf; (apply E || apply E').
Qed.

(** * General properties of complete lattices *)

Section sup.
 Context {X} {L: CompleteLattice X}.

 (** Partial order *)
 Global Instance Equivalence_weq: Equivalence weq.
 Proof.
   constructor.
    intro x. now apply weq_spec.
    intros x y. rewrite 2weq_spec. tauto.
    intros x y z. rewrite 3weq_spec. split; transitivity y; tauto.
  Qed.
 Global Instance PartialOrder_weq_leq: PartialOrder weq leq.
 Proof.
   intros x y. simpl. now rewrite weq_spec.
 Qed.
 Lemma antisym x y: x <= y -> y <= x -> x == y.
 Proof. rewrite weq_spec. tauto. Qed.

 Lemma antisym' x y: x <= y -> (x <= y -> y <= x) -> x == y.
 Proof. intros. apply antisym; tauto. Qed.

 Lemma from_above x y: (forall z, x<=z <-> y<=z) -> x==y.
 Proof. intro E. apply antisym; apply E; reflexivity. Qed.

 Lemma from_below x y: (forall z, z<=x <-> z<=y) -> x==y.
 Proof. intro E. apply antisym; apply E; reflexivity. Qed.

 (** Least upper bounds *)
 Global Instance sup_leq I:
   Proper (leq ==> leq ==> leq) (sup' (I:=I)).
 Proof.
   intros P P' HP f f' Hf. apply sup_spec.
   intro i. rewrite (HP i), (Hf i).
   now apply sup_spec.
 Qed.
 Global Instance sup_weq I: Proper (weq ==> weq ==> weq) (sup' (I:=I)) := op_leq_weq_2.

 Lemma leq_xsup' I (P: I -> Prop) (f: I -> X) i: P i -> f i <= sup' P f.
 Proof. now apply sup_spec. Qed.
 Lemma leq_xsup (P: X -> Prop) x: P x -> x <= sup P.
 Proof. apply (leq_xsup' P id). Qed.

 Lemma eleq_xsup I (P: I -> Prop) (f: I -> X) i x: P i -> x <= f i -> x <= sup' P f.
 Proof. intros ? H. rewrite H. now apply leq_xsup'. Qed.

 Lemma sup_bot I (f: I -> X): sup' bot f == bot.
 Proof. apply antisym. now apply sup_spec. apply leq_bx. Qed.
 Lemma sup_single I (f: I -> X) i: sup' (eq i) f == f i.
 Proof. apply antisym. apply sup_spec. now intros ? <-. now apply leq_xsup'. Qed.
 Lemma sup_top: sup top == top.
 Proof. apply antisym. apply leq_xt. now apply leq_xsup. Qed.

 (** Binary join *)
 Lemma leq_xcup x y z: z <= x \/ z <= y -> z <= cup x y.
 Proof.
   destruct (cup_spec x y (cup x y)) as [H _].
   now intros [E|E]; rewrite E; apply H.
 Qed.
 Lemma cup_l x y: x <= cup x y.
 Proof. auto using leq_xcup. Qed.
 Lemma cup_r x y: y <= cup x y.
 Proof. auto using leq_xcup. Qed.

 Lemma cupA x y z: cup x (cup y z) == cup (cup x y) z.
 Proof. apply from_above. intro. rewrite 4cup_spec. tauto. Qed.
 Lemma cupC x y: cup x y == cup y x.
 Proof. apply from_above. intro. rewrite 2cup_spec. tauto. Qed.
 Lemma cupI x: cup x x == x.
 Proof. apply from_above. intro. rewrite cup_spec. tauto. Qed.
 Lemma cupbx x: cup bot x == x.
 Proof. apply antisym. apply cup_spec. now split. apply cup_r. Qed.
 Lemma cupxb x: cup x bot == x.
 Proof. rewrite cupC. apply cupbx. Qed.
 Lemma cuptx x: cup top x == top.
 Proof. apply antisym. apply leq_xt. apply cup_l. Qed.
 Lemma cupxt x: cup x top == top.
 Proof. rewrite cupC. apply cuptx. Qed.

 Global Instance cup_leq: Proper (leq ==> leq ==> leq) cup.
 Proof.
   intros x x' Hx y y' Hy.
   apply cup_spec. rewrite Hx, Hy.
   now apply cup_spec.
 Qed.
 Global Instance cup_weq: Proper (weq ==> weq ==> weq) cup := op_leq_weq_2.

End sup.
Global Hint Resolve cup_l cup_r: core.

Section sup_cup.
 Context {X} {L: CompleteLattice X}.
 Lemma sup_cup I (f: I -> X) P Q: sup' (cup P Q) f == cup (sup' P f) (sup' Q f).
 Proof.
   apply antisym. apply sup_spec. intros i [H|H]; apply leq_xcup.
   now left; apply leq_xsup'.
   now right; apply leq_xsup'.
   apply cup_spec. now split; apply sup_leq.
 Qed.
End sup_cup.

(** * Properties obtained by duality *)
Section inf.
 Context {X} {L: CompleteLattice X}.

 (** Greatest lower bounds *)
 Global Instance inf_leq I:
   Proper (leq --> leq ==> leq) (inf' (I:=I)).
 Proof. intros ??????. now dual @sup_leq. Qed.
 Global Instance inf_weq I: Proper (weq ==> weq ==> weq) (inf' (I:=I)).
 Proof. apply (@sup_weq _ (@Dual _ L)). Qed.

 Lemma leq_infx' I (P: I -> Prop) (f: I -> X) i: P i -> inf' P f <= f i.
 Proof. dual @leq_xsup'. Qed.
 Lemma leq_infx (P: X -> Prop) x: P x -> inf P <= x.
 Proof. dual @leq_xsup. Qed.
 Lemma eleq_infx I (P: I -> Prop) (f: I -> X) i x: P i -> f i <= x -> inf' P f <= x.
 Proof. dual @eleq_xsup. Qed.

 Lemma inf_bot I (f: I -> X): inf' bot f == top.
 Proof. dual @sup_bot. Qed.
 Lemma inf_single I (f: I -> X) i: inf' (eq i) f == f i.
 Proof. dual @sup_single. Qed.
 Lemma inf_cup I (f: I -> X) P Q: inf' (cup P Q) f == cap (inf' P f) (inf' Q f).
 Proof. dual @sup_cup. Qed.
 Lemma inf_top: inf top == bot.
 Proof. dual @sup_top. Qed.

 (** Binary meet *)
 Lemma leq_capx x y z: x <= z \/ y <= z -> cap x y <= z.
 Proof. dual @leq_xcup. Qed.
 Lemma cap_l x y: cap x y <= x.
 Proof. dual @cup_l. Qed.
 Lemma cap_r x y: cap x y <= y.
 Proof. dual @cup_r. Qed.

 Lemma capA x y z: cap x (cap y z) == cap (cap x y) z.
 Proof. dual @cupA. Qed.
 Lemma capC x y: cap x y == cap y x.
 Proof. dual @cupC. Qed.
 Lemma capI x: cap x x == x.
 Proof. dual @cupI. Qed.
 Lemma captx x: cap top x == x.
 Proof. dual @cupbx. Qed.
 Lemma capxt x: cap x top == x.
 Proof. dual @cupxb. Qed.
 Lemma capbx x: cap bot x == bot.
 Proof. dual @cuptx. Qed.
 Lemma capxb x: cap x bot == bot.
 Proof. dual @cupxt. Qed.

 Global Instance cap_leq: Proper (leq ==> leq ==> leq) cap.
 Proof. intros ??????. now dual @cup_leq. Qed.
 Global Instance cap_weq: Proper (weq ==> weq ==> weq) cap := op_leq_weq_2.

End inf.
Global Hint Resolve cap_l cap_r: core.

(** * The complete lattice of monotone endofunctions *)

Section mon.
 Context {X} {L: CompleteLattice X}.

 (** monotone endofunctions *)
 Record mon := { body:> X -> X; Hbody: Proper (leq ==> leq) body }.

 (** the following instances are not global: more powerful ones are
    given at the end of the section *)
 Existing Instance Hbody.
 Instance Hbody' (f: mon): Proper (weq ==> weq) f.
 Proof. intros x y. rewrite 2weq_spec. now split; apply f. Qed.

 (** constant function *)
 Program Definition const x: mon := {| body y := x |}.
 Next Obligation. intros ? ? ?. reflexivity. Qed.

 (** identity and composition
     the monotonicity proofs are transparent to get strong equalities
     - [id ° f = f ° id = f], and
     - [f ° (g ° h) = (f ° g) ° h]
  *)
 Definition id: mon := {|
   body x := x;
   Hbody x y H := H
 |}.

 Definition comp (f g: mon): mon := {|
   body := fun x => f (g x);
   Hbody x y H := Hbody f _ _ (Hbody g _ _ H)
 |}.
 Infix "°" := comp (at level 20): lattice.

 (** monotone endofunctions form a new complete lattice *)
 Global Program Instance CompleteLattice_mon: CompleteLattice mon := {|
   weq := pointwise_relation X weq;
   leq := pointwise_relation X leq;
   sup' I P f := {| body := fun x => sup' P (fun i => f i x) |};
   inf' I P f := {| body := fun x => inf' P (fun i => f i x) |};
   cup f g := {| body := fun x => cup (f x) (g x) |};
   cap f g := {| body := fun x => cap (f x) (g x) |};
   bot := const bot;
   top := const top
 |}.
 Next Obligation.
   intros x y H. apply sup_spec. intros i Hi.
   rewrite H. eapply eleq_xsup; eauto.
 Qed.
 Next Obligation.
   intros x y H. apply inf_spec. intros i Hi.
   rewrite <-H. eapply eleq_infx; eauto.
 Qed.
 Next Obligation. intros x y H. now rewrite H. Qed.
 Next Obligation. intros x y H. now rewrite H. Qed.
 Next Obligation. constructor. now intros f x. intros f g h H H' x. now transitivity (g x). Qed.
 Next Obligation. unfold pointwise_relation. setoid_rewrite weq_spec. firstorder. Qed.
 Next Obligation. unfold pointwise_relation. setoid_rewrite sup_spec. firstorder. Qed.
 Next Obligation. unfold pointwise_relation. setoid_rewrite inf_spec. firstorder. Qed.
 Next Obligation. unfold pointwise_relation. setoid_rewrite cup_spec. firstorder. Qed.
 Next Obligation. unfold pointwise_relation. setoid_rewrite cap_spec. firstorder. Qed.
 Next Obligation. intro. apply leq_bx. Qed.
 Next Obligation. intro. apply leq_xt. Qed.

 Global Instance comp_leq: Proper (leq ==> leq ==> leq) comp.
 Proof. intros f f' Hf g g' Hg x. simpl. rewrite (Hg x). apply Hf. Qed.
 Global Instance comp_weq: Proper (weq ==> weq ==> weq) comp := op_leq_weq_2.

 (** trivial properties of composition *)
 Lemma compA f g h: f ° (g ° h) = (f ° g) ° h.
 Proof. reflexivity. Qed.
 Lemma compIx f: id ° f = f.
 Proof. now case f. Qed.
 Lemma compxI f: f ° id = f.
 Proof. now case f. Qed.

 (** monotone functions applied to infs/sups *)
 Lemma mon_sup I (g: I -> X) (f: mon) P: sup' P (fun x => f (g x)) <= f (sup' P g).
 Proof. apply sup_spec. intros. apply f. now apply leq_xsup'. Qed.
 Lemma mon_cup (f: mon) x y: cup (f x) (f y) <= f (cup x y).
 Proof. apply cup_spec; split; apply f; auto. Qed.
 Lemma mon_inf I (g: I -> X) (f: mon) P: f (inf' P g) <= inf' P (fun x => f (g x)).
 Proof. apply inf_spec. intros. apply f. now apply leq_infx'. Qed.
 Lemma mon_cap (f: mon) x y: f (cap x y) <= cap (f x) (f y).
 Proof. apply cap_spec; split; apply f; auto. Qed.

 (** operations on [mon X] behave as expected on the left of compositions *)
 Lemma msup_o I f P h: sup' P f ° h == sup' P (fun i: I => (f i) ° h).
 Proof. now intro. Qed.
 Lemma mcup_o f g h: (cup f g) ° h == cup (f ° h) (g ° h).
 Proof. now intro. Qed.
 Lemma mbot_o f: bot ° f == bot.
 Proof. now intro. Qed.
 Lemma minf_o I f P h: inf' P f ° h == inf' P (fun i: I => (f i) ° h).
 Proof. now intro. Qed.
 Lemma mcap_o f g h: (cap f g) ° h == cap (f ° h) (g ° h).
 Proof. now intro. Qed.
 Lemma mtop_o f: top ° f == top.
 Proof. now intro. Qed.

 (** instead, only one inclusion holds in general when they are on the left *)
 Lemma o_msup I f P h: sup' P (fun i: I => h ° (f i)) <= h ° sup' P f.
 Proof. intro. apply sup_spec. intros. apply h. eapply eleq_xsup; eauto. Qed.
 Lemma o_mcup h f g: cup (h ° f) (h ° g) <= h ° (cup f g).
 Proof. intro. apply (mon_cup h). Qed.
 Lemma o_minf I f P h: h ° inf' P f <= inf' P (fun i: I => h ° (f i)).
 Proof. intro. apply inf_spec. intros. apply h. eapply eleq_infx; eauto. Qed.
 Lemma o_mcap h f g: h ° (cap f g) <= cap (h ° f) (h ° g).
 Proof. intro. apply (mon_cap h). Qed.

End mon.
Arguments mon X {L}.
Infix "°" := comp (at level 20): lattice.
Global Opaque cup bot cap top.  (* TODO: check that we still need this *)

(** application as a function [X->X]->X->X is monotone in its two arguments *)
#[export] Instance app_leq {X} {L: CompleteLattice X}: Proper (leq ==> leq ==> leq) body.
Proof. intros f g fg x y xy. transitivity (f y). now apply f. now apply fg. Qed.
#[export] Instance app_weq {X} {L: CompleteLattice X}: Proper (weq ==> weq ==> weq) body := op_leq_weq_2.

(** * Involutions *)

Section involutions.

 Context {X} {L: CompleteLattice X} {i: mon X}.

 Class Involution := invol: i ° i == id.

 Context {I: Involution}.

 Lemma invol' x: i (i x) == x.
 Proof. apply invol. Qed.

 Lemma switch x y: i x <= y <-> x <= i y.
 Proof. split; (intro H; apply i in H; now rewrite invol' in H). Qed.

 Lemma Switch f g: i ° f <= g <-> f <= i ° g.
 Proof. split; (intros H x; apply switch, H). Qed.

 Lemma invol_fixed x: i x <= x <-> i x == x.
 Proof.
   split; intro H. apply antisym'; trivial. apply switch.
   now apply weq_spec in H.
 Qed.

 (* TODO: should follow from general adjoint theory since [i -| i] *)
 Lemma invol_bot: i bot == bot.
 Proof. apply antisym; trivial. now apply switch. Qed.
 Lemma invol_cup x y: i (cup x y) == cup (i x) (i y).
 Proof.
   apply antisym. 2: apply mon_cup.
   apply switch. now rewrite <-mon_cup, 2invol'.
 Qed.
 Lemma invol_sup A (f: A -> X) P: i (sup' P f) == sup' P (fun x => i (f x)).
 Proof.
   apply antisym. 2: apply mon_sup.
   apply switch. rewrite <-mon_sup.
   apply sup_leq; trivial. intro.
   now rewrite invol'.
 Qed.
 Lemma invol_top: i top == top.
 Proof. apply antisym; trivial. now apply switch. Qed.
 Lemma invol_cap x y: i (cap x y) == cap (i x) (i y).
 Proof.
   apply antisym. apply mon_cap.
   apply switch. now rewrite mon_cap, 2invol'.
 Qed.
 Lemma invol_inf A (f: A -> X) P: i (inf' P f) == inf' P (fun x => i (f x)).
 Proof.
   apply antisym. apply mon_inf.
   apply switch. rewrite mon_inf.
   apply inf_leq; trivial. intro.
   now rewrite invol'.
 Qed.
End involutions.
Arguments Involution {_ _} _.


Require Import CContext.

(* We are going to take advantage of extensive syntactical sugaring in C to develop a set of core types which all other types can be derived from.

  Using this, we hope to significantly reduce the footprint of our proofs.  We define below a core set of types which all other types can be interpreted as syntactical sugar of.
 **)

(*
  Our principle goal with our typing system is to provide
  flexibility for future extensions.

  Some notes: we define a pointer based on its underlying reference
  We define a struct based on the subfields it contains
**)
Inductive CCore_Type :=
| void
| number (width: nat) (signed: bool)
| pointer (len: nat) (ref: CCore_Type)
| struct (fields: list CCore_Type).

Inductive CType :=
| unsigned_int
| int
| signed_char
| char
| short
| unsigned_short
| long_unsigned
| long_signed
| array (len: nat) (ref: CType)
| bool.

(* TODO: Add integer width **)
Fixpoint reduce_type_sugaring (t: CType): CCore_Type :=
  match t with
  | unsigned_int => number 4 false
  | int => number 4 true
  | signed_char => number 1 true
  | char => number 1 false
  | short => number 2 true
  | unsigned_short => number 2 false
  | long_unsigned => number 8 false
  | long_signed => number 8 true
  | array len ref => pointer len (reduce_type_sugaring ref)
  | bool => number 1 false
  end.


Require Import ZF.
Require Import ZFpairs ZFrelations ZFord ZFfix ZFiso.
Require Import ZFnest ZFspos.

(* Simply nested inductive *)

Section NestedInductive.

  Variable Fop : set -> set -> set.
  Hypothesis Fop_mono : Proper (incl_set==>incl_set==>incl_set) Fop.

(** F(X,Y): Y is the nested type with (uniform) parameter X *)

(* F(X,Y) iso { x:A | B x -> X & C x -> Y } *)
Hypothesis A : set.
Hypothesis B : set -> set.
Hypothesis C : set -> set.
Hypothesis Bm : morph1 B.
Hypothesis Cm : morph1 C.
Hypothesis h : set -> set.
Hypothesis hm : morph1 h.
Hypothesis hiso : forall X Y, iso_fun (Fop X Y) (F A B C X Y) h.

Definition nest_pos (o:set) : positive :=
  mkPositive (fun X => TI (fun Y => Fop X Y) o) (A'i A C o) (B' A B C) (nest_trad A B C h o).

Lemma isPos_nest o :
  isOrd o ->
  isPositive (nest_pos o).
constructor.
 do 2 red; intros.
 simpl.
 apply TI_op_mono; auto with *; apply Fmono_morph;
   do 2 red; intros; apply Fop_mono; auto with *.

 do 2 red; intros; simpl.
 apply B'm; trivial.

 simpl; intros.
 apply nest_iso_it; trivial.
 intros; apply Fop_mono.
 reflexivity.
Qed.

End NestedInductive.

Print Assumptions isPos_nest.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal33.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj15eqsynthconj1_hyp: forall  (lv0 : natural) (lv1 : natural) (lv2 : natural), (@eq natural (plus (mult lv0 lv2) lv0) (mult lv0 lv1)) ->  (@eq natural (plus (mult lv0 lv1) lv2) (plus lv2 (mult lv0 (Succ lv2)))).
Admitted.
QuickChick conj15eqsynthconj1_hyp.


(* Copyright (c) 2022, choukh <choukyuhei@gmail.com> *)

Require Import GOO.Ordinal.Ord.
Require Import GOO.Ordinal.Recursion.
Require Import GOO.Ordinal.Iteration.
Require Import GOO.Ordinal.VeblenFunction.
Require Import GOO.Ordinal.ExtendedVeblenFunction.

Local Open Scope 序数域.

Notation ω元φ := ExtendedVeblenFunction.φ.
Notation ω增元迭代 := ExtendedVeblenFunction.增元迭代.

Notation ω元 := (∀ n, 多元 (S n) 序数).
Notation ω后继元 n := (多元 n (ω元)).
Notation ω2元 := (∀ n, ω后继元 (S n)).

Module ω加一元.

Fixpoint 跳出 (F : ω元) α n : 多元 (S n) 序数 := match α with
  | ∅ => F n
  | α⁺ =>
    let G₀ := lim (λ n, 跳出 F α n [1] ∅..) in
    let G := λ β, lim (λ n, 跳出 F α n β⁺ ∅..) in
    ω增元迭代 (递归 G G₀) n
  | lim f =>
    let G₀ := lim (λ n, 跳出 F (f n) 0 ∅) in
    let G := λ β, lim (λ n, 跳出 F (f n) 0 β⁺) in
    ω增元迭代 (递归 G G₀) n
  end.

Definition φ := 跳出 ω元φ.

Fact φ_z_X : ∀ n, φ ∅ n = ω元φ n.
Proof. reflexivity. Qed.

Theorem φ_x_n_Z : ∀ α n, φ α n ∅.. = φ α 0 ∅.
Proof.
  intros. destruct α.
  - induction n. reflexivity. rewrite φ_z_X in *. simpl.
    rewrite ExtendedVeblenFunction.φ_z_X, <- f_Z_eq_f_z_Z, IHn. reflexivity.
  - unfold φ, 跳出. rewrite f_Z_eq_f_Z_z, 增元迭代_Z_x. reflexivity.
  - unfold φ, 跳出. rewrite f_Z_eq_f_Z_z, 增元迭代_Z_x. reflexivity.
Qed.

Fact φ_1_Z : φ [1] 0 ∅ = SVO.
Proof. reflexivity. Qed.

Fact φ_s_Z : ∀ α, φ α⁺ 0 ∅ = lim (λ n, φ α n [1] ∅..).
Proof. reflexivity. Qed.

Fact φ_1_Z_1 : φ [1] 0 [1] = lim (λ n, ω元φ n SVO⁺ ∅..).
Proof. reflexivity. Qed.

Fact φ_s_Z_1 : ∀ α, φ α⁺ 0 [1] = lim (λ n, φ α n (φ α⁺ 0 ∅)⁺ ∅..).
Proof. reflexivity. Qed.

Fact φ_s_Z_s : ∀ α β, φ α⁺ 0 β⁺ = lim (λ n, φ α n (φ α⁺ 0 β)⁺ ∅..).
Proof. reflexivity. Qed.

Fact φ_s_Z_l : ∀ α f, φ α⁺ 0 (lim f) = lim (λ n, φ α⁺ 0 (f n)).
Proof. reflexivity. Qed.

Fact φ_s_Z_1_z : ∀ α, φ α⁺ 1 [1] ∅ = Itω (φ α⁺ 0) ∅.
Proof. reflexivity. Qed.

Fact φ_s_Z_1_x : ∀ α, φ α⁺ 1 [1] = (φ α⁺ 0)′.
Proof. reflexivity. Qed.

Fact φ_x_Z_s_y : ∀ α β, φ α⁺ 1 β⁺ = (φ α⁺ 1 β)′.
Proof. reflexivity. Qed.

Fact φ_x_Z_l_z : ∀ α f, φ α⁺ 1 (lim f) ∅ = lim (λ n, φ α⁺ 1 (f n) ∅).
Proof. reflexivity. Qed.

Fact φ_x_Z_l_s : ∀ α f β, φ α⁺ 1 (lim f) β⁺ = lim (λ n, φ α⁺ 1 (f n) (φ α⁺ 1 (lim f) β)⁺).
Proof. reflexivity. Qed.

Fact φ_x_Z_l_l : ∀ α f g, φ α⁺ 1 (lim f) (lim g) = lim (λ n, φ α⁺ 1 (lim f) (g n)).
Proof. reflexivity. Qed.

Fact φ_l_Z : ∀ f, φ (lim f) 0 ∅ = lim (λ n, φ (f n) 0 ∅).
Proof. reflexivity. Qed.

Fact φ_l_Z_1 : ∀ f, φ (lim f) 0 [1] = lim (λ n, φ (f n) 0 (φ (lim f) 0 ∅)⁺).
Proof. reflexivity. Qed.

Fact φ_l_Z_s : ∀ f α, φ (lim f) 0 α⁺ = lim (λ n, φ (f n) 0 (φ (lim f) 0 α)⁺).
Proof. reflexivity. Qed.

Fact φ_l_Z_l : ∀ f g, φ (lim f) 0 (lim g) = lim (λ n, φ (lim f) 0 (g n)).
Proof. reflexivity. Qed.

Fact φ_l_Z_1_0 : ∀ f, φ (lim f) 1 [1] ∅ = Itω (φ (lim f) 0) ∅.
Proof. reflexivity. Qed.

Fact φ_l_Z_1_x : ∀ f, φ (lim f) 1 [1] = (φ (lim f) 0)′.
Proof. reflexivity. Qed.

Fact φ_l_Z_s_x : ∀ f α, φ (lim f) 1 α⁺ = (φ (lim f) 1 α)′.
Proof. reflexivity. Qed.

Fact φ_l_Z_l_z : ∀ f g, φ (lim f) 1 (lim g) ∅ = lim (λ n, φ (lim f) 1 (g n) ∅).
Proof. reflexivity. Qed.

Fact φ_l_Z_l_s : ∀ f g α, φ (lim f) 1 (lim g) α⁺ = lim (λ n, φ (lim f) 1 (g n) (φ (lim f) 1 (lim g) α)⁺).
Proof. reflexivity. Qed.

Fact φ_l_Z_l_l : ∀ f g h, φ (lim f) 1 (lim g) (lim h) = lim (λ n, φ (lim f) 1 (lim g) (h n)).
Proof. reflexivity. Qed.

Theorem φ_s_Z_s_Z_x : ∀ α n β x, φ α⁺ (S n) β⁺ ∅.._ x = (λ ξ, φ α⁺ (S n) β ξ ∅..)′ x.
Proof. intros. unfold φ, 跳出, 增元迭代. rewrite veblen_s_Z_x. reflexivity. Qed.

Theorem φ_s_Z_l_Z_x : ∀ α n f, φ α⁺ (S n) (lim f) ∅.._ =
  递归 (λ ξ, lim (λ m, φ α⁺ (S n) (f m) ξ⁺ ∅..)) (lim (λ m, φ α⁺ (S n) (f m) ∅ ∅..)).
Proof. intros. unfold φ, 跳出, 增元迭代. rewrite veblen_l_Z_x. reflexivity. Qed.

Corollary φ_s_Z_l_Z_z : ∀ α n f, φ α⁺ n (lim f) ∅.. = lim (λ m, φ α⁺ n (f m) ∅..).
Proof. intros. destruct n. reflexivity. rewrite f_Z_eq_f_Z_z, φ_s_Z_l_Z_x. reflexivity. Qed.

Corollary φ_s_Z_l_Z_s : ∀ α n f β, φ α⁺ (S n) (lim f) ∅.._ β⁺ =
  lim (λ m, φ α⁺ (S n) (f m) (φ α⁺ (S n) (lim f) ∅.._ β)⁺ ∅..).
Proof. intros. rewrite φ_s_Z_l_Z_x. reflexivity. Qed.

Corollary φ_s_Z_l_Z_l : ∀ α n f g, φ α⁺ (S n) (lim f) ∅.._ (lim g) =
  lim (λ m, φ α⁺ (S n) (lim f) ∅.._ (g m)).
Proof. intros. rewrite φ_s_Z_l_Z_x. reflexivity. Qed.

Theorem φ_l_Z_s_Z_x : ∀ f n α x, φ (lim f) (S n) α⁺ ∅.._ x = (λ ξ, φ (lim f) (S n) α ξ ∅..)′ x.
Proof. intros. unfold φ, 跳出, 增元迭代. rewrite veblen_s_Z_x. reflexivity. Qed.

Theorem φ_l_Z_l_Z_x : ∀ f n g, φ (lim f) (S n) (lim g) ∅.._ =
  递归 (λ ξ, lim (λ m, φ (lim f) (S n) (g m) ξ⁺ ∅..)) (lim (λ m, φ (lim f) (S n) (g m) ∅ ∅..)).
Proof. intros. unfold φ, 跳出, 增元迭代. rewrite veblen_l_Z_x. reflexivity. Qed.

Corollary φ_l_Z_l_Z_z : ∀ f n g, φ (lim f) n (lim g) ∅.. = lim (λ m, φ (lim f) n (g m) ∅..).
Proof. intros. destruct n. reflexivity. rewrite f_Z_eq_f_Z_z, φ_l_Z_l_Z_x. reflexivity. Qed.

Corollary φ_l_Z_l_Z_s : ∀ f n g α, φ (lim f) (S n) (lim g) ∅.._ α⁺ =
  lim (λ m, φ (lim f) (S n) (g m) (φ (lim f) (S n) (lim g) ∅.._ α)⁺ ∅..).
Proof. intros. rewrite φ_l_Z_l_Z_x. reflexivity. Qed.

Corollary φ_l_Z_l_Z_l : ∀ f n g h, φ (lim f) (S n) (lim g) ∅.._ (lim h) =
  lim (λ m, φ (lim f) (S n) (lim g) ∅.._ (h m)).
Proof. intros. rewrite φ_l_Z_l_Z_x. reflexivity. Qed.

Example φ_sω_Z : φ ω⁺ 0 ∅ = lim (λ n, φ ω n [1] ∅..).
Proof. reflexivity. Qed.

Example φ_φωZ_Z : φ (φ [1] 0 ∅) 0 ∅ = lim (λ n, φ (ω元φ n [1] ∅..) 0 ∅).
Proof. reflexivity. Qed.

End ω加一元.

Module ω加二元.

Fixpoint veblen (F : 序数 → ω元) (α : 序数) : 序数 → ω元.
  destruct α as [|α|f].
  - apply F.
  - set (增元迭代 (λ β, veblen F α β 0 ∅)′) as ω元F.
    apply (ω加一元.跳出 ω元F).
  - set (lim (λ m, veblen F (f m) ∅ 0 ∅)) as G₀.
    set (λ β, lim (λ m, veblen F (f m) β⁺ 0 ∅)) as G.
    set (增元迭代 (递归 G G₀)) as ω元F.
    apply (ω加一元.跳出 ω元F).
Defined.

Definition φ := veblen (ω加一元.φ).

Fact φ_z_X : φ ∅ = ω加一元.φ.
Proof. reflexivity. Qed.

Fact φ_1_Z : φ [1] ∅ 0 ∅ = Itω (λ ξ, φ ∅ ξ 0 ∅) ∅.
Proof. reflexivity. Qed.

Fact φ_1_Z_x : φ [1] ∅ 0 = (λ β, φ ∅ β 0 ∅)′.
Proof. reflexivity. Qed.

Fact φ_s_Z_x : ∀ α, φ α⁺ ∅ 0 = (λ β, φ α β 0 ∅)′.
Proof. reflexivity. Qed.

Fact φ_l_Z_x : ∀ f, φ (lim f) ∅ 0 =
  递归 (λ ξ, lim (λ m, φ (f m) ξ⁺ 0 ∅)) (lim (λ m, φ (f m) ∅ 0 ∅)).
Proof. reflexivity. Qed.

Fact φ_x_s_Z : ∀ α β, φ α β⁺ 0 ∅ = lim (λ n, φ α β n [1] ∅..).
Proof. destruct α; reflexivity. Qed.

Fact φ_x_s_Z_s : ∀ α β γ, φ α β⁺ 0 γ⁺ = lim (λ n, φ α β n (φ α β⁺ 0 γ)⁺ ∅..).
Proof. destruct α; reflexivity. Qed.

Fact φ_x_s_Z_l : ∀ α β f, φ α β⁺ 0 (lim f) = lim (λ n, φ α β⁺ 0 (f n)).
Proof. destruct α; reflexivity. Qed.

Fact φ_x_l_Z : ∀ α f, φ α (lim f) 0 ∅ = lim (λ n, φ α (f n) 0 ∅).
Proof. destruct α; reflexivity. Qed.

Fact φ_x_l_Z_1 : ∀ α f, φ α (lim f) 0 [1] = lim (λ n, φ α (f n) 0 (φ α (lim f) 0 ∅)⁺).
Proof. destruct α; reflexivity. Qed.

Fact φ_x_l_Z_s : ∀ α f β, φ α (lim f) 0 β⁺ = lim (λ n, φ α (f n) 0 (φ α (lim f) 0 β)⁺).
Proof. destruct α; reflexivity. Qed.

End ω加二元.

Module ω2元.

Fixpoint veblen {n} : ω后继元 (S n) → ω后继元 (S (S n)).
  set (fix 增元迭代 (F : ω后继元 1) n : ω后继元 (S n) :=
    match n with
    | O => F
    | S n => veblen n (增元迭代 F n)
    end) as 增元迭代.
  refine (fix inner (F : ω后继元 (S n)) (α : 序数) : ω后继元 (S n) := _).
  destruct α as [|α|g].
  - apply F.
  - set (ω增元迭代 (λ β, inner F α β ∅.. 0 ∅)′) as ω元F.
    apply (增元迭代 (ω加一元.跳出 ω元F) n).
  - set (lim (λ m, inner F (g m) ∅.. 0 ∅)) as G₀.
    set (λ β, lim (λ m, inner F (g m) β⁺ ∅.. 0 ∅)) as G.
    set (ω增元迭代 (递归 G G₀)) as ω元F.
    apply (增元迭代 (ω加一元.跳出 ω元F) n).
Defined.

Fixpoint 增元迭代 F n : ω后继元 (S n) :=
  match n with
    | O => F
    | S m => veblen (增元迭代 F m)
  end.

Definition φ := 增元迭代 (ω加一元.φ).

Lemma veblen_z : ∀ n (F : ω后继元 (S n)), veblen F ∅ = F.
Proof. destruct n; reflexivity. Qed.

Lemma 增元迭代_Z_x__X : ∀ F n, (增元迭代 F n) ∅.._ = F.
Proof.
  intros. induction n. reflexivity.
  simpl. rewrite veblen_z. easy.
Qed.

Lemma veblen_s_Z_x : ∀ n (F : ω后继元 (S n)) α,
  veblen F α⁺ ∅ ∅.. 0 = (λ β, veblen F α β ∅.. 0 ∅)′.
Proof.
  intros. destruct n. reflexivity.
  simpl. rewrite veblen_z, <- f_Z_eq_f_z_Z, f_Z_eq_f_Z_z.
  rewrite 增元迭代_Z_x__X. reflexivity.
Qed.

Lemma veblen_l_Z_x : ∀ n (F : ω后继元 (S n)) f, veblen F (lim f) ∅ ∅.. 0 =
  递归 (λ ξ, lim (λ m, veblen F (f m) ξ⁺ ∅.. 0 ∅)) (lim (λ m, veblen F (f m) ∅ ∅.. 0 ∅)).
Proof.
  intros. destruct n. reflexivity.
  simpl. rewrite veblen_z, <- f_Z_eq_f_z_Z, f_Z_eq_f_Z_z.
  rewrite 增元迭代_Z_x__X. reflexivity.
Qed.

Lemma 增元迭代_x_s_Z_y : ∀ n F α β, 增元迭代 F (S (S n)) α β⁺ ∅ ∅.. 0 =
  (λ γ, 增元迭代 F (S (S n)) α β γ ∅.. 0 ∅)′.
Proof.
  intros. destruct α.
  - simpl. rewrite veblen_s_Z_x. reflexivity.
  - unfold 增元迭代. simpl. rewrite veblen_s_Z_x. reflexivity.
  - unfold 增元迭代. simpl. rewrite veblen_s_Z_x. reflexivity.
Qed.

Lemma 增元迭代_x_l_Z_y : ∀ n F α f, 增元迭代 F (S (S n)) α (lim f) ∅ ∅.. 0 =
  递归 (λ ξ, lim (λ m, 增元迭代 F (S (S n)) α (f m) ξ⁺ ∅.. 0 ∅)) (lim (λ m, 增元迭代 F (S (S n)) α (f m) ∅ ∅.. 0 ∅)).
Proof.
  intros. destruct α.
  - simpl. rewrite veblen_l_Z_x. reflexivity.
  - unfold 增元迭代. simpl. rewrite veblen_l_Z_x. reflexivity.
  - unfold 增元迭代. simpl. rewrite veblen_l_Z_x. reflexivity.
Qed.

Lemma 增元迭代_Z__Z_s_x : ∀ F n α,
  veblen (增元迭代 (ω加一元.跳出 (ω增元迭代 F)) n) ∅.. 1 α⁺ =
  (veblen (增元迭代 (ω加一元.跳出 (ω增元迭代 F)) n) ∅.. 1 α)′.
Proof.
  intros. induction n. reflexivity.
  simpl in *. rewrite IHn. reflexivity.
Qed.

Lemma veblen_s_Z__Z_s_x : ∀ n (F : ω后继元 (S n)) α β,
  veblen F α⁺ ∅ ∅.. 1 β⁺ = (veblen F α⁺ ∅ ∅.. 1 β)′.
Proof.
  intros. destruct n. reflexivity. simpl.
  rewrite <- f_Z_eq_f_z_Z, <- f_Z_eq_f_z_Z, 增元迭代_Z__Z_s_x. reflexivity.
Qed.

Lemma veblen_l_Z__Z_s_x : ∀ n (F : ω后继元 (S n)) f α,
  veblen F (lim f) ∅ ∅.. 1 α⁺ = (veblen F (lim f) ∅ ∅.. 1 α)′.
Proof.
  intros. destruct n. reflexivity. simpl.
  rewrite <- f_Z_eq_f_z_Z, <- f_Z_eq_f_z_Z, 增元迭代_Z__Z_s_x. reflexivity.
Qed.

Lemma 增元迭代_x_Z__Z_s_y : ∀ n α β,
  增元迭代 (ω加一元.φ) n α ∅.. 1 β⁺ = (增元迭代 (ω加一元.φ) n α ∅.. 1 β)′.
Proof.
  intros. destruct α.
  - induction n. reflexivity. simpl. rewrite veblen_z. apply IHn.
  - unfold 增元迭代. destruct n. reflexivity.
    rewrite f_Z_eq_f_z_Z, veblen_s_Z__Z_s_x. reflexivity.
  - unfold 增元迭代. destruct n. reflexivity.
    rewrite f_Z_eq_f_z_Z, veblen_l_Z__Z_s_x. reflexivity.
Qed.

Lemma 增元迭代_Z__Z_l_x : ∀ F n f,
  let G := veblen (增元迭代 (ω加一元.跳出 (ω增元迭代 F)) n) ∅.. 1 in
  G (lim f) = 递归 (λ ξ, lim (λ m, G (f m) ξ⁺)) (lim (λ m, G (f m) ∅)).
Proof.
  intros. unfold G. induction n. reflexivity.
  simpl in *. rewrite IHn. reflexivity.
Qed.

Lemma veblen_s_Z__Z_l_x : ∀ n (F : ω后继元 (S n)) α f,
  let G := veblen F α⁺ ∅ ∅.. 1 in
  G (lim f) = 递归 (λ ξ, lim (λ m, G (f m) ξ⁺)) (lim (λ m, G (f m) ∅)).
Proof.
  intros. unfold G. destruct n. reflexivity. simpl.
  rewrite <- f_Z_eq_f_z_Z, <- f_Z_eq_f_z_Z, 增元迭代_Z__Z_l_x. reflexivity.
Qed.

Lemma veblen_l_Z__Z_l_x : ∀ n (F : ω后继元 (S n)) f g,
  let G := veblen F (lim f) ∅ ∅.. 1 in
  G (lim g) = 递归 (λ ξ, lim (λ m, G (g m) ξ⁺)) (lim (λ m, G (g m) ∅)).
Proof.
  intros. unfold G. destruct n. reflexivity. simpl.
  rewrite <- f_Z_eq_f_z_Z, <- f_Z_eq_f_z_Z, 增元迭代_Z__Z_l_x. reflexivity.
Qed.

Lemma 增元迭代_x_Z__Z_l_y : ∀ n α f,
  let F := 增元迭代 (ω加一元.φ) n α ∅.. 1 in
  F (lim f) = 递归 (λ ξ, lim (λ m, F (f m) ξ⁺)) (lim (λ m, F (f m) ∅)).
Proof.
  intros. unfold F. destruct α.
  - induction n. reflexivity. simpl. rewrite veblen_z. apply IHn.
  - unfold 增元迭代. destruct n. reflexivity.
    rewrite f_Z_eq_f_z_Z, veblen_s_Z__Z_l_x. reflexivity.
  - unfold 增元迭代. destruct n. reflexivity.
    rewrite f_Z_eq_f_z_Z, veblen_l_Z__Z_l_x. reflexivity.
Qed.

Lemma 增元迭代_Z_s__Z : ∀ F n α,
  veblen (增元迭代 (ω加一元.跳出 (ω增元迭代 F)) n) ∅ ∅.._ α⁺ 0 ∅ =
  lim (λ m, veblen (增元迭代 (ω加一元.跳出 (ω增元迭代 F)) n) ∅ ∅.._ α m [1] ∅..).
Proof.
  intros. induction n. reflexivity.
  simpl in *. rewrite IHn. reflexivity.
Qed.

Lemma veblen_s_Z_s__Z : ∀ n (F : ω后继元 (S n)) α β,
  veblen F α⁺ ∅.._ β⁺ 0 ∅ = lim (λ m, veblen F α⁺ ∅.._ β m [1] ∅..).
Proof.
  intros. destruct n. reflexivity. simpl.
  rewrite 增元迭代_Z_s__Z. reflexivity.
Qed.

Lemma veblen_l_Z_s__Z : ∀ n (F : ω后继元 (S n)) f α,
  veblen F (lim f) ∅.._ α⁺ 0 ∅ = lim (λ m, veblen F (lim f) ∅.._ α m [1] ∅..).
Proof.
  intros. destruct n. reflexivity. simpl.
  rewrite 增元迭代_Z_s__Z. reflexivity.
Qed.

Lemma 增元迭代_x_Z_s__Z : ∀ n α β, 增元迭代 ω加一元.φ (S n) α ∅.._ β⁺ 0 ∅ =
  lim (λ m, 增元迭代 ω加一元.φ (S n) α ∅.._ β m [1] ∅..).
Proof.
  intros. destruct α.
  - induction n. reflexivity. simpl in *. rewrite veblen_z in *. apply IHn.
  - unfold 增元迭代. rewrite veblen_s_Z_s__Z. reflexivity.
  - unfold 增元迭代. rewrite veblen_l_Z_s__Z. reflexivity.
Qed.

Lemma 增元迭代_Z_l__Z : ∀ F n f,
  veblen (增元迭代 (ω加一元.跳出 (ω增元迭代 F)) n) ∅ ∅.._ (lim f) 0 ∅ =
  lim (λ m, veblen (增元迭代 (ω加一元.跳出 (ω增元迭代 F)) n) ∅ ∅.._ (f m) 0 ∅).
Proof.
  intros. induction n. reflexivity.
  simpl in *. rewrite IHn. reflexivity.
Qed.

Lemma veblen_s_Z_l__Z : ∀ n (F : ω后继元 (S n)) α f,
  veblen F α⁺ ∅.._ (lim f) 0 ∅ = lim (λ m, veblen F α⁺ ∅.._ (f m) 0 ∅).
Proof.
  intros. destruct n. reflexivity. simpl.
  rewrite 增元迭代_Z_l__Z. reflexivity.
Qed.

Lemma veblen_l_Z_l__Z : ∀ n (F : ω后继元 (S n)) f g,
  veblen F (lim f) ∅.._ (lim g) 0 ∅ = lim (λ m, veblen F (lim f) ∅.._ (g m) 0 ∅).
Proof.
  intros. destruct n. reflexivity. simpl.
  rewrite 增元迭代_Z_l__Z. reflexivity.
Qed.

Lemma 增元迭代_x_Z_l__Z : ∀ n α f, 增元迭代 ω加一元.φ (S n) α ∅.._ (lim f) 0 ∅ =
  lim (λ m, 增元迭代 ω加一元.φ (S n) α ∅.._ (f m) 0 ∅).
Proof.
  intros. destruct α.
  - induction n. reflexivity. simpl in *. rewrite veblen_z in *. apply IHn.
  - unfold 增元迭代. rewrite veblen_s_Z_l__Z. reflexivity.
  - unfold 增元迭代. rewrite veblen_l_Z_l__Z. reflexivity.
Qed.

Theorem φ_z_X : ∀ n, φ (S n) ∅ = φ n.
Proof. destruct n; reflexivity. Qed.

Theorem φ_s_Z__Z_x : ∀ n α, φ (S n) α⁺ ∅ ∅.. 0 = (λ β, φ (S n) α β ∅.. 0 ∅)′.
Proof. intros. unfold φ, 增元迭代. rewrite veblen_s_Z_x. reflexivity. Qed.

Theorem φ_l_Z__Z_x : ∀ n f, φ (S n) (lim f) ∅ ∅.. 0 =
  递归 (λ ξ, lim (λ m, φ (S n) (f m) ξ⁺ ∅.. 0 ∅)) (lim (λ m, φ (S n) (f m) ∅ ∅.. 0 ∅)).
Proof. intros. unfold φ, 增元迭代. rewrite veblen_l_Z_x. reflexivity. Qed.

Theorem φ_x_s_Z__Z_y : ∀ n α β, φ (S (S n)) α β⁺ ∅ ∅.. 0 = (λ γ, φ (S (S n)) α β γ ∅.. 0 ∅)′.
Proof. intros. unfold φ. rewrite 增元迭代_x_s_Z_y. reflexivity. Qed.

Theorem φ_x_l_Z__Z_y : ∀ n α f, φ (S (S n)) α (lim f) ∅ ∅.. 0 =
  递归 (λ ξ, lim (λ m, φ (S (S n)) α (f m) ξ⁺ ∅.. 0 ∅)) (lim (λ m, φ (S (S n)) α (f m) ∅ ∅.. 0 ∅)).
Proof. intros. unfold φ. rewrite 增元迭代_x_l_Z_y. reflexivity. Qed.

Theorem φ_x_Z__Z_s_y : ∀ n α β, φ n α ∅.. 1 β⁺ = (φ n α ∅.. 1 β)′.
Proof. intros. unfold φ. rewrite 增元迭代_x_Z__Z_s_y. reflexivity. Qed.

Theorem φ_x_Z__Z_l_y : ∀ n α f, φ n α ∅.. 1 (lim f) =
  递归 (λ ξ, lim (λ m, φ n α ∅.. 1 (f m) ξ⁺)) (lim (λ m, φ n α ∅.. 1 (f m) ∅)).
Proof. intros. unfold φ. rewrite 增元迭代_x_Z__Z_l_y. reflexivity. Qed.

Theorem φ_x_Z_s__Z : ∀ n α β, φ (S n) α ∅.._ β⁺ 0 ∅ =
  lim (λ m, φ (S n) α ∅.._ β m [1] ∅..).
Proof. intros. unfold φ. rewrite 增元迭代_x_Z_s__Z. reflexivity. Qed.

Theorem φ_x_Z_l__Z : ∀ n α f, φ (S n) α ∅.._ (lim f) 0 ∅ =
  lim (λ m, φ (S n) α ∅.._ (f m) 0 ∅).
Proof. intros. unfold φ. rewrite 增元迭代_x_Z_l__Z. reflexivity. Qed.

End ω2元.

Fixpoint ω倍数元 n : Set := match n with
  | O => 序数
  | S n => ∀ m, 多元 (S m) (ω倍数元 n)
end.

Notation ω2后继元 n := (多元 n ω2元).
Notation ω倍数后继元 n m := (多元 m (ω倍数元 n)).

Fact ω倍数元_1 : ω倍数元 1 = ω元.
Proof. reflexivity. Qed.

Fact ω倍数元_2 : ω倍数元 2 = ω2元.
Proof. reflexivity. Qed.

Fact ω倍数元_Sn : ∀ n, ω倍数元 (S n) = ∀ m, ω倍数后继元 n (S m).
Proof. reflexivity. Qed.

Notation ωω元 := (∀ n, ω倍数元 (S n)).

Module ω2加一元.

Fixpoint 跳出 (F : ω2元) (α : 序数) n : ω后继元 (S n).
  destruct α as [|α|f].
  - apply (F n).
  - set (lim (λ n, 跳出 F α n [1] ∅.. 0 ∅)) as G₀.
    set (λ ξ, lim (λ n, 跳出 F α n ξ⁺ ∅.. 0 ∅)) as G.
    apply (ω2元.增元迭代 (ω加一元.跳出 (ω增元迭代 (递归 G G₀))) n).
  - set (lim (λ n, 跳出 F (f n) 0 ∅ 0 ∅)) as G₀.
    set (λ ξ, lim (λ n, 跳出 F (f n) 0 ∅ 0 ξ⁺)) as G.
    apply (ω2元.增元迭代 (ω加一元.跳出 (ω增元迭代 (递归 G G₀))) n).
Defined.

Definition φ := 跳出 (ω2元.φ).

End ω2加一元.

Module ω3元.

Fixpoint veblen {n} : ω2后继元 (S n) → ω2后继元 (S (S n)).
  set (fix 增元迭代 (F : ω2后继元 1) n : ω2后继元 (S n) :=
    match n with
    | O => F
    | S n => veblen n (增元迭代 F n)
    end) as 增元迭代.
  refine (fix inner (F : ω2后继元 (S n)) (α : 序数) : ω2后继元 (S n) := _).
  destruct α as [|α|g].
  - apply F.
  - set (ω增元迭代 (λ β, inner F α β ∅.. 0 ∅ 0 ∅)′) as ω元F.
    apply (增元迭代 (ω2加一元.跳出 (ω2元.增元迭代 (ω加一元.跳出 ω元F)))).
  - set (lim (λ m, inner F (g m) ∅.. 0 ∅ 0 ∅)) as G₀.
    set (λ β, lim (λ m, inner F (g m) β⁺ ∅.. 0 ∅ 0 ∅)) as G.
    set (ω增元迭代 (递归 G G₀)) as ω元F.
    apply (增元迭代 (ω2加一元.跳出 (ω2元.增元迭代 (ω加一元.跳出 ω元F)))).
Defined.

Fixpoint 增元迭代 F n : ω2后继元 (S n) :=
  match n with
    | O => F
    | S m => veblen (增元迭代 F m)
  end.

Definition φ := 增元迭代 (ω2加一元.φ).

End ω3元.


(*************************************************************)
(*   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 Arith Bool Lia Eqdep_dec.

From Undecidability.Shared.Libs.DLW.Utils
  Require Import utils_tac utils_list utils_nat finite.

From Undecidability.Shared.Libs.DLW.Vec
  Require Import pos vec.

From Undecidability.TRAKHTENBROT
  Require Import notations utils fol_ops fo_sig fo_terms fo_logic fo_sat.

Import fol_notations.

Set Implicit Arguments.

(* * From Σ=(ø;{R^n}) to any signature *)

Tactic Notation "iff" "equal" := apply fol_equiv_ext.

Local Notation ø := vec_nil.

Section Sig_n_Sig.

  Variable (Σ : fo_signature) (r : rels Σ).

  Notation Σn := (Σrel (ar_rels _ r)).

  Local Fixpoint enc (A : fol_form Σn) : fol_form Σ :=
    match A with
      | ⊥              => ⊥
      | fol_atom   _ v => fol_atom r (vec_map (fun x => £(Σrel_var x)) v)
      | fol_bin b A B  => fol_bin b (enc A) (enc B)
      | fol_quant q A  => fol_quant q (enc A)
     end.

  Section M_enc_n.

    Variables (X : Type) (M : fo_model Σ X).

    Local Definition M_enc_n : fo_model Σn X.
    Proof.
      exists; intros [] v.
      exact (fom_rels M r v).
    Defined.

    Notation "⟪ A ⟫" := (fun ψ => fol_sem M ψ A).
    Notation "⟪ A ⟫'" := (fun φ => fol_sem M_enc_n φ A) (at level 1, format "⟪ A ⟫'").

    Local Fact enc_correct_1 A φ : ⟪ A ⟫' φ <-> ⟪ enc A ⟫ φ.
    Proof.
      revert φ.
      induction A as [ | [] v | b A HA B HB | q A HA ]; intros phi.
      + simpl; tauto.
      + unfold M_enc_n; simpl; rewrite vec_map_map.
        iff equal; f_equal; apply vec_pos_ext.
        intros p; do 2 rewrite vec_pos_map; rew fot.
        simpl in v; generalize (vec_pos v p); intros [ i | [] ].
        rew fot; simpl; auto.
      + simpl; apply fol_bin_sem_ext; auto.
      + simpl; apply fol_quant_sem_ext; intro; auto.
    Qed.

  End M_enc_n.

  Local Lemma SAT_SATn A : fo_form_fin_dec_SAT (enc A)
                        -> fo_form_fin_dec_SAT A.
  Proof.
    intros (X & M & H1 & H2 & phi & H3).
    exists X, (M_enc_n M), H1.
    exists. { intros [] v; apply H2. }
    exists phi.
    revert H3; apply enc_correct_1.
  Qed.

  Section Mn_enc.

    Variables (X : Type) (Mn : fo_model Σn X) (x0 : X).

    Local Definition Mn_enc : fo_model Σ X.
    Proof.
      exists.
      + intros s v; apply x0.
      + intros r' v.
        destruct (eq_nat_dec (ar_rels _ r) (ar_rels _ r')) as [ H | H ].
        * exact (fom_rels Mn tt (eq_rect_r _ v H)).
        * exact False.
    Defined.

    Notation "⟪ A ⟫" := (fun ψ => fol_sem Mn_enc ψ A).
    Notation "⟪ A ⟫'" := (fun φ => fol_sem Mn φ A) (at level 1, format "⟪ A ⟫'").

    Local Fact enc_correct_2 A φ : ⟪ A ⟫' φ <-> ⟪ enc A ⟫ φ.
    Proof.
      revert φ.
      induction A as [ | [] v | b A HA B HB | q A HA ]; intros phi.
      + simpl; tauto.
      + unfold Mn_enc; simpl; rewrite vec_map_map.
        destruct (eq_nat_dec (ar_rels Σ r) (ar_rels Σ r)) as [ H | [] ]; auto.
        rewrite eq_nat_uniq with (H := H); unfold eq_rect_r; simpl.
        iff equal; f_equal; apply vec_pos_ext.
        intros p; do 2 rewrite vec_pos_map; rew fot.
        simpl in v; generalize (vec_pos v p); intros [ i | [] ].
        rew fot; simpl; auto.
      + simpl; apply fol_bin_sem_ext; auto.
      + simpl; apply fol_quant_sem_ext; intro; auto.
    Qed.

  End Mn_enc.

  Local Lemma SATn_SAT A : fo_form_fin_dec_SAT A
                        -> fo_form_fin_dec_SAT (enc A).
  Proof.
    intros (X & Mn & H1 & H2 & phi & H3).
    exists X, (Mn_enc Mn (phi 0)), H1.
    exists.
    { intros r' v; simpl.
      destruct (eq_nat_dec (ar_rels Σ r) (ar_rels Σ r')) as [ H | H ].
      + revert v; rewrite <- H; unfold eq_rect_r; simpl; intro; apply H2.
      + right; tauto. }
    exists phi.
    revert H3; apply enc_correct_2.
  Qed.

  Hint Resolve SATn_SAT SAT_SATn : core.

  Local Theorem SATn_SAT_red :
       { f : fol_form Σn -> fol_form Σ
           | forall A, fo_form_fin_dec_SAT A <-> fo_form_fin_dec_SAT (f A) }.
  Proof. exists enc; split; auto. Qed.

End Sig_n_Sig.

Theorem SATn_SAT_reduction (Σ : fo_signature) (n : nat) (r : rels Σ) (Hr : ar_rels _ r = n) :
      { f : fol_form (Σrel n) -> fol_form Σ
          | forall A, fo_form_fin_dec_SAT A <-> fo_form_fin_dec_SAT (f A) }.
Proof. subst n; apply SATn_SAT_red. Qed.


Require Import Hahn.
From RelationAlgebra Require Import kat normalisation rewriting kat_tac rel.
Set Implicit Arguments.

(* Definition of a relational model of the kleene algebra with test *)

(* kat consists of a boolean algebra and a kleene algebra *)
Canonical Structure bool_algebra (A: Type): lattice.ops := {|
  car := (A -> Prop);
  leq := set_subset;
  weq := set_equiv;
  cup := set_union (A:=A);
  cap := @set_inter _;
  bot := set_empty;
  top := set_full;
  neg := @set_compl _;
|}.

Canonical Structure partial_order (A: Type): lattice.ops := {|
  car := relation A;
  leq := inclusion;
  weq := same_relation;
  cup := @union _;
  cap := @inter_rel _;
  bot := ∅₂;
  top := fun _ _ => True;
  neg := fun r => (fun _ _ => True) \ r
|}.

(*
Left and right division are defined such that
  left_div: R <= P // Q iff R ; Q <= P
  right_div: R <= P \\ Q iff P ; R <= Q
*)

Definition div_l := fun A (P Q : relation A) => P ⨾  (Q ⁻¹).
Definition div_r := fun A (P Q : relation A) => (P⁻¹) ⨾  Q .

Notation "P // Q" := (div_l P Q) (at level 44).
Notation "P \\ Q" := (div_r P Q) (at level 44).

Canonical Structure kleene_algebra A: monoid.ops := {|
  ob := unit;
  mor n m := partial_order A;
  dot n m p := @seq A;
  one n := (* <| fun _ : A => True |> *) fun x y => x = y;
  itr n := @clos_trans _;
  str n := @clos_refl_trans _;
  cnv n m := @transp _;
  ldv n m p := @div_l _;
  rdv n m p := @div_r _
|}.

Canonical Structure kleene_algebra_with_test A: kat.ops := {|
  kar := kleene_algebra A;
  tst n := bool_algebra A;
  inj n := @eqv_rel A
|}.

Local Ltac u :=
  unfold set_union, set_inter, set_minus, set_compl,
         set_equiv, set_subset, set_empty, set_full,
         reflexive, transitive in *;
  ins; try solve [tauto | firstorder].

(* Proving laws of the algebra holds *)

(* Boolean algebra is a lattice *)
Instance expr_lattice_laws A: lattice.laws BL (bool_algebra A).
Proof.
  constructor; try eauto; ins; u.
Qed.

(* Partial order is a lattice *)
Instance prog_lattice_laws A: lattice.laws BKA (partial_order A).
Proof.
  constructor; try eauto; ins; u.
Qed.

(* Kleene algebra is a monoid *)
Instance prog_monoid_laws A: monoid.laws BKA (kleene_algebra A).
Proof.
  constructor; try ins; eauto; u.
  all: rels.
  - red; split; u.
    red; ins; red in H; desf.
  - right. ins. red; split; u.
    red; ins; red in H; desf.
  - unfold seq, inclusion in *; ins; desf; u.
  - unfold seq, inclusion in *; ins; desf.
    induction H1; eauto.
  - right; right; ins.
    unfold seq, inclusion in *; ins; desf.
    induction H2; eauto.
Qed.

Instance prog_kat_laws A: kat.laws (kleene_algebra_with_test A).
Proof.
  constructor; simpl; eauto with typeclass_instances.
  split; ins.
  - by rewrite H.
  - by rewrite H.
  - by rewrite id_union.
  - by unfold eqv_rel; split; red; ins; desf.
  - by unfold set_inter, eqv_rel, seq, same_relation, inclusion; split; ins; desf; eauto.
  - ins.
    red; split.
    * unfold eqv_rel; do 2 red; ins. eexists; split; split; desf; red in H0; desf.
    * unfold eqv_rel; red; ins; split; red in H; desf.
Qed.

(*-------------------------------------------------------------------------------------------*)

(* Tactics for converting a Hahn query into a ra library query *)
Ltac conv_term t k :=
  let rec conv_loop t k :=
  match t with
  | ∅₂ => constr:(0)
  | ?a⁺ => conv_loop a ltac:(fun a' => k constr:(a' ^+))
  | ?a＊ =>  conv_loop a ltac:(fun a' => k uconstr:(a' ^*))
  | ?a⁻¹ =>  conv_loop a ltac:(fun a' => k constr:(a' `))
  | ?a ^? => conv_loop a ltac:(fun a' => k constr: (1 + a'))
  | ⦗ ?a ⦘ => conv_loop a ltac:(fun a' => k constr:( [a']))
  | ?a ⊆ ?b =>
      conv_loop a ltac:(fun a' => conv_loop b ltac:(fun b' => k constr:(a' <== b')))
  | ?a ≡ ?b =>
      conv_loop a ltac:(fun a' => conv_loop b ltac:(fun b' => k constr:(a' == b')))
  | ?a ⨾  ?b =>
      conv_loop a ltac:(fun a' => conv_loop b ltac:(fun b' => k constr:(a' * b')))
  |  ?a ∪ ?b =>
      conv_loop a ltac:(fun a' => conv_loop b ltac:(fun b' => k constr:(a' + b')))
  | ?a ∩ ?b =>
      conv_loop a ltac:(fun a' => conv_loop b ltac:(fun b' => k constr:(a' ^ b')))
  | ?a // ?b =>
      conv_loop a ltac:(fun a' => conv_loop b ltac:(fun b' => k constr:(a' -o b')))
  | ?a \\ ?b =>
      conv_loop a ltac:(fun a' => conv_loop b ltac:(fun b' => k constr:(a' o- b')))
  |  pow_rel ?a O => k uconstr:(1)
  |  pow_rel ?a (S ?n) =>
        conv_loop (a ^^ n) ltac:(fun an' => conv_loop a ltac:(fun a' => k constr:(an' * a')))
  (*| ?f ?a ?b =>
      conv_loop a ltac:(fun a' => conv_loop b ltac:(fun b' => k constr:(f a' b'))) *)
  | _ => k t
  end in
  conv_loop t k.

Ltac conv :=
  change (relation) with (fun A => car (@mor (@kar (kleene_algebra_with_test A)) tt tt)) in *;
  match goal with
  | |- ?a =>
     conv_term a ltac:(fun b => change a with b)
  end.

Ltac conv_all :=
  repeat match goal with
  | H: ?A -> Prop |- _ => progress (change (A -> Prop) with (car (@tst (kleene_algebra_with_test A) tt)) in H)
  end;
  change (relation) with (fun A => car (kleene_algebra_with_test A tt tt)) in *;
  repeat match goal with
  | H: ?a |- _ => progress (conv_term a ltac:(fun b => change a with b in H))
  | |- ?a => progress (conv_term a ltac:(fun b => change a with b))
  end.

Ltac kat_solve := ins; conv_all; kat.

(* Same test examples *)
Lemma r_trans_comm A (r: relation A): (r⁺ ;; r) ≡ r ;; r⁺.
Proof. kat_solve. Qed.

Lemma r_seq_trans_clos A (r: relation A): (r ;; r) ⊆ r⁺.
Proof. kat_solve. Qed.

Lemma bla0 A (r: relation A): r^? ⊆ r＊.
Proof. kat_solve. Qed.

Lemma bla1 A (x y: relation A):  x ;; y == x ;; y ;; x -> x ⊆ x ;; (y ;; x)＊.
Proof. kat_solve. Qed.

Lemma bla2 A (x y: relation A):  x ;; y == x ;; y ;; x ->
    (x ;; y)＊ ;; (x ;; y ;; x) ⊆ (x ;; y)＊ ;; x.
Proof. kat_solve. Qed.

Lemma bla3 A (b: A -> Prop) (q: relation A): ⦗ b ⦘ ;; ⦗ b⦘ ⊆ ⦗ b⦘⁺.
Proof. kat_solve. Qed.


Require Import Undecidability.Synthetic.Undecidability.
Require Import Undecidability.Synthetic.ReducibilityFacts.
Require Import Undecidability.TM.TM.

Require Import Undecidability.TM.Reductions.mTM_to_TM.
Require Import Undecidability.TM.Reductions.SBTM_HALT_to_HaltTM_1.
Require Import Undecidability.TM.SBTM_undec.
(** ** HaltMTM and HaltTM 1 are undecidable *)

Lemma HaltMTM_undec :
  undecidable HaltMTM.
Proof.
  apply (undecidability_from_reducibility SBTM_HALT_undec).
  apply (reduces_transitive SBTM_HALT_to_HaltTM_1.reduction).
  apply nTM_to_MTM.
Qed.

Lemma HaltTM_1_undec :
  undecidable (HaltTM 1).
Proof.
  apply (undecidability_from_reducibility SBTM_HALT_undec).
  exact SBTM_HALT_to_HaltTM_1.reduction.
Qed.