From mathcomp Require Import all_ssreflect all_fingroup all_algebra.
From mathcomp Require Import all_solvable all_field.
From Abel Require Import various char0.

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

Import GRing.Theory.

Local Open Scope ring_scope.

Local Notation "p ^^ f" := (map_poly f p)
  (at level 30, f at level 30, format "p  ^^  f").

Section Prodv.
Import AEnd_FinGroup.

Variables (F0 : fieldType) (L : splittingFieldType F0).
Implicit Types (K E F : {subfield L}).

Lemma galois_subW E F : galois E F -> (E <= F)%VS. Proof. by case/andP. Qed.

Lemma galois_normalW E F : galois E F -> (normalField E F)%VS.
Proof. by case/and3P. Qed.

Lemma galois_separableW E F : galois E F -> (separable E F)%VS.
Proof. by case/and3P. Qed.

Lemma normalField_refl E : normalField E E.
Proof.
apply/forallP => /= u; apply/implyP; rewrite in_set.
by move=> /andP[/andP[_ /fixedSpace_limg->]].
Qed.
Hint Resolve normalField_refl : core.

Lemma galois_refl E : galois E E.
Proof. by rewrite /galois subvv separable_refl normalField_refl. Qed.

Lemma gal1 K (g : gal_of K) : g \in 'Gal(K / 1%VS)%g.
Proof. by rewrite gal_kHom ?sub1v// k1HomE ahomWin. Qed.

Lemma Fadjoin_sub E x y : x \in <<E; y>>%VS -> (<<E; x>> <= <<E; y>>)%VS.
Proof. by move=> xEy; apply/FadjoinP; rewrite subv_adjoin. Qed.

Lemma galvv E : ('Gal(E / E) = 1)%g.
Proof.
apply/trivgP/subsetP=> u uG; rewrite inE.
by apply/gal_eqP => x xE; rewrite gal_id (fixed_gal _ uG).
Qed.

Program Canonical prodv_aspace_law :=
  @Monoid.Law {subfield L} 1%AS (@prodv_aspace _ _) _ _ _.
Next Obligation. by move=> *; apply/val_inj/prodvA. Qed.
Next Obligation. by move=> *; apply/val_inj/prod1v. Qed.
Next Obligation. by move=> *; apply/val_inj/prodv1. Qed.

Program Canonical prodv_aspace_com_law :=
  @Monoid.ComLaw {subfield L} 1%AS prodv_aspace_law _.
Next Obligation. by move=> *; apply/val_inj/prodvC. Qed.

Lemma big_prodv_eq_aspace I (r : seq I) (P : {pred I}) (F : I -> {aspace L}) :
  (\big[@prodv _ _/1%VS]_(i <- r | P i) F i) =
  (\big[@prodv_aspace _ _/1%AS]_(i <- r | P i) F i).
Proof. by elim/big_rec2: _ => // i U V _ ->. Qed.

Lemma separable_mulv K x y :
  separable_element K x -> separable_element K y -> separable_element K (x * y).
Proof.
move/(separable_elementS (subv_adjoin K y))=> sepKy_x sepKy.
have [z defKz] := Primitive_Element_Theorem x sepKy.
have /(adjoin_separableP _): x * y \in <<K; z>>%VS.
  by rewrite -defKz rpredM ?memv_adjoin // subvP_adjoin ?memv_adjoin.
apply; apply: adjoin_separable sepKy (adjoin_separable sepKy_x _).
by rewrite defKz base_separable ?memv_adjoin.
Qed.

Lemma separable_prod I r (P : pred I) (v_ : I -> L) (K : {subfield L}) :
    (forall i, P i -> separable_element K (v_ i)) ->
  separable_element K (\prod_(i <- r | P i) v_ i).
Proof.
move=> sepKi.
by elim/big_ind: _; [apply/base_separable/mem1v | apply: separable_mulv |].
Qed.

Lemma separable_prodv (k K1 K2 : {subfield L}) :
  separable k (K1 * K2) = (separable k K1 && separable k K2).
Proof.
apply/separableP/andP => [sepK12|].
  split; apply/separableP => y yK; rewrite sepK12//.
    by apply: (subv_trans yK); rewrite field_subvMr.
  by apply: (subv_trans yK); rewrite field_subvMl.
move=> [/separableP sepK1 /separableP sepK2].
move=> x /memv_mulP[n [us [vs [/allP/= usK /allP/= vsK ->]]]].
rewrite separable_sum// => i _; rewrite separable_mulv//.
  by rewrite sepK1 ?usK ?mem_tnth.
by rewrite sepK2 ?vsK ?mem_tnth.
Qed.

Lemma separable_super (k K : {subfield L}) : (k <= K)%VS ->
  separable K k.
Proof. by move=> /separableSr->//; rewrite separable_refl. Qed.

Lemma separable1 (k : {subfield L}) : separable k 1.
Proof. by rewrite separable_super// ?sub1v. Qed.

Lemma separable_big_prodv I r (P : {pred I}) (k : {subfield L})
  (K : I -> {subfield L}) :
  separable k (\big[@prodv _ _/1%VS]_(i <- r | P i) K i) =
  \big[andb/true]_(i <- r | P i) separable k (K i).
Proof.
rewrite big_prodv_eq_aspace; elim/big_rec2: _ => [|i E b _].
  by rewrite separable1.
by rewrite separable_prodv => ->.
Qed.

Lemma separable_big_prodvW I r (P : {pred I}) (k : {subfield L})
  (K : I -> {subfield L}) :
  (forall i, P i -> separable k (K i)) ->
  separable k (\big[@prodv _ _/1%VS]_(i <- r | P i) K i).
Proof.
move=> sepKi; rewrite separable_big_prodv big_tnth big_andE.
by apply/'forall_implyP => i /sepKi.
Qed.

Lemma separable_prodvr (k K F : {subfield L}) : (k <= F)%VS ->
  separable k K -> separable F (K * F).
Proof.
by move=> kF sepkK; rewrite separable_prodv separable_refl (separableSl kF).
Qed.

Lemma normal_prodvr (k K F : {subfield L}) : (k <= K)%VS -> (k <= F)%VS ->
  normalField k K -> normalField F (K * F).
Proof.
move=> kK kF /(splitting_normalField kK) [p pk [rs p_eq krs]].
apply/splitting_normalField; rewrite ?field_subvMl//; exists p.
  by apply: polyOverS pk => x; apply: subvP.
exists rs => //; apply/eqP; rewrite eqEsubv; apply/andP; split.
  apply/Fadjoin_seqP; rewrite field_subvMl; split => //= r rrs.
  by apply: (subvP (field_subvMr _ _)); rewrite -krs seqv_sub_adjoin.
apply/prodvP => x y xK yF; rewrite rpredM//; last first.
  by rewrite (subvP (subv_adjoin_seq _ _))//.
by rewrite -krs in xK; apply: subvP xK; apply: adjoin_seqSl.
Qed.

Lemma galois_prodvr (k K F : {subfield L}) : (k <= F)%VS ->
  galois k K -> galois F (K * F).
Proof.
move=> kF /and3P[kK sep norm]; rewrite /galois field_subvMl/=.
by rewrite (separable_prodvr kF)// (normal_prodvr kK kF).
Qed.

(** N/A **)
Lemma capv_galois (k K F : {subfield L}) : (k <= F)%VS ->
  galois k K -> galois (K :&: F) K.
Proof.
move=> kF /splitting_galoisField [p [pk p_sep [rs p_eq krs]]].
have k_subKF: (k <= K :&: F)%VS.
  apply/subvP => x xk.
  by rewrite memv_cap (subvP kF)// -krs (subvP (subv_adjoin_seq _ _)).
apply/splitting_galoisField; exists p; split => //.
  by apply: polyOverS pk; apply/subvP.
exists rs => //; apply/eqP; rewrite -krs eqEsubv andbC adjoin_seqSl//=.
by apply/Fadjoin_seqP; split; [rewrite /= krs capvSl|apply: seqv_sub_adjoin].
Qed.

Lemma kAutEnormal (K E : {subfield L}) (f : 'End(L)) :
  (K <= E)%VS -> normalField K E -> kAut K E f = kHom K E f.
Proof.
move=> KE normalKE; rewrite kAutE; have [f_hom|]//= := boolP (kHom _ _ _).
apply/subvP => _/memv_imgP[x Ex ->].
have := kHom_to_gal _ normalKE f_hom; rewrite subvv KE => -[//|g gK ->//].
by rewrite memv_gal.
Qed.

Lemma fixedField_sub  (K E : {subfield L}) (A : {set gal_of E}) :
  galois K E -> (('Gal(E / K))%g \subset A) -> (fixedField A <= K)%VS.
Proof. by move=> /galois_fixedField{2}<- subA; apply: fixedFieldS. Qed.

Lemma galois_sub  (K E : {subfield L}) (A : {group gal_of E}) :
  galois K E -> (('Gal(E / K))%g \subset A) = (fixedField A <= K)%VS.
Proof.
move=> galKE; apply/idP/idP; first exact: fixedField_sub.
move=> /galS-/(_ E)/=/subset_trans->//.
by apply/subsetP => u; rewrite gal_fixedField.
Qed.

Lemma galois_eq  (K E : {subfield L}) (A : {group gal_of E}) :
  galois K E -> ('Gal(E / K)%g == A) = (fixedField A == K)%VS.
Proof.
move=> galKE; have KE := galois_subW galKE.
by rewrite eqEsubset eqEsubv galois_sub// galois_connection.
Qed.

Lemma galois_misom (k K F : {subfield L})
  (H := 'Gal((K * F) / F)%g) (H' := 'Gal (K / (K :&: F))%g) :
  galois k K -> (k <= F)%VS -> misom H H' (normalField_cast K).
Proof.
move=> gal_kK kF; have kK := galois_subW gal_kK.
have normal_kK := galois_normalW gal_kK.
have KF u : u \in H -> (u @: K <= K)%VS.
  move=> Hu; suff : kHom k K u by rewrite -kAutEnormal// kAutE => /andP[].
  by apply/kAHomP => x kx; rewrite (fixed_gal _ Hu) ?field_subvMl ?(subvP kF).
have r_H_morphic : morphic H (normalField_cast K).
  apply/morphicP => u v uH vH; apply/eqP/gal_eqP => x Kx.
  rewrite galM// [LHS]galK ?KF ?groupM//.
  rewrite 2?galK ?KF//; last by apply/(subvP (KF u uH)); rewrite memv_img.
  by rewrite galM//; apply: subvP Kx; apply: field_subvMr.
apply/misomP; exists r_H_morphic; apply/isomP; split.
  apply/subsetP => /= u ker_u; have Hu := dom_ker ker_u.
  apply/set1gP/eqP/gal_eqP => _ /memv_mulP[n [xs [ys [xsP ysP ->]]]].
  rewrite rmorph_sum/= gal_id; apply: eq_bigr => i _; rewrite rmorphM/=.
  have [xiK yiK] := (allP xsP _ (mem_tnth i _), allP ysP _ (mem_tnth i _)).
  have /eqP/gal_eqP/(_ _ xiK) := mker ker_u.
  rewrite /normalField_cast galK ?KF// => ->; rewrite gal_id.
  by rewrite (fixed_gal _ Hu)// field_subvMl.
apply/eqP; rewrite eq_sym galois_eq ?(capv_galois kF gal_kK)//.
rewrite eqEsubv; apply/andP; split; apply/subvP => x; last first.
  rewrite memv_cap => /andP[Kx Fx].
  apply/fixedFieldP => // _ /morphimP[/= v Hv _ ->].
  rewrite morphmE /normalField_cast galK// ?KF//.
  by rewrite (fixed_gal _ Hv)// field_subvMl.
move=> /mem_fixedFieldP[Kx xP]; rewrite memv_cap Kx/=.
rewrite -(galois_fixedField (galois_prodvr kF gal_kK)).
apply/fixedFieldP; first by rewrite -[x]mulr1 memv_mul// rpred1.
move=> u Hu; have := xP (normalField_cast _ u).
by rewrite /normalField_cast galK ?KF//; apply; apply/morphimP; exists u.
Qed.

Lemma galois_isog (k K F : {subfield L}) : galois k K -> (k <= F)%VS ->
  'Gal((K * F) / F) \isog 'Gal (K / K :&: F).
Proof. by move=> galkK /(galois_misom galkK) /misom_isog. Qed.

Lemma subv_big_prodv_seq I r (P : {pred I}) (k : {subfield L})
  (K : I -> {subfield L}) :
  (forall i, P i -> (k <= K i)%VS) ->
  ~~ nilp [seq i <- r | P i] ->
  (k <= \big[@prodv _ _/1]_(i <- r | P i) K i)%VS.
Proof.
move=> normkK; elim: r => [|i r IHr]; rewrite !(big_nil, big_cons)//=.
case: ifP IHr => //= Pi; rewrite -big_filter.
have [->|_ IHr]//= := altP nilP; first by rewrite big_nil prodv1 normkK.
by rewrite -[X in (X <= _)%VS]prodv_id prodvS ?IHr ?normkK.
Qed.

Lemma subv_big_prodv (I : finType) (D : {pred I}) (k : {subfield L})
  (K : I -> {subfield L}) :
  (#|D| > 0)%N -> (forall i, D i -> k <= K i)%VS ->
  (k <= \big[@prodv _ _/1]_(i in D) K i)%VS.
Proof.
move=> D_gt0 DK; apply: subv_big_prodv_seq => //.
by rewrite /nilp size_filter -sum1_count sum1_card -lt0n.
Qed.

Lemma normal_prodv (k K1 K2 : {subfield L}) :
  normalField k K1 -> normalField k K2 -> normalField k (K1 * K2).
Proof.
move=> /'forall_implyP/(_ _ _)/eqP endK1  /'forall_implyP/(_ _ _)/eqP endK2.
by apply/'forall_implyP => s s_end; rewrite aimgM endK1// endK2.
Qed.

Lemma normal_big_prodv I r (P : {pred I}) (k : {subfield L})
    (K : I -> {subfield L}) :
    (forall i, P i -> normalField k (K i)) ->
  normalField k (\big[@prodv _ _/1%VS]_(i <- r | P i) K i).
Proof.
move=> normkK; elim: r => [|i r IHr]; rewrite !(big_nil, big_cons).
  apply/normalFieldP => a a1; exists [:: a]; rewrite /= ?a1//.
  rewrite big_cons big_nil mulr1; apply: minPoly_XsubC.
  by apply: subvP a1; rewrite sub1v.
rewrite big_prodv_eq_aspace in IHr *; case: ifP => // Pi.
by rewrite normal_prodv// normkK.
Qed.

Lemma galois_prodv (k K1 K2 : {subfield L}) :
  galois k K1 -> galois k K2 -> galois k (K1 * K2).
Proof.
rewrite /galois => /and3P[kK1 sepK1 normK1] /and3P[kK2 sepK2 normK2].
rewrite -[X in (X <= _)%VS]prodv_id prodvS//=.
by rewrite separable_prodv ?sepK1 ?sepK2// normal_prodv.
Qed.

Lemma galois_big_prodv_seq I r (P : {pred I}) (k : {subfield L})
  (K : I -> {subfield L}) :
  (forall i, P i -> galois k (K i)) ->
  ~~ nilp [seq i <- r | P i] ->
  galois k (\big[@prodv _ _/1%VS]_(i <- r | P i) K i).
Proof.
move=> galkK brP; pose gW := (galois_subW, galois_normalW, galois_separableW).
pose bpv := (subv_big_prodv_seq, separable_big_prodvW, normal_big_prodv).
by rewrite /galois !bpv// => i Pi; rewrite /= gW ?galkK.
Qed.

Lemma galois_big_prodv (I : finType) (D : {pred I}) (k : {subfield L})
    (K : I -> {subfield L}) :
    (#|D| > 0)%N -> (forall i, D i -> galois k (K i)) ->
  galois k (\big[@prodv _ _/1%VS]_(i in D) K i).
Proof.
move=> D_gt0 galkK; apply: galois_big_prodv_seq => //.
by rewrite /nilp size_filter -sum1_count sum1_card -lt0n.
Qed.

Definition gal_big_prodv_cast_subdef {n} {K : 'I_n -> {subfield L}}
   (s : gal_of (\big[@prodv_aspace _ _/1%AS]_(i < n) K i)) :
    {dffun forall i, gal_of (K i)} :=
  [ffun i => normalField_cast (K i) s].

Lemma gal_big_prodv_cast_morphic n (k : {subfield L}) (K : 'I_n -> {subfield L}) :
  (forall i, galois k (K i)) ->
  morphic 'Gal((\big[@prodv_aspace _ _/1%AS]_(i < n) K i)%VS / k)
          gal_big_prodv_cast_subdef.
Proof.
rewrite /gal_big_prodv_cast_subdef => galK.
apply/'forall_implyP => -[s t]; rewrite inE => /andP[sG tG].
apply/eqP/ffunP => i; rewrite !ffunE/=.
have n_gt0 : (n > 0)%N by case: {+}n i => -[].
rewrite (@normalField_castM _ _ _ k) ?galois_normalW//.
by rewrite [(k <= _)%VS]galois_subW//= (bigD1 i)//= field_subvMr.
Qed.

Definition gal_big_prodv_cast n (k : {subfield L}) (K : 'I_n -> {subfield L})
  (galK : forall i, galois k (K i)) :=
  [morphism of morphm (gal_big_prodv_cast_morphic galK)].

Lemma gal_big_prodv_cast_inj n (k : {subfield L}) (K : 'I_n -> {subfield L})
  (galK : forall i, galois k (K i)) :
  ('injm (gal_big_prodv_cast galK))%g.
Proof.
apply/subsetP => /= s s_ker; rewrite inE; apply/gal_eqP => x xK.
suff: x \in fixedField [set s].
  by move=> /mem_fixedFieldP [_ /(_ s)]; rewrite inE gal_id; apply.
apply/subvP: x xK; rewrite /= -[X in (X <= _)%VS]big_prodv_eq_aspace.
apply/big_prod_subfieldP => u uK /=; rewrite rpred_prod// => i _.
apply/fixedFieldP; first by rewrite (bigD1 i)// -[u i]mulr1 memv_mul ?rpred1 ?uK.
move=> s'; rewrite inE => /eqP->{s'}; have /mker := s_ker.
rewrite /gal_big_prodv_cast/= morphmE /gal_big_prodv_cast_subdef.
move=> /ffunP-/(_ i); rewrite !ffunE.
move=> /eqP/gal_eqP/(_ _ (uK _ _))-/(_ isT); rewrite gal_id.
rewrite (@normalField_cast_eq _ _ _ k) ?uK ?galois_normalW ?(dom_ker s_ker)//=.
by rewrite [(k <= _)%VS]galois_subW//= (bigD1 i)//= field_subvMr.
Qed.

Lemma img_gal_big_prodv_cast_sub n (k : {subfield L}) (K : 'I_n -> {subfield L})
  (galK : forall i, galois k (K i))
  (E := (\big[@prodv_aspace _ _/1%AS]_(i < n) K i)%AS)
  (G := 'Gal(E / k)%g):
  (gal_big_prodv_cast galK @* G \subset setXn (fun i => 'Gal(K i / k)))%g.
Proof.
case: n => [|n] in K galK E G *.
  rewrite setX0; apply/subsetP => /= x _; rewrite !inE.
  by apply/eqP/ffunP => -[].
apply/subsetP => /= x; rewrite !inE morphimEdom => /imsetP[s sG ->]/=.
apply/forallP => i/=; rewrite morphmE/= ffunE/=.
rewrite -(@normalField_img _ _ E)// ?galois_normalW//.
- by rewrite (galois_subW (galK _))//= /E (bigD1 i)//= field_subvMr.
- by move=> ? ?/=; rewrite mem_morphim//.
- by rewrite /E/= -big_prodv_eq_aspace galois_big_prodv//= card_ord.
Qed.

End Prodv.
#[global] Hint Resolve normalField_refl : core.

Section map_hom.
Variables (F0 : fieldType) (L L' : splittingFieldType F0).
Variable (iota : 'Hom(L, L')).

Definition map_hom (f : 'End(L)) := (iota \o f \o iota^-1)%VF.
Definition inv_map_hom (f : 'End(L')) := (iota^-1 \o f \o iota)%VF.

Lemma map_hom_is_linear : linear map_hom.
Proof.
move=> /= k a b; apply/lfunP => x; rewrite /map_hom.
by rewrite !(comp_lfunE, add_lfunE, scale_lfunE) linearP.
Qed.
Canonical map_hom_linear := Linear map_hom_is_linear.

Lemma inv_map_hom_is_linear : linear inv_map_hom.
Proof.
move=> /= k a b; apply/lfunP => x; rewrite /map_hom.
by rewrite !(comp_lfunE, add_lfunE, scale_lfunE) linearP.
Qed.
Canonical inv_map_hom_linear := Linear inv_map_hom_is_linear.

Lemma lker0_map_homC (f : 'End(L)) : lker iota == 0%VS ->
  (map_hom f \o iota = iota \o f)%VF.
Proof. by move=> kiota0; apply/lfunP => x; rewrite !comp_lfunE lker0_lfunK. Qed.

Lemma lker0_map_homE (f : 'End(L)) (x : L) : lker iota == 0%VS ->
  map_hom f (iota x) = iota (f x).
Proof. by rewrite !comp_lfunE => /lker0_lfunK->. Qed.

Lemma inv_map_homC (f : 'End(L')) : (f @: limg iota <= limg iota)%VS ->
  (iota \o inv_map_hom f = f \o iota)%VF.
Proof.
move=> fiota; apply/lfunP => x. rewrite !comp_lfunE limg_lfunVK//.
by rewrite memvE (subv_trans _ fiota)// -memvE !memv_img ?memvf.
Qed.

Lemma inv_map_homE (f : 'End(L')) (x : L) :
  f (iota x) \in (limg iota)%VS ->
  iota (inv_map_hom f x) = f (iota x).
Proof. by move=> fiotax; rewrite !comp_lfunE limg_lfunVK. Qed.

End map_hom.

Section map_ahom.
Variables (F0 : fieldType) (L L' : splittingFieldType F0).
Variable (iota : 'AHom(L, L')).

Lemma map_hom_algE (f : 'End(L)) (x : L) :
  map_hom iota f (iota x) = iota (f x).
Proof. by rewrite lker0_map_homE// AHom_lker0. Qed.

Lemma map_hom_algC (f : 'End(L)) : (map_hom iota f \o iota = iota \o f)%VF.
Proof. by rewrite lker0_map_homC// AHom_lker0. Qed.

Lemma map_ahom_in (f : 'End(L)) (E : {vspace L}) :
  ahom_in (iota @: E) (map_hom iota f) = ahom_in E f.
Proof.
apply/ahom_inP/ahom_inP => -[mfM mf1]; last first.
  split; last by rewrite -(rmorph1 [rmorphism of iota]) map_hom_algE mf1.
  move=> _ _ /memv_imgP[u uE ->] /memv_imgP[v vE ->].
  by rewrite !(map_hom_algE, =^~rmorphM)/= mfM.
split=> [x y xE yE|]; last first.
  have : map_hom iota f (iota 1) = iota 1 by rewrite rmorph1.
  by rewrite map_hom_algE => /fmorph_inj.
have := mfM _ _ (memv_img iota xE) (memv_img iota yE).
by rewrite !(map_hom_algE, =^~rmorphM)/= => /fmorph_inj.
Qed.

Lemma map_ahom_subproof (f : 'AEnd(L)) :
   {g : 'AEnd(L') | (g \o iota)%VF = (iota \o f)%VF }.
Proof.
have : kHom 1%VS (iota @: {: L})%VS (map_hom iota f).
  by rewrite k1HomE map_ahom_in ahomWin.
move=> /kHom_to_AEnd[g gP]; exists g.
apply/lfunP => x; rewrite !comp_lfunE/=.
by rewrite -map_hom_algE gP ?memv_img// memvf.
Qed.

Lemma inv_map_hom_kHom (E F : {subfield L}) (f : 'End(L')) :
  (E <= F)%VS -> ((f @: (iota @: F)) <= (limg iota))%VS ->
  kHom E F (inv_map_hom iota f) = kHom (iota @: E) (iota @: F) f.
Proof.
move=> EF fiotaF; have fiotaf u : u \in F -> f (iota u) \in limg iota.
  by move=> uF; apply: subv_trans fiotaF; do !apply: memv_img.
apply/kHomP/kHomP => -[/= fM s_id].
   split=> [_ _/memv_imgP[x xF ->]|_] /memv_imgP[y yF ->].
     rewrite -!rmorphM/= -3?inv_map_homE ?memv_img ?memvf ?fiotaf ?rpredM//.
     by rewrite fM// rmorphM.
  by rewrite -inv_map_homE ?s_id// fiotaf//; apply: subv_trans EF.
split=> [x y xF yF|x xF]; apply: (fmorph_inj [rmorphism of iota]) => /=.
  by rewrite rmorphM/= !inv_map_homE ?fiotaf ?rpredM// rmorphM fM ?memv_img.
by rewrite inv_map_homE s_id ?memv_img ?memvf.
Qed.

Lemma limg_inv_map_ahom  (E : {subfield L}) (f : 'End(L')) :
  ((f @: (iota @: E)) <= (iota @: E))%VS ->
  (iota @: (inv_map_hom iota f @: E))%VS = (f @: (iota @: E))%VS.
Proof.
move=> fiotaE; rewrite -!limg_comp; apply/vspaceP => x.
have fiota u : u \in E -> f (iota u) \in limg iota.
  move=> uE; rewrite memvE (@subv_trans _ _ (f @: (iota @: E))%VS) //.
    by rewrite -memvE !(memv_img, limgS).
  by rewrite (subv_trans fiotaE) ?limgS ?subvf.
by apply/memv_imgP/memv_imgP => -[u uE ->]; exists u => //;
   rewrite [LHS]comp_lfunE [RHS]comp_lfunE inv_map_homE// ?fiota.
Qed.

Lemma inv_map_hom_kAut (E F : {subfield L}) (f : 'End(L')) :
  (E <= F)%VS -> ((f @: (iota @: F)) <= (iota @: F))%VS ->
  kAut E F (inv_map_hom iota f) = kAut (iota @: E) (iota @: F) f.
Proof.
move=> EF fiotaF; rewrite !kAutE -limg_inv_map_ahom// limg_ker0 ?AHom_lker0//.
by rewrite inv_map_hom_kHom// (subv_trans fiotaF) ?limgS ?subvf.
Qed.

Lemma inv_map_ahom_in (f : 'End(L')) (E : {subfield L}) :
    (f @: (iota @: E) <= limg iota)%VS ->
  ahom_in E (inv_map_hom iota f) = ahom_in (iota @: E) f.
Proof.
by move=> fiotaE; rewrite -!k1HomE inv_map_hom_kHom ?sub1v// aimg1.
Qed.

Lemma inv_map_is_ahom (E : {subfield L}) (f : gal_of (iota @: E)) :
  ahom_in E (inv_map_hom iota f).
Proof.
rewrite inv_map_ahom_in ?limg_gal ?limgS ?subvf//.
by rewrite -k1HomE -gal_kHom ?sub1v ?gal1.
Qed.
Canonical inv_map_ahom (f : gal_of (limg iota)) := AHom (inv_map_is_ahom f).

Import AEnd_FinGroup.

Definition map_ahom (f : 'AEnd(L)) := projT1 (map_ahom_subproof f).

Lemma map_ahomC (f : 'AEnd(L)) :
   (map_ahom f \o iota)%VF = (iota \o f)%VF.
Proof. by rewrite /map_ahom; case: map_ahom_subproof. Qed.

Lemma map_ahomE (f : 'AEnd(L)) x : map_ahom f (iota x) = iota (f x).
Proof. by rewrite -!comp_lfunE map_ahomC. Qed.

Lemma limg_map_ahom (f : 'AEnd(L))  (E : {vspace L}) :
  (map_ahom f @: (iota @: E))%VS = (iota @: (f @: E))%VS.
Proof. by rewrite -!limg_comp map_ahomC. Qed.

Lemma map_ahom_kAut s (E F : {subfield L}) :
  kAut (iota @: E)%VS (iota @: F)%VS (map_ahom s) = kAut E F s.
Proof.
rewrite !kAutE limg_map_ahom limg_ker0 ?AHom_lker0// [LHS]andbC [RHS]andbC.
have [sF_sub_F|]//= := boolP (s @: F <= F)%VS.
apply/kAHomP/kAHomP => [s_id x xE|s_id _/memv_imgP[x xE ->]]; last first.
  by rewrite map_ahomE s_id.
apply: (fmorph_inj [rmorphism of iota]).
by rewrite /= -map_ahomE s_id// memv_img.
Qed.

Lemma map_ahom_kAEnd s (E F : {subfield L}) :
  (map_ahom s \in kAEnd (iota @: E)%VS (iota @: F)%VS) = (s \in kAEnd E F).
Proof. by rewrite !inE map_ahom_kAut. Qed.

Lemma map_ahom_kEnd_img s : map_ahom s \in kAEnd 1 (iota @: {: L})%AS.
Proof.
rewrite inE -(aimg1 iota) map_ahom_kAut// kAutfE.
exact/kHom_lrmorphism/ahom_is_lrmorphism.
Qed.

End map_ahom.

Section gal_kAEnd.

Variables (F0 : fieldType) (L : splittingFieldType F0).
Import AEnd_FinGroup.

Lemma kAEndSl (k K F : {subfield L}) : (k <= K)%VS -> (kAEnd K F \subset kAEnd k F).
Proof. by move=> EK; apply/subsetP => x; rewrite !inE; apply: kAutS. Qed.

Lemma ker_gal (E : {subfield L}) : ('ker (gal E))%g = kAEndf E.
Proof.
apply/setP => g; rewrite !inE kAut1E/= !kAutE subvf andbT subfield_closed.
apply/andP/idP => [[gE /gal_eqP galg1]|/kAHomP g_id].
  by apply/kAHomP => x xE; have := galg1 _ xE; rewrite gal_id galK// => ->.
have gE : (g @: E <= E)%VS by apply/subvP => _/memv_imgP[x ? ->]; rewrite g_id.
by split=> //; apply/gal_eqP => x xE; rewrite gal_id galK// g_id.
Qed.

Lemma kAEnd_split (K E : {subfield L}) : kAEnd K E = kAEnd 1 E :&: kAEndf K.
Proof.
apply/setP => f; rewrite !inE kAut1E !kAutE subvf andbT andbC.
by case fE : (f @: E <= E)%VS => //=; apply/kAHomP/kAHomP.
Qed.

Lemma gal_kAEndf (K E : {subfield L}) : (K <= E)%VS ->
   (gal E @* kAEndf K)%g = (gal E @* kAEnd K E)%g :> {set _}.
Proof.
move=> KE; rewrite kAEnd_split morphimIG ?ker_gal ?kAEndSl// (setIidPr _)//=.
by rewrite (subset_trans (morphim_sub _ _))//= morphimS// subfield_closed.
Qed.

End gal_kAEnd.

Section map_gal.
Variables (F0 : fieldType) (L L' : splittingFieldType F0).
Variable (iota : 'AHom(L, L')).
Variables (E : {subfield L}).
Let iota_ker0 := AHom_lker0 iota.

Definition map_gal (g : gal_of E) : gal_of (iota @: E) :=
  gal (iota @: E) (map_ahom iota g).

Lemma map_galE (g : gal_of E) :
  {in E, forall x, map_gal g (iota x) = iota (g x)}.
Proof.
move=> x xE /=; rewrite galK ?memv_img ?memvf//=.
  by rewrite -!comp_lfunE map_ahomC.
by rewrite limg_map_ahom limg_gal.
Qed.

Definition map_gal_is_morphism : {in setT &,
   {morph map_gal : x y / (x * y)%g >-> (x * y)%g}}.
Proof.
move=> /= f g _ _; apply/eqP/gal_eqP => _/memv_imgP[x xE ->].
rewrite galM ?memv_img// 3?map_galE// ?galM//.
by rewrite -[in X in _ \in X](limg_gal f) memv_img.
Qed.
Canonical map_gal_morphism := Morphism map_gal_is_morphism.

Import AEnd_FinGroup.
Lemma map_galK :
  {in kAEnd 1 E, map_gal \o gal E =1 gal (iota @: E) \o map_ahom iota }.
Proof.
move=> s; rewrite inE kAut1E => sE.
apply/eqP/gal_eqP => _/memv_imgP[x xE ->]/=.
rewrite map_galE// !galK ?memv_img ?map_ahomE//.
by rewrite -limg_comp map_ahomC limg_comp limgS.
Qed.

Lemma map_gal_inj : ('injm map_gal)%g.
Proof.
apply/injmP => /= f g _ _ eq_fg; apply/eqP/gal_eqP => x xE.
have /eqP/gal_eqP/(_ _ (memv_img iota xE)) := eq_fg.
by rewrite !map_galE// => /fmorph_inj.
Qed.

Lemma img_map_gal (K : {subfield L}) :
   (map_gal @* 'Gal(E / K))%g = 'Gal(iota @: E / iota @: K)%g.
Proof.
wlog subKE : K / (K <= E)%VS => [hwlog|].
  by rewrite gal_cap hwlog ?capvSr// aimg_cap -gal_cap.
rewrite /'Gal(_ / _)%g -aimg_cap !genGid/= (capv_idPl _)//.
rewrite -!gal_kAEndf ?limgS// -morphim_comp/=.
apply/setP => u; apply/imsetP/imsetP => /= [[f faut ->]|[f' f'aut ->]] {u}.
  have := faut; rewrite !inE !kAut1E !kAutE/= !subfield_closed !subvf !andbT.
  move=> /andP[fE /kAHomP fK].
  exists (map_ahom iota f).
    rewrite !inE !kAut1E !kAutE/= !subvf !andbT limg_map_ahom limgS//=.
    by apply/kAHomP => _/memv_imgP[x xK ->]; rewrite map_ahomE ?fK.
  apply/eqP/gal_eqP => _/memv_imgP[x xK ->].
  by rewrite map_galE// !galK ?memv_img ?limg_map_ahom ?map_ahomE// limg_ker0//.
have := f'aut; rewrite !inE !kAut1E !kAutE/= !subvf !andbT.
have -> : agenv (iota @: E) = (iota @: E)%VS by rewrite subfield_closed.
move=> /andP[f'E /kAHomP f'K].
have /kHom_to_AEnd[f eqf] : kHom K E (inv_map_hom iota f').
  by rewrite inv_map_hom_kHom ?(subv_trans f'E) ?limgS ?subvf//; apply/kAHomP.
have fE : (f @: E <= E)%VS.
  rewrite -(eq_in_limg eqf) -(limg_ker0 _ _ (AHom_lker0 iota)).
  by rewrite limg_inv_map_ahom//.
exists f; rewrite ?inE ?kAut1E ?kAutE/= ?subfield_closed ?subvf ?andbT ?fE.
  apply/kAHomP => x xK; rewrite -eqf ?(subvP subKE)// !comp_lfunE.
  by rewrite f'K ?memv_img// lker0_lfunK.
apply/eqP/gal_eqP => _/memv_imgP[x xE ->]; rewrite map_galE//.
rewrite !galK ?memv_img// -eqf//= inv_map_homE//.
apply: subv_trans (limgS _ (subvf E)); apply: subv_trans f'E.
by do !apply: memv_img.
Qed.

Lemma reflexiveW T (r : rel T) : reflexive r -> forall x y, x = y -> r x y.
Proof. by move=> ? ? ? ->. Qed.

Lemma normalField_aimg (K : {subfield L}) : (K <= E)%VS ->
   normalField (iota @: K) (iota @: E) = normalField K E.
Proof.
move=> KE; have iotaKS : (iota @: K <= iota @: E)%VS by rewrite limgS.
apply/splitting_normalField/splitting_normalField => //= -[p pK [rs peq Krs]].
  have /polyOver_aimg [q qK pE] := pK.
  have /subset_limgP [rs' _ rsE] : {subset rs <= (iota @: E)%VS}.
    by rewrite -Krs; apply/seqv_sub_adjoin.
  exists q => //; exists rs'.
    by have := peq; rewrite pE rsE -map_prod_XsubC/= eqp_map.
  by do [rewrite rsE -aimg_adjoin_seq => /eqP;
         rewrite eq_limg_ker0// => /eqP] in Krs.
exists (map_poly iota p) => //; first by rewrite mapf_polyOver.
by apply/splittingFieldFor_aimg; exists rs.
Qed.

Lemma galois_aimg (K : {subfield L}) :
   galois (iota @: K) (iota @: E) = galois K E.
Proof.
rewrite /galois limg_ker0 ?AHom_lker0// separable_aimg.
by case: (boolP (K <= E)%VS) => // /normalField_aimg->.
Qed.

End map_gal.

Import AEnd_FinGroup.

Section normalClosure.
Variable (F0 : fieldType) (L : splittingFieldType F0).
Implicit Types (K E F : {subfield L}).

Lemma separable_aimgr E F s : s \in kAEndf E ->
   separable E (s @: F) = separable E F.
Proof.
rewrite inE => /kHom_kAut_sub/kAHomP s_id; rewrite -(separable_aimg _ _ s).
suff /eq_in_limg->: {in E, s =1 \1%VF} by rewrite lim1g.
by move=> x xE; rewrite lfunE/= s_id.
Qed.

Definition normalClosure (U V : {vspace L}) :=
  (\big[@prodv _ _/1]_(s in kAEndf U) (s @: (U * V)))%VS.

Definition normalClosure_is_aspace E F : is_aspace (normalClosure E F).
Proof.
by rewrite /normalClosure big_prodv_eq_aspace; case: (\big[_/_]_(_ in _) _).
Qed.
Canonical normalClosure_aspace E F := ASpace (normalClosure_is_aspace E F).

Lemma prodv_sub_normalClosure E F : (E * F <= normalClosure E F)%VS.
Proof.
rewrite /normalClosure (bigD1 \1%AF) ?group1//= lim1g.
by rewrite big_prodv_eq_aspace field_subvMr.
Qed.

Lemma normalClosureSl E F : (E <= normalClosure E F)%VS.
Proof.
by rewrite (subv_trans (field_subvMr _ _) (prodv_sub_normalClosure _ _)).
Qed.
#[local] Hint Resolve normalClosureSl : core.

Lemma normalClosureSr E F : (F <= normalClosure E F)%VS.
Proof. exact: subv_trans (field_subvMl _ _) (prodv_sub_normalClosure _ _). Qed.
Hint Resolve normalClosureSr : core.

Lemma normalClosure_normal E F : normalField E (normalClosure E F).
Proof.
apply/'forall_implyP => s s_end; apply/eqP.
rewrite /normalClosure (big_morph _ (aimgM _) (aimg1 _)).
under eq_bigr => s' do rewrite -limg_comp.
under eq_bigr => s' do have -> : (s \o s')%VF = 'R%act s' s by [].
have /(reindex_astabs 'R _) : s \in ('N(kAEndf E | 'R))%g by rewrite astabsR/=.
by move/(_ _ _ _ (fun i => i @: (E * F))%AS); rewrite !big_prodv_eq_aspace => <-.
Qed.
#[local] Hint Resolve normalClosure_normal : core.

Lemma normalClosure_separable E F : separable E F ->
   separable E (normalClosure E F).
Proof.
move=> sepEF; rewrite separable_big_prodv big_andE; apply/forall_inP => g ggal.
by rewrite separable_aimgr// separable_prodv separable_refl.
Qed.

Lemma normalClosure_galois E F : separable E F -> galois E (normalClosure E F).
Proof.
move=> sepEF; rewrite /galois.
by rewrite normalClosureSl normalClosure_separable// normalClosure_normal.
Qed.
#[local] Hint Resolve normalClosure_galois : core.

Lemma normalClosureP E F K' : (E <= K')%VS -> (F <= K')%VS ->
  normalField E K' -> (normalClosure E F <= K')%VS.
Proof.
move=> EK' FK' /'forall_implyP/(_ _ _)/eqP/= sK'.
apply/big_prod_subfieldP => /= u uEF; rewrite rpred_prod// => s s_end.
by apply/subvP: (uEF s s_end); rewrite -(sK' _ s_end) limgS// prodv_sub.
Qed.

Lemma galoisClosureP E F K' : (F <= K')%VS ->
  galois E K' -> (normalClosure E F <= K')%VS.
Proof. by move=> EK' /and3P[FK' _ ] /normalClosureP; apply. Qed.

Lemma normalClosure_id E F : (E <= F)%VS -> normalField E F ->
   normalClosure E F = F.
Proof.
by move=> EF nEF; apply/eqP; rewrite eqEsubv/= normalClosureSr normalClosureP.
Qed.

Lemma galoisClosure_id E F : galois E F -> normalClosure E F = F.
Proof. by move=> /and3P[EF _ /normalClosure_id->]. Qed.

Definition solvable_ext (E F : {vspace L}) :=
  separable E F && solvable 'Gal(normalClosure E F / E).

Lemma char0_solvable_extE E F : has_char0 L ->
  solvable_ext E F = solvable 'Gal(normalClosure E F / E).
Proof. by rewrite /solvable_ext => /char0_separable->. Qed.

Lemma solvable_extP (E F : {subfield L}) :
  reflect (exists K : {subfield L},
            [&& (F <= K)%VS, galois E K & solvable 'Gal(K / E)])
          (solvable_ext E F).
Proof.
apply: (iffP idP) => [/andP[sepEF solEF]|[K /and3P[FK galEK solEK]]].
  exists [aspace of normalClosure E F].
  by rewrite normalClosure_galois ?normalClosureSr.
have MsubK := galoisClosureP FK galEK; rewrite /solvable_ext.
have sepEF : separable E F by case/and3P: galEK => [_ /separableSr->].
have /and3P [EsubM _ EnormM] := (normalClosure_galois sepEF).
by rewrite -(isog_sol (normalField_isog galEK _ _)) ?EsubM ?quotient_sol ?andbT.
Qed.

Lemma solvable_ext_refl E : solvable_ext E E.
Proof.
by apply/solvable_extP; exists E; rewrite subvv galois_refl/= galvv solvable1.
Qed.
#[local] Hint Resolve solvable_ext_refl : core.

Lemma sub_solvable_ext F K E :
  (E <= F)%VS -> solvable_ext K F -> solvable_ext K E.
Proof.
move=> EF /solvable_extP[M /and3P[Msuper galKM solKM]].
by apply/solvable_extP; exists M; rewrite (subv_trans EF) ?galKM.
Qed.

Lemma solvable_prodv (k E F : {subfield L}) :
  (k <= F)%VS -> solvable_ext k E -> solvable_ext F (E * F)%AS.
Proof.
move=> kF /andP[sepkE solkE]; apply/solvable_extP => //.
exists ([aspace of normalClosure k E] * F)%AS.
rewrite (@galois_prodvr _ _ k) ?normalClosure_galois//.
rewrite ?prodvSl ?sub_normalClosure//=.
rewrite (isog_sol (galois_isog (normalClosure_galois _) _))//.
rewrite (solvableS _ solkE)// galS// subv_cap kF.
by rewrite galois_subW ?normalClosure_galois.
Qed.

Import AEnd_FinGroup.

Lemma solvable_ext_trans (F k E : {subfield L}) : (k <= F <= E)%VS ->
  solvable_ext k F -> solvable_ext F E -> solvable_ext k E.
Proof.
move=> /andP[kF FE] solkF solFE.
move: (solkF) (solFE) => /andP[sepkF solmkF] /andP[sepFE solmFE].
have sepkE := separable_trans sepFE.
have /solvable_extP [/= l /and3P[EKl galKl subl]] :=
  solvable_prodv (normalClosureSr k F) solFE.
apply/solvable_extP; exists [aspace of normalClosure k l] => /=.
have galkK := normalClosure_galois sepkF.
set K := normalClosure k F in galkK galKl subl EKl *.
have /and3P [kK sepkK normkK] := galkK.
have /and3P [Kl sepKl normKl] := galKl.
have sepkl := separable_trans sepkK sepKl.
have kl := subv_trans kK Kl.
rewrite normalClosure_galois ?(subv_trans _ (normalClosureSr _ _))//=; last first.
  by rewrite (subv_trans _ EKl)//= field_subvMr.
have KM : (K <= normalClosure k l)%VS := subv_trans Kl (normalClosureSr _ _).
have kKM : (k <= K <= normalClosure k l)%VS by rewrite kK KM.
rewrite (series_sol (normalField_normal _ normkK))//= -/K.
rewrite (isog_sol (normalField_isog _ _ _)) ?normalClosure_galois//=.
rewrite [X in _ && X]solmkF andbT /normalClosure.
under eq_bigr do rewrite /= (prodv_idPr _)//.
rewrite big_prodv_eq_aspace big_enum_val/=.
have /'forall_implyP/(_ _ _)/eqP/= sK := galois_normalW galkK.
have gKl (i : 'I_#|kAEndf k|) : galois K (enum_val i @: l)%AS.
  move: (enum_val _) (enum_valP i) => s s_end.
  have /splitting_galoisField[/= p [pK p_sep [rs p_eq <-]]] := galKl.
  apply/splitting_galoisField; exists (map_poly s p); split => //=.
  - by rewrite -(sK _ s_end) mapf_polyOver.
  - by rewrite separable_map.
  - rewrite aimg_adjoin_seq -{1}(sK _ s_end); exists (map s rs) => //.
    by rewrite -map_prod_XsubC eqp_map.
rewrite -(injm_sol (gal_big_prodv_cast_inj gKl))//.
rewrite (solvableS (img_gal_big_prodv_cast_sub _)) ?sol_setXn// => i /=.
move: (enum_val _) (enum_valP i) => s s_end; rewrite -(sK _ s_end).
by rewrite -img_map_gal/= morphim_sol.
Qed.

End normalClosure.

#[global] Hint Resolve normalClosureSl : core.
#[global] Hint Resolve normalClosureSr : core.
#[global] Hint Resolve normalClosure_normal : core.
#[global] Hint Resolve solvable_ext_refl : core.

Lemma aimg_normalClosure (F0 : fieldType) (L L' : splittingFieldType F0)
  (iota : 'AHom(L, L')) (K E : {subfield L}) :
  (iota @: normalClosure K E)%VS = normalClosure (iota @: K) (iota @: E).
Proof.
set M' := normalClosure (iota @: _) _; have iK0 := AHom_lker0 iota.
have M'sub : (M' <= iota @: normalClosure K E)%VS.
  by rewrite normalClosureP ?limgS//= normalField_aimg/=.
apply/eqP; rewrite eqEsubv M'sub /M'.
have /sub_aimgP[/= M ME] : (M' <= iota @: fullv)%VS.
  by apply: subv_trans M'sub _; rewrite limgS ?subvf.
have KM : (K <= M)%VS by rewrite -(limg_ker0 _ _ iK0) ME/= normalClosureSl.
rewrite -ME limgS// normalClosureP//.
  by rewrite -(limg_ker0 _ _ iK0) ME/= normalClosureSr.
by rewrite -(normalField_aimg iota)// ME// normalClosure_normal.
Qed.

Lemma solvable_ext_aimg (F0 : fieldType) (L L' : splittingFieldType F0)
  (iota : 'AHom(L, L')) (E F : {subfield L}) :
  solvable_ext (iota @: E) (iota @: F) = solvable_ext E F.
Proof.
rewrite /solvable_ext separable_aimg; have [sepEF|]//= := boolP (separable _ _).
by rewrite -aimg_normalClosure// -img_map_gal injm_sol ?map_gal_inj ?subsetT.
Qed.


Require Import LibLN.
Require Import LibTactics.
Require Import List.

Require Import type subst coercion.

Inductive tff : type -> Prop :=
| tfBVar : forall n, tff (TBVar n)
| tfArrow : forall t1 t2, tff t1 -> tff t2 -> tff (TArrow t1 t2)
| tfTycon : forall tycon, tff (TTycon tycon)
| tfApp : forall t1 t2, tff t1 -> tff t2 -> tff (TApp t1 t2).

Definition good_tff axs := forall C ks f typat target,
  binds C (mkAxiom ks f typat target) axs -> tff typat.

Inductive Good G : Prop :=
| mkGood :
    good_tff G ->
    Good G.

Ltac invert_good :=
  match goal with
    | [ Hgood : Good _ |- _ ] => inverts Hgood as; introv Hgood_tff
  end.


Require Import List.
Export ListNotations.

Require Import PeanoNat.
Require Import Lia.

Require Import Ensembles.
Require Import K_Syntax.
Require Import K_Kripke_sem.

(* Define the notion of bisimulation. *)

Definition bisimulation (M0 M1 : kmodel) (B : (@nodes M0) -> (@nodes M1) -> Prop) : Prop :=
  forall (w0 : @nodes M0) (w1 : @nodes M1), (B w0 w1) ->
 (* B1 *) ((forall p, (@val M0) w0 p <-> (@val M1) w1 p) /\
 (* B2 *) (forall v1, ((@reachable M1) w1 v1) -> (exists v0, ((@reachable M0) w0 v0) /\ (B v0 v1))) /\
 (* B3 *) (forall v0, ((@reachable M0) w0 v0) -> (exists v1, ((@reachable M1) w1 v1) /\ (B v0 v1)))).

(* Show that bisimulation implies logical equivalence. *)

Lemma bisimulation_imp_modal_equiv : forall M0 M1 B,
  (bisimulation M0 M1 B) ->
  (forall A w0 w1, (B w0 w1) -> ((wforces M0 w0 A) <-> (wforces M1 w1 A))).
Proof.
intros M0 M1 B H.
induction A ; split ; intro.
  * simpl. simpl in H1. unfold bisimulation in H. pose (H w0 w1 H0).
    destruct a. apply H2. auto.
  * simpl. simpl in H1. unfold bisimulation in H. pose (H w0 w1 H0).
    destruct a. apply H2. auto.
  * simpl. inversion H1.
  * simpl. inversion H1.
  * simpl. simpl in H1. intros. pose (IHA1 w0 w1 H0).
    apply i in H2. apply H1 in H2. pose (IHA2 w0 w1 H0).
    apply i0 in H2. auto.
  * simpl. simpl in H1. intros. pose (IHA1 w0 w1 H0).
    apply i in H2. apply H1 in H2. pose (IHA2 w0 w1 H0).
    apply i0 in H2. auto.
  * simpl. simpl in H1. unfold bisimulation in H. intros.
    pose (H w0 w1 H0). destruct a. destruct H4. apply H4 in H2.
    destruct H2. apply IHA with (w0:=x) ; auto. destruct H2 ; auto.
    apply H1 ; auto. destruct H2 ; auto.
  * simpl. simpl in H1. unfold bisimulation in H. intros.
    pose (H w0 w1 H0). destruct a. destruct H4. apply H5 in H2.
    destruct H2. apply IHA with (w1:=x) ; auto. destruct H2 ; auto.
    apply H1 ; auto. destruct H2 ; auto.
Qed.


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

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

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

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

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

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

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

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

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

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

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


Require Export Coq.Unicode.Utf8.
Require Export Coq.Program.Equality.
Require Export Coq.Program.Tactics.

(******************************************************************************)
(* Representation of types.                                                   *)
(******************************************************************************)

Inductive Ty : Set :=
  | tvar (X : nat)
  | tarr (T1 T2 : Ty)
  | tall (T : Ty)
  | tprod (T1 T2 : Ty).

(******************************************************************************)
(* Representation of terms.                                                   *)
(******************************************************************************)

Inductive Pat : Set :=
  | pvar
  | pprod (p1 p2: Pat).

Inductive Tm : Set :=
  | var  (x  : nat)
  | abs  (T  : Ty) (t  : Tm)
  | app  (t1 : Tm) (t2 : Tm)
  | tabs (t  : Tm)
  | tapp (t  : Tm) (T  : Ty)
  | prod (t1 : Tm) (t2 : Tm)
  | lett (p : Pat) (s : Tm) (t : Tm) .

(* Calculates the number of cariables bound in a pattern. *)
Fixpoint bindPat (p : Pat) : nat :=
  match p with
   | pvar        => 1
   | pprod p1 p2 => bindPat p2 + bindPat p1
  end.

(******************************************************************************)
(* Representation of contexts, extensions.                                    *)
(******************************************************************************)

Inductive Env : Set :=
  | empty
  | etvar (Γ : Env)
  | evar  (Γ : Env) (T : Ty).


Require Export ProjectiveGeometry.Dev.basic_plane_facts.

Section s_ProjectivePlane'ToProjectivePlane.

Context `{PP : ProjectivePlane'}.
Context `{EP : EqDecidability Point}.

(** M and P are the same and lie at the meeting point between l1 and l2 **)

Lemma case1 : forall M N O P Q R : Point, forall l1 l2 : Line,
  l1 <> l2 ->
  ~ M [==] N /\ ~ M [==] O /\ ~ N [==] O /\ Incid M l1 /\ Incid N l1 /\ Incid O l1 ->
  ~ P [==] Q /\ ~ P [==] R /\ ~ Q [==] R /\ Incid P l2 /\ Incid Q l2 /\ Incid R l2 ->
  Incid M l2 -> Incid P l1 ->
  {A : Point & {B : Point & {C : Point & {D : Point |
          forall l : Line,
            ~ A [==] B /\ ~ A [==] C /\ ~ A [==] D /\ ~ B [==] C /\ ~ B [==] D /\ ~ C [==] D /\
            (Incid A l /\ Incid B l -> ~ Incid C l /\ ~ Incid D l) /\
            (Incid A l /\ Incid C l -> ~ Incid B l /\ ~ Incid D l) /\
            (Incid A l /\ Incid D l -> ~ Incid C l /\ ~ Incid B l) /\
            (Incid C l /\ Incid B l -> ~ Incid A l /\ ~ Incid D l) /\
            (Incid D l /\ Incid B l -> ~ Incid C l /\ ~ Incid A l) /\
            (Incid C l /\ Incid D l -> ~ Incid B l /\ ~ Incid A l)}}}}.
Proof.
intros M N O P Q R l1 l2 H1 H2 H3 HMl2 HPl1.
intuition.
assert (~Incid N l2).
intro HNl2.
generalize (a2_unique l1 l2 M N H1 H6 HMl2 H8 HNl2); intros H'.
rewrite H' in *.
apply H; trivial.
assert (~Incid O l2).
intro HOl2.
generalize (a2_unique l1 l2 M O H1 H6 HMl2 H11 HOl2); intros H'.
rewrite H' in *.
apply H3; trivial.
assert (~Incid Q l1).
intros HQl1.
generalize (a2_unique l1 l2 P Q H1 HPl1 H7 HQl1 H9); intros H'.
rewrite H' in *.
apply H2; trivial.
assert (~Incid R l1).
intros HRl1.
generalize (a2_unique l1 l2 P R H1 HPl1 H7 HRl1 H12); intros H'.
rewrite H' in *.
apply H0; trivial.
exists N.
exists O.
exists Q.
exists R.
intros l.
split.
assumption.
split.
intros HNQ.
rewrite HNQ in *;contradiction.
split.
intros HNR.
rewrite HNR in *;contradiction.
split.
intros HOQ.
rewrite HOQ in *;contradiction.
split.
intros HOR.
rewrite HOR in *;contradiction.
split.
assumption.
split.
intros (Hnew1, Hnew2).
generalize (a1_unique N O l l1 H4 Hnew1 Hnew2 H8 H11); intros H'.
subst l.
solve[intuition].
split.
intros (Hnew1, Hnew2).
split.
intros HOl.
generalize (a1_unique N O l l1 H4 Hnew1 HOl H8 H11); intros H'.

subst l.
solve[intuition].
intros HRl.
generalize (a1_unique Q R l l2 H5 Hnew2 HRl H9 H12) ; intros H'.
subst l.
solve[intuition].

split.
intros (Hnew1,Hnew2).
split.
intros HQl.
generalize (a1_unique Q R l l2 H5 HQl Hnew2 H9 H12) ; intros H'.
subst l.
solve[intuition].
intros HOl.
generalize (a1_unique N O l l1 H4 Hnew1 HOl H8 H11); intros H'.
subst l.
solve[intuition].

split.
intros (Hnew1, Hnew2).
split.
intros HNl.
generalize (a1_unique N O l l1 H4 HNl Hnew2 H8 H11); intros H'.
subst l.
solve[intuition].
intros HRl.
generalize (a1_unique Q R l l2 H5 Hnew1 HRl H9 H12) ; intros H'.
subst l.
solve[intuition].

split.
intros (Hnew1,Hnew2).
split.
intros HQl.
generalize (a1_unique Q R l l2 H5 HQl Hnew1 H9 H12) ; intros H'.
subst l.
solve[intuition].
intros HNl.
generalize (a1_unique N O l l1 H4 HNl Hnew2 H8 H11); intros H'.
subst l.
solve[intuition].
intros (Hnew1, Hnew2).
generalize (a1_unique Q R l l2 H5 Hnew1 Hnew2 H9 H12) ; intros H'.
subst l.
solve[intuition].
Qed.

Lemma case2 : forall M N O P Q R : Point, forall l1 l2 : Line,
  l1 <> l2 ->
  ~ M [==] N /\ ~ M [==] O /\ ~ N [==] O /\ Incid M l1 /\ Incid N l1 /\ Incid O l1 ->
  ~ P [==] Q /\ ~ P [==] R /\ ~ Q [==] R /\ Incid P l2 /\ Incid Q l2 /\ Incid R l2 ->
  Incid M l2 -> ~Incid P l1 -> ~Incid Q l1 -> ~Incid R l1 ->
  {A : Point & {B : Point & {C : Point & {D : Point |
          forall l : Line,
            ~ A [==] B /\ ~ A [==] C /\ ~ A [==] D /\ ~ B [==] C /\ ~ B [==] D /\ ~ C [==] D /\
            (Incid A l /\ Incid B l -> ~ Incid C l /\ ~ Incid D l) /\
            (Incid A l /\ Incid C l -> ~ Incid B l /\ ~ Incid D l) /\
            (Incid A l /\ Incid D l -> ~ Incid C l /\ ~ Incid B l) /\
            (Incid C l /\ Incid B l -> ~ Incid A l /\ ~ Incid D l) /\
            (Incid D l /\ Incid B l -> ~ Incid C l /\ ~ Incid A l) /\
            (Incid C l /\ Incid D l -> ~ Incid B l /\ ~ Incid A l)}}}}.
Proof.
intros M N O P Q R l1 l2 H1 H2 H3 HMl2 HPl1 HQl1 HRl1.
intuition.
assert (~Incid N l2).
intro HNl2.
generalize (a2_unique l1 l2 M N H1 H6 HMl2 H8 HNl2); intros H'.
rewrite H' in *.
apply H; trivial.
assert (~Incid O l2).
intro HOl2.
generalize (a2_unique l1 l2 M O H1 H6 HMl2 H11 HOl2); intros H'.
rewrite H' in *.
apply H3; trivial.
exists N.
exists R.
exists Q.
exists O.
intros l.
split.
intros HNR.
rewrite HNR in *;contradiction.
split.
intros HNQ.
rewrite HNQ in *;contradiction.
split.
assumption.
split.
solve[intuition].
split.
intros HRO.
rewrite HRO in *;contradiction.
split.
intros HQO.
rewrite HQO in *;contradiction.
split.
intros (Hnew1,Hnew2).
split.
intros HQl.
generalize (a1_unique Q R l l2 H5 HQl Hnew2 H9 H12); intros H'.
subst l.
solve[intuition].
intros HOl.
generalize (a1_unique N O l l1 H4 Hnew1 HOl H8 H11); intros H'.
subst l.
solve[intuition].
split.
intros (Hnew1, Hnew2).
split.
intros HRl.
generalize (a1_unique Q R l l2 H5 Hnew2 HRl H9 H12); intros H'.
subst l.
solve[intuition].
intros HOl.
generalize (a1_unique N O l l1 H4 Hnew1 HOl H8 H11); intros H'.
subst l.
solve[intuition].
split.
intros (Hnew1, Hnew2).
generalize (a1_unique N O l l1 H4 Hnew1 Hnew2 H8 H11); intros H'.
subst l.
solve[intuition].
split.
intros (Hnew1, Hnew2).
generalize (a1_unique Q R l l2 H5 Hnew1 Hnew2 H9 H12); intros H'.
subst l.
solve[intuition].
split.
intros (Hnew1, Hnew2).
split.
intros HQl.
generalize (a1_unique Q R l l2 H5 HQl Hnew2 H9 H12); intros H'.
subst l.
solve[intuition].
intros HNl.
generalize (a1_unique N O l l1 H4 HNl Hnew1 H8 H11); intros H'.
subst l.
solve[intuition].
intros (Hnew1, Hnew2).
split.
intros HRl.
generalize (a1_unique Q R l l2 H5 Hnew1 HRl H9 H12); intros H'.
subst l.
solve[intuition].
intros HNl.
generalize (a1_unique N O l l1 H4 HNl Hnew2 H8 H11); intros H'.
subst l.
solve[intuition].
Qed.

(** case2 with l1 and l2 inverted *)
Lemma case3 : forall M N O P Q R : Point, forall l1 l2 : Line,
  l1 <> l2 ->
  ~ M [==] N /\ ~ M [==] O /\ ~ N [==] O /\ Incid M l1 /\ Incid N l1 /\ Incid O l1 ->
  ~ P [==] Q /\ ~ P [==] R /\ ~ Q [==] R /\ Incid P l2 /\ Incid Q l2 /\ Incid R l2 ->
  Incid P l1 -> ~Incid M l2 -> ~Incid N l2 -> ~Incid O l2 ->
  {A : Point & {B : Point & {C : Point & {D : Point |
          forall l : Line,
            ~ A [==] B /\ ~ A [==] C /\ ~ A [==] D /\ ~ B [==] C /\ ~ B [==] D /\ ~ C [==] D /\
            (Incid A l /\ Incid B l -> ~ Incid C l /\ ~ Incid D l) /\
            (Incid A l /\ Incid C l -> ~ Incid B l /\ ~ Incid D l) /\
            (Incid A l /\ Incid D l -> ~ Incid C l /\ ~ Incid B l) /\
            (Incid C l /\ Incid B l -> ~ Incid A l /\ ~ Incid D l) /\
            (Incid D l /\ Incid B l -> ~ Incid C l /\ ~ Incid A l) /\
            (Incid C l /\ Incid D l -> ~ Incid B l /\ ~ Incid A l)}}}}.
Proof.
intros M N O P Q R l1 l2 H1 H2 H3 HPl1 HMl2 HNl2 HOl2.
eapply case2 with (l1:=l2) (l2:=l1);eauto.
Qed.

(** none of M, N, O, P, Q, and R are at the meeting point of l1 and l2 *)
Lemma case4 : forall M N O P Q R : Point, forall l1 l2 : Line,
  l1 <> l2 ->
  ~ M [==] N /\ ~ M [==] O /\ ~ N [==] O /\ Incid M l1 /\ Incid N l1 /\ Incid O l1 ->
  ~ P [==] Q /\ ~ P [==] R /\ ~ Q [==] R /\ Incid P l2 /\ Incid Q l2 /\ Incid R l2 ->
  ~Incid P l1 -> ~Incid Q l1 -> ~Incid R l1 -> ~Incid M l2 -> ~Incid N l2 -> ~Incid O l2 ->
  {A : Point & {B : Point & {C : Point & {D : Point |
          forall l : Line,
            ~ A [==] B /\ ~ A [==] C /\ ~ A [==] D /\ ~ B [==] C /\ ~ B [==] D /\ ~ C [==] D /\
            (Incid A l /\ Incid B l -> ~ Incid C l /\ ~ Incid D l) /\
            (Incid A l /\ Incid C l -> ~ Incid B l /\ ~ Incid D l) /\
            (Incid A l /\ Incid D l -> ~ Incid C l /\ ~ Incid B l) /\
            (Incid C l /\ Incid B l -> ~ Incid A l /\ ~ Incid D l) /\
            (Incid D l /\ Incid B l -> ~ Incid C l /\ ~ Incid A l) /\
            (Incid C l /\ Incid D l -> ~ Incid B l /\ ~ Incid A l)}}}}.
Proof.
intros M N O P Q R l1 l2 H1 H2 H3 HPl1 HQl1 HRl1 HMl2 HNl2 HOl2.
intuition.
exists N.
exists R.
exists Q.
exists O.
intros l.
split.
intros HNR.
rewrite HNR in *;contradiction.
split.
intros HNQ.
rewrite HNQ in *;contradiction.
split.
assumption.
split.
intros HRQ.
solve[intuition].
split.
intros HRO.
rewrite HRO in *;contradiction.
split.
intros HQO.
rewrite HQO in *;contradiction.
split.
intros (Hnew1,Hnew2).
split.
intros HQl.
generalize (a1_unique Q R l l2 H5 HQl Hnew2 H9 H12); intros H'.
subst l.
solve[intuition].
intros HOl.
generalize (a1_unique N O l l1 H4 Hnew1 HOl H8 H11); intros H'.
subst l.
solve[intuition].
split.
intros (Hnew1, Hnew2).
split.
intros HRl.
generalize (a1_unique Q R l l2 H5 Hnew2 HRl H9 H12); intros H'.
subst l.
solve[intuition].
intros HOl.
generalize (a1_unique N O l l1 H4 Hnew1 HOl H8 H11); intros H'.
subst l.
solve[intuition].
split.
intros (Hnew1, Hnew2).
generalize (a1_unique N O l l1 H4 Hnew1 Hnew2 H8 H11); intros H'.
subst l.
solve[intuition].
split.
intros (Hnew1, Hnew2).
generalize (a1_unique Q R l l2 H5 Hnew1 Hnew2 H9 H12); intros H'.
subst l.
solve[intuition].
split.
intros (Hnew1, Hnew2).
split.
intros HQl.
generalize (a1_unique Q R l l2 H5 HQl Hnew2 H9 H12); intros H'.
subst l.
solve[intuition].
intros HNl.
generalize (a1_unique N O l l1 H4 HNl Hnew1 H8 H11); intros H'.
subst l.
solve[intuition].
intros (Hnew1, Hnew2).
split.
intros HRl.
generalize (a1_unique Q R l l2 H5 Hnew1 HRl H9 H12); intros H'.
subst l.
solve[intuition].
intros HNl.
generalize (a1_unique N O l l1 H4 HNl Hnew2 H8 H11); intros H'.
subst l.
solve[intuition].
Qed.

Definition a3 : {A:Point & {B :Point & {C:Point & {D :Point |
  (forall l :Line, ~ A [==] B /\ ~ A [==] C /\ ~ A [==] D /\ ~ B [==] C /\ ~ B [==] D /\ ~ C [==] D /\
    (Incid A l /\ Incid B l -> ~Incid C l /\ ~Incid D l)
    /\ (Incid A l /\ Incid C l -> ~Incid B l /\ ~Incid D l)
    /\  (Incid A l /\ Incid D l -> ~Incid C l /\ ~Incid B l)
    /\  (Incid C l /\ Incid B l -> ~Incid A l /\ ~Incid D l)
    /\ (Incid D l /\ Incid B l -> ~Incid C l /\ ~Incid A l)
    /\  (Incid C l /\ Incid D l -> ~Incid B l /\ ~Incid A l))}}}}.
Proof.
generalize a3_1 a3_2.
intros H1 H2.
elim H2; clear H2; intros l1 Hl1.
elim Hl1; clear Hl1; intros l2 HdistL.
generalize (H1 l1); intros Hl1.
generalize (H1 l2); intros Hl2.
clear H1.
elim Hl1; clear Hl1; intros A1 HA1.
elim HA1; clear HA1; intros B1 HB1.
elim HB1; clear HB1; intros C1 H1.
elim Hl2; clear Hl2; intros A2 HA2.
elim HA2; clear HA2; intros B2 HB2.
elim HB2; clear HB2; intros C2 H2.
elim (incid_dec A1 l2).
elim (incid_dec A2 l1).
intros Ha Hb.
eapply case1;eauto.
intros Ha Hb.
elim (incid_dec B1 l2).
intros Hc.
assert (~Incid B1 l2).
intuition.
generalize (a2_unique l1 l2 A1 B1 HdistL H6 Hb H8 Hc); intros H'.
rewrite H' in *.
solve[intuition].
solve[intuition].
intros Hc.
elim (incid_dec C1 l2).
intros Hd.
assert (~Incid C1 l2).
intuition.
generalize (a2_unique l1 l2 A1 C1 HdistL H6 Hb H11 Hd); intros H'.
rewrite H' in *.
solve[intuition].
solve[intuition].
intros Hd.
elim (incid_dec B2 l1).
intros H.
eapply case1 with (M:=A1) (N:=B1) (O:=C1) (P:=B2) (Q:=A2) (R:=C2);eauto;intuition.
intros He.
elim (incid_dec C2 l1).
intros H.
eapply case1 with (M:=A1) (N:=B1) (O:=C1) (P:=C2) (Q:=A2) (R:=B2);eauto;intuition.
intros Hf.
eapply case2;eauto.
intros Ha.
elim (incid_dec B1 l2).
intros Hb.
elim (incid_dec A2 l1).
intros Hc.
eapply case1 with (M:=B1) (N:=A1) (O:=C1) (P:=A2) (Q:=B2) (R:=C2);eauto;intuition.
intros Hc.
elim (incid_dec B2 l1).
intros Hd.
eapply case1 with (M:=B1) (N:=A1) (O:=C1) (P:=B2) (Q:=A2) (R:=C2);eauto;intuition.
intros He.
elim (incid_dec C2 l1).
intros Hf.
eapply case1 with (M:=B1) (N:=A1) (O:=C1) (P:=C2) (Q:=A2) (R:=B2);eauto;intuition.
intros Hf.
eapply case2 with (M:=B1) (N:=A1) (O:=C1) (P:=A2) (Q:=B2) (R:=C2);eauto;intuition.
intros Hb.
elim (incid_dec C1 l2).
intros Hc.
elim (incid_dec A2 l1).
intros Hd.
eapply case1 with (M:=C1) (N:=A1) (O:=B1) (P:=A2) (Q:=B2) (R:=C2);eauto;intuition.
intros Hd.
elim (incid_dec B2 l1).
intros He.
eapply case1 with (M:=C1) (N:=A1) (O:=B1) (P:=B2) (Q:=A2) (R:=C2);eauto;intuition.
intros He.
elim (incid_dec C2 l1).
intros Hf.
eapply case1 with (M:=C1) (N:=A1) (O:=B1) (P:=C2) (Q:=A2) (R:=B2);eauto;intuition.
intros Hf.
eapply case2 with (M:=C1) (N:=A1) (O:=B1) (P:=A2) (Q:=B2) (R:=C2);eauto;intuition.
intros Hc.
elim (incid_dec A2 l1).
intros Hd.
eapply case3 with (M:=A1) (N:=B1) (O:=C1) (P:=A2) (Q:=B2) (R:=C2);eauto;intuition.
intros Hd.
elim (incid_dec B2 l1).
intros He.
eapply case3 with (M:=A1) (N:=B1) (O:=C1) (P:=B2) (Q:=A2) (R:=C2);eauto;intuition.
intros He.
elim (incid_dec C2 l1).
intros Hf.
eapply case3 with (M:=A1) (N:=B1) (O:=C1) (P:=C2) (Q:=A2) (R:=B2);eauto;intuition.
intros Hf.
eapply case4;eauto.
Qed.

End s_ProjectivePlane'ToProjectivePlane.


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

Set Implicit Arguments.

Section tortoise_hare_false.

  Variables (X : Type) (eqdec : forall x y : X, { x = y } + { x <> y })
            (f : X -> X) (x0 : X) (H0 : False).

  Fixpoint th_false_rec x y (H : False) : nat :=
    match eqdec x y with
      | left _  => 0
      | right _ => S (th_false_rec (f x) (f (f y)) match H with end)
    end.

  Definition th_false := S (th_false_rec (f x0) (f (f x0)) H0).

End tortoise_hare_false.

Section tortoise_hare_tail_false.

  Variables (X : Type) (eqdec : forall x y : X, { x = y } + { x <> y })
            (f : X -> X) (x0 : X) (H0 : False).

  Definition th_false_tail : nat.
  Proof.
    revert H0.
    generalize 1 (f x0) (f (f x0)).
    refine (fix loop i x y H :=
      match eqdec x y with
        | left _  => i
        | right _ => loop (S i) (f x) (f (f y)) match H with end
      end).
  Defined.

End tortoise_hare_tail_false.

Check th_false.
Print Assumptions th_false.
Recursive Extraction th_false.

Check th_false_tail.
Print Assumptions th_false_tail.
Extraction th_false_tail.

Parameter absurd : False.

(* This one extracts to let rec loop _ = loop () of type unit -> 'a *)

Definition loop X (x : unit) : X :=
   (fix loop _ (H : False) := loop tt (match H with end)) x absurd.

(* This one is of type 'a *)

Definition universal : forall X, X := fun X => loop X tt.

Check loop.
Print Assumptions loop.
Check universal.

(* This one extracts to a general fixpoint over function types
   ie genfix phi is extensionally equal to a fixpoint of phi

   let rec genfix phi x = phi (fun y -> genfix phi y) x
*)

Section general_fixpoint.

  Variables (X Y : Type) (phi : (X -> Y) -> (X -> Y)).

  Definition genfix (x : X) : Y :=
    (fix loop x (H : False) := phi (fun y => loop y (match H with end)) x) x absurd.

End general_fixpoint.


Require Import Coq.Program.Program.
Require Import Coq.Program.Tactics.
Require Import Coq.Classes.Morphisms.
Require Import Coq.Logic.Decidable.
Require Import Coq.Reals.Reals.
Require Import Coquelicot.Rbar.
Require Import Coquelicot.Lim_seq.
Require Import Autosubst.Autosubst.
Require Import Coq.Logic.Classical.
Require Import Coq.Logic.ClassicalDescription.
Require Import Coq.Logic.ClassicalEpsilon.
Require Import Coq.Logic.ProofIrrelevance.

Require Import Biorthogonality.Basics.
Require Import Biorthogonality.Measures.
Require Import Biorthogonality.Syntax.
Require Import Biorthogonality.OpSem.

Set Bullet Behavior "Strict Subproofs".

Open Scope R.

(*** From Evaluations to Measures. *)
(* Definition 5.1 *)
Definition μeval (n : nat) (e : Expr) (K : Kont) (A : Measurable R) : Rbar :=
  integrate (fun σ2 => integrate (fun σ1 => eval A n ⟨ σ1 | e | K | σ2 | 1 ⟩)
                                 μentropy)
            μentropy.

Definition μeval_star (e : Expr) (K : Kont) (A : Measurable R) : Rbar :=
  integrate (fun σ2 => integrate (fun σ1 => eval_star A ⟨ σ1 | e | K | σ2 | 1 ⟩)
                                 μentropy)
            μentropy.

Lemma μeval_nonnegative : forall m e K A,
    Rbar_le 0 (μeval m e K A).
Proof.
  intros.
  unfold μeval.
  replace (Finite 0)
    with (integrate (fun σ2 => (integrate (fun σ1 : Entropy => Rbar_mult (Finite 0) (eval A m ⟨ σ1 | e | K | σ2 | 1 ⟩)) μentropy)) μentropy);
    cycle -1.
  { repeat setoid_rewrite integrate_linear.
    rewrite Rbar_mult_0_l.
    auto.
  }
  repeat (apply integrate_monotonic; intros).
  setoid_rewrite Rbar_mult_0_l.
  apply eval_weight_nonnegative.
  auto.
Qed.

Hint Resolve μeval_nonnegative.

Lemma μeval_star_nonnegative : forall e K A,
    Rbar_le 0 (μeval_star e K A).
Proof.
  intros.
  unfold μeval_star.
  replace (Finite 0)
    with (integrate (fun σ2 => integrate (fun σ1 : Entropy => Rbar_mult (Finite 0) (eval_star A ⟨ σ1 | e | K | σ2 | 1 ⟩)) μentropy) μentropy).
  - repeat (apply integrate_monotonic; intros).
    unfold eval_star.
    rewrite Rbar_mult_0_l.
    rewrite <- Lim_seq_const.
    apply Lim_seq_le_loc.
    unfold Hierarchy.eventually.
    exists 0%nat.
    intros.
    apply eval_weight_nonnegative.
    auto.
  - setoid_rewrite Rbar_mult_0_l.
    setoid_rewrite integrate_0.
    setoid_rewrite integrate_0.
    auto.
Qed.

Hint Resolve μeval_star_nonnegative.

(* Lemma 5.3 part 3 *)
Lemma μeval_index_monotonic : forall (n m : nat) (Hmn: (m <= n)%nat) (e : Expr) (K : Kont) (A : Measurable R),
    Rbar_le (μeval m e K A) (μeval n e K A).
Proof.
  intros.
  unfold μeval.
  repeat (eapply integrate_monotonic; intros).
  rename x into σ2.
  rename x0 into σ1.
  revert e K σ2 σ1.
  intros.
  apply eval_index_monotonic; auto.
Qed.

Hint Resolve μeval_index_monotonic.

(* Lemma 5.3 part 3 *)
Lemma μeval_star_index_monotonic : forall (n : nat) (e : Expr) (K : Kont) (A : Measurable R),
    Rbar_le (μeval n e K A) (μeval_star e K A).
Proof.
  intros.
  unfold μeval, μeval_star.
  repeat (apply integrate_monotonic; intros).
  unfold eval_star.
  intros.
  apply (Lim_seq_monotonic (fun n => eval A n ⟨ _ | e | K | _ | 1 ⟩)).
  intros.
  apply eval_index_monotonic; auto.
Qed.

Hint Resolve μeval_star_index_monotonic.

(* Lemma 5.4 part 4 (but using Lim_seq instead of Sup_seq) *)
Lemma μeval_lim_interchange : forall e K A,
    μeval_star e K A =
    Sup_seq (fun n => μeval n e K A).
Proof.
  intros.
  unfold μeval, μeval_star.
  rewrite split_entropy.
  replace (Sup_seq _)
    with
      (Sup_seq
         (fun n => integrate (fun σ => eval A n ⟨ Entropy_π1 σ | e | K | Entropy_π2 σ | 1 ⟩)
                             μentropy));
    cycle -1.
  { f_equal.
    extensionality n.
    rewrite split_entropy.
    auto.
  }
  rewrite lebesgue_monotone_convergence;
    auto.
  intros.
  apply eval_index_monotonic_1.
  auto.
Qed.

(*** μeval step lemmas *)

(* Shows that all of the following lemmas apply to μeval_star as well. *)

Lemma μeval_0 : forall e K A,
    μeval 0 e K A = 0.
Proof.
  intros.
  unfold μeval.
  cbn.
  repeat rewrite integrate_0.
  auto.
Qed.

Lemma μeval_star_step_1 : forall {e1 e2 K1 K2 A},
    (forall n, μeval (S n) e1 K1 A = μeval n e2 K2 A) ->
    μeval_star e1 K1 A = μeval_star e2 K2 A.
Proof.
  intros.
  repeat rewrite μeval_lim_interchange.
  rewrite Sup_seq_incr_1 at 1; auto.
Qed.

Lemma μeval_star_step : forall j {e1 e2 K1 K2 A},
    (forall n, μeval (j + n) e1 K1 A = μeval n e2 K2 A) ->
    μeval_star e1 K1 A = μeval_star e2 K2 A.
Proof.
  intros.
  repeat rewrite μeval_lim_interchange.
  rewrite Sup_seq_incr_n with (j:=j) at 1; auto.
Qed.

Lemma μeval_star_step_end_1 : forall {e1 K1 A r},
    (forall n, μeval (S n) e1 K1 A = r) ->
    μeval_star e1 K1 A = r.
Proof.
  intros.
  repeat rewrite μeval_lim_interchange.
  rewrite <- Sup_seq_const.
  rewrite Sup_seq_incr_1 at 1; auto.
Qed.

Lemma μeval_star_step_end : forall j {e1 K1 A r},
    (forall n, μeval (j + n) e1 K1 A = r) ->
    μeval_star e1 K1 A = r.
Proof.
  intros.
  repeat rewrite μeval_lim_interchange.
  rewrite <- Sup_seq_const.
  rewrite Sup_seq_incr_n with (j:=j) at 1; auto.
Qed.

(* Lemma 5.4 {lemma-let} *)
Lemma μeval_step_Seq : forall {n e1 e2 K A},
    μeval (S n) (Seq e1 e2) K A = μeval n e1 (e2-:K) A.
Proof.
  intros.
  unfold μeval.
  setoid_rewrite eval_step_Seq.
  assert
    (forall σ2,
        integrate
          (fun σ1 =>
             eval A n ⟨ Entropy_π1 σ1 | e1 | e2 -: K | Entropy_π2 σ1 # σ2 | 1 ⟩) μentropy
        =
        integrate
          (fun σ12 =>
             integrate
               (fun σ11 =>
                  eval A n ⟨ σ11 | e1 | e2 -: K | σ12 # σ2 | 1 ⟩) μentropy) μentropy)
    by (setoid_rewrite split_entropy; auto).
  setoid_rewrite H.
  clear H.
  rewrite split_entropy.
  setoid_rewrite interpolate_join.
  auto.
Qed.

(* Lemma 5.5 {lemma-return} *)
Lemma μeval_step_Return : forall n v e K A,
    VCLOSED v ->
    μeval (S n) v (e-:K) A = μeval n e.[v/] K A.
Proof.
  unfold μeval.
  intros.
  setoid_rewrite (eval_step_Return H).
  setoid_rewrite integrate_entropy_const.
  setoid_rewrite split_entropy.
  trivial.
Qed.

(* Lemma 5.6 {lemma-return} *)
Lemma μeval_step_App : forall n b v K A,
    VCLOSED v ->
    μeval (S n) (App (Fun b) v) K A = μeval n b.[v/] K A.
Proof.
  unfold μeval.
  intros.
  setoid_rewrite eval_step_App.
  trivial.
Qed.

Lemma μeval_step_Op1_Exp : forall n r K A,
    μeval (S n) (Op1 Exp (Const r)) K A = μeval n (Const (Rexp r)) K A.
Proof.
  unfold μeval.
  intros.
  setoid_rewrite eval_step_Op1_Exp.
  trivial.
Qed.

Lemma μeval_step_Op1_Log : forall {n r K A},
    r <> 0 ->
    μeval (S n) (Op1 Log (Const r)) K A =
    μeval n (Const (Rlog r)) K A.
Proof.
  unfold μeval.
  intros.
  setoid_rewrite (eval_step_Op1_Log H).
  trivial.
Qed.

Lemma μeval_step_Op1_Log_0 : forall {n K A},
    μeval (S n) (Op1 Log (Const 0)) K A = 0.
Proof.
  unfold μeval.
  intros.
  unfold eval.
  unfold run.
  cbn.
  destruct Req_EM_T; try contradiction.
  repeat rewrite integrate_0.
  auto.
Qed.

Lemma μeval_step_Op1_Realp_1 : forall {n r K A},
    μeval (S n) (Op1 Realp (Const r)) K A =
    μeval n (Const 1%R) K A.
Proof.
  unfold μeval.
  intros.
  setoid_rewrite eval_step_Op1_Realp_1.
  trivial.
Qed.

Lemma μeval_step_Op1_Realp_0 : forall {n b K A},
    μeval (S n) (Op1 Realp (Fun b)) K A =
    μeval n (Const 0%R) K A.
Proof.
  unfold μeval.
  intros.
  setoid_rewrite eval_step_Op1_Realp_0.
  trivial.
Qed.

Lemma μeval_step_Op2_Plus : forall {n r1 r2 K A},
    μeval (S n) (Op2 Plus (Const r1) (Const r2)) K A =
    μeval n (Const (Rplus r1 r2)) K A.
Proof.
  unfold μeval.
  intros.
  setoid_rewrite eval_step_Op2_Plus.
  trivial.
Qed.

Lemma μeval_step_Op2_Minus : forall {n r1 r2 K A},
    μeval (S n) (Op2 Minus (Const r1) (Const r2)) K A =
    μeval n (Const (Rminus r1 r2)) K A.
Proof.
  unfold μeval.
  intros.
  setoid_rewrite eval_step_Op2_Minus.
  trivial.
Qed.

Lemma μeval_step_Op2_Times : forall {n r1 r2 K A},
    μeval (S n) (Op2 Times (Const r1) (Const r2)) K A =
    μeval n (Const (Rmult r1 r2)) K A.
Proof.
  unfold μeval.
  intros.
  setoid_rewrite eval_step_Op2_Times.
  trivial.
Qed.

Lemma μeval_step_Op2_Div : forall {n r1 r2 K A},
    r2 <> 0 ->
    μeval (S n) (Op2 Div (Const r1) (Const r2)) K A =
    μeval n (Const (Rdiv r1 r2)) K A.
Proof.
  unfold μeval.
  intros.
  setoid_rewrite (eval_step_Op2_Div H).
  trivial.
Qed.

Lemma μeval_step_Op2_Div_0 : forall {n r1 K A},
    μeval (S n) (Op2 Div (Const r1) (Const 0)) K A = 0.
Proof.
  unfold μeval.
  intros.
  unfold eval.
  unfold run.
  cbn.
  destruct Req_EM_T; try contradiction.
  repeat rewrite integrate_0.
  auto.
Qed.

Lemma μeval_step_Op2_Le_1 : forall {n r1 r2 K A},
    r1 <= r2 ->
    μeval (S n) (Op2 Le (Const r1) (Const r2)) K A =
    μeval n (Const 1%R) K A.
Proof.
  unfold μeval.
  intros.
  setoid_rewrite (eval_step_Op2_Le_1 H).
  trivial.
Qed.

Lemma μeval_step_Op2_Le_0 : forall {n r1 r2 K A},
    r2 < r1 ->
    μeval (S n) (Op2 Le (Const r1) (Const r2)) K A =
    μeval n (Const 0%R) K A.
Proof.
  unfold μeval.
  intros.
  setoid_rewrite (eval_step_Op2_Le_0 H).
  trivial.
Qed.

Lemma μeval_step_Op2_Lt_1 : forall {n r1 r2 K A},
    r1 < r2 ->
    μeval (S n) (Op2 Lt (Const r1) (Const r2)) K A =
    μeval n (Const 1%R) K A.
Proof.
  unfold μeval.
  intros.
  setoid_rewrite (eval_step_Op2_Lt_1 H).
  trivial.
Qed.

Lemma μeval_step_Op2_Lt_0 : forall {n r1 r2 K A},
    r2 <= r1 ->
    μeval (S n) (Op2 Lt (Const r1) (Const r2)) K A =
    μeval n (Const 0%R) K A.
Proof.
  unfold μeval.
  intros.
  setoid_rewrite (eval_step_Op2_Lt_0 H).
  trivial.
Qed.

Lemma μeval_step_Cond_true : forall {n r et ef K A},
    0 < r ->
    μeval (S n) (Cond (Const r) et ef) K A =
    μeval n et K A.
Proof.
  unfold μeval.
  intros.
  setoid_rewrite (eval_step_Cond_true H).
  trivial.
Qed.

Lemma μeval_step_Cond_false : forall {n r et ef K A},
    r <= 0 ->
    μeval (S n) (Cond (Const r) et ef) K A =
    μeval n ef K A.
Proof.
  unfold μeval.
  intros.
  setoid_rewrite (eval_step_Cond_false H).
  trivial.
Qed.

(* Lemma 5.7 *)
Lemma μeval_step_Sample : forall n K A,
    μeval (S n) Sample K A =
    integrate (fun σ => μeval n (Const (Entropy_extract σ)) K A) μentropy.
Proof.
  intros.
  unfold μeval.
  setoid_rewrite eval_step_Sample.
  setoid_rewrite tonelli_μentropy at 2.
  setoid_rewrite split_entropy at 3.
  trivial.
Qed.

(* Lemma 5.7 *)
Lemma μeval_step_Factor : forall n r K A,
    (0 < r)%R ->
    μeval (S n) (Factor (Const r)) K A =
    Rbar_mult r (μeval n (Const r) K A).
Proof.
  intros.
  unfold μeval at 1.
  setoid_rewrite (eval_step_Factor H).
  setoid_rewrite Rbar_mult_Finite.
  setoid_rewrite <- integrate_linear.
  setoid_rewrite <- integrate_linear.
  trivial.
Qed.

Require Import Coq.Setoids.Setoid.

Lemma μeval_step_App_Const : forall n r e K A,
    μeval n (App (Const r) e) K A = 0%R.
Proof.
  intros.
  destruct n.
  - apply μeval_0.
  - unfold μeval.
    unfold eval.
    cbn.
    repeat rewrite integrate_entropy_const.
    trivial.
Qed.

Lemma μeval_step_Fun_Knil : forall m b A,
    μeval m (Fun b) Knil A = 0%R.
Proof.
  intros.
  unfold μeval.
  unfold eval.
  destruct m;
    cbn;
    repeat rewrite integrate_0;
    auto.
Qed.

Lemma μeval_step_Factor_Fun : forall b n K A,
    μeval n (Factor (Fun b)) K A = 0%R.
Proof.
  intros.
  unfold μeval.
  destruct n;
    cbn;
    rewrite integrate_0;
    rewrite integrate_0;
    auto.
Qed.

Set Printing Coercions.

Lemma μeval_star_step_Sample: forall (K : Kont) A,
    μeval_star Sample K A =
    integrate (fun σ : Entropy => μeval_star (Const (Entropy_extract σ)) K A) μentropy.
Proof.
  intros K A.
  unfold μeval_star at 1.

  replace (fun σ2' => integrate (fun σ1' => eval_star _ _) μentropy)
    with (fun σ2' =>
            integrate
              (fun σ1' =>
                 eval_star A ⟨ Entropy_π1 σ1' | Const (Entropy_extract (Entropy_π2 σ1')) | K | σ2' | 1 ⟩)
              μentropy);
    revgoals.
  { extensionality σ2'.
    f_equal.
    extensionality σ1'.
    unfold eval_star at 2.
    rewrite <- Lim_seq_incr_1.
    unfold eval_star at 1.
    auto.
  }

  replace (fun σ2' => integrate (fun σ1' => eval_star _ _) _)
    with (fun σ2' =>
            integrate (fun σ2 =>
                         integrate
                           (fun σ1 =>
                              eval_star A ⟨σ1 | Const (Entropy_extract σ2) | K | σ2' | 1⟩)
                           μentropy)
                      μentropy)
    by (extensionality σ'; apply split_entropy).
  rewrite tonelli_μentropy.
  auto.
Qed.

Ltac run_μeval_1 :=
  match goal with
  | [ |- context[ μeval (S ?n) (App (Fun ?b) ?v) ?K ?A ] ] =>
    setoid_replace (μeval (S n) (App (Fun b) v) K A)
      with (μeval n b.[v/] K A)
      by (apply μeval_step_App;
          auto)
  | [ |- context[ μeval (S ?n) (Seq ?e1 ?e2) ?K ?A ] ] =>
    setoid_replace (μeval (S n) (Seq e1 e2) K A)
      with (μeval n e1 (e2-:K) A)
      by (apply μeval_step_Seq)
  | [ |- context[ μeval (S ?n) Sample ?K ?A ] ] =>
    setoid_replace (μeval (S n) Sample K A)
      with (integrate (fun σ => μeval n (Const (Entropy_extract σ)) K A) μentropy)
      by (apply μeval_step_Sample)
  | [ |- context[ μeval (S ?n) (Factor (Const ?r)) ?K ?A ] ] =>
    setoid_replace (μeval (S n) (Factor (Const r)) K A)
      with (Rbar_mult r (μeval n (Const r) K A))
      by (apply μeval_step_Factor;
          destruct (Rle_dec 0 r);
          auto)
  | [ |- context[ μeval (S ?n) ?v (?e-:?K) ?A ] ] =>
    setoid_replace (μeval (S n) v (e-:K) A)
      with (μeval n e.[v/] K A)
      by (apply μeval_step_Return;
          auto)
  | [ |- context[ μeval 0 ?e ?K ?A ] ] =>
    setoid_replace (μeval 0 e K A)
      with 0%R
      by (apply μeval_0;
          auto)
  | [ |- context[ μeval ?n (App (Const ?r) ?v) ?K ?A ] ] =>
    setoid_replace (μeval n (App (Const r) v) K A)
      with 0%R
      by (apply μeval_step_App_Const)
  (* Op1 *)
  | [ |- context[ μeval ?n (Op1 Exp (Const ?r)) ?K ?A ] ] =>
    setoid_replace (μeval n (Op1 Exp (Const r)) K A)
      with (μeval n (Const (Rexp r)) K A)
      by (apply μeval_step_Op1_Exp)
  | [ |- context[ μeval ?n (Op1 Log (Const ?r)) ?K ?A ] ] =>
    setoid_replace (μeval n (Op1 Log (Const r)) K A)
      with (μeval n (Const (Rlog r)) K A)
      by (apply μeval_step_Op1_Log)
  | [ |- context[ μeval ?n (Op1 Realp (Const ?r)) ?K ?A ] ] =>
    setoid_replace (μeval n (Op1 Realp (Const r)) K A)
      with (μeval n (Const 1%R) K A)
      by (apply μeval_step_Op1_Realp_1)
  | [ |- context[ μeval ?n (Op1 Realp (Fun ?b)) ?K ?A ] ] =>
    setoid_replace (μeval n (Op1 Realp (Fun ?b)) K A)
      with (μeval n (Const 0%R) K A)
      by (apply μeval_step_Op1_Realp_0)
  (* Op2 *)
  | [ |- context[ μeval ?n (Op2 Plus (Const ?r1) (Const ?r2)) ?K ?A ] ] =>
    setoid_replace (μeval n (Op2 Plus (Const r1) (Const r2)) K A)
      with (μeval n (Const (Rplus r1 r2)) K A)
      by (apply μeval_step_Op2_Plus)
  | [ |- context[ μeval ?n (Op2 Minus (Const ?r1) (Const ?r2)) ?K ?A ] ] =>
    setoid_replace (μeval n (Op2 Minus (Const r1) (Const r2)) K A)
      with (μeval n (Const (Rminus r1 r2)) K A)
      by (apply μeval_step_Op2_Minus)
  | [ |- context[ μeval ?n (Op2 Times (Const ?r1) (Const ?r2)) ?K ?A ] ] =>
    setoid_replace (μeval n (Op2 Times (Const r1) (Const r2)) K A)
      with (μeval n (Const (Rmult r1 r2)) K A)
      by (apply μeval_step_Op2_Times)
  | [ |- context[ μeval ?n (Op2 Div (Const ?r1) (Const ?r2)) ?K ?A ] ] =>
    setoid_replace (μeval n (Op2 Div (Const r1) (Const r2)) K A)
      with (μeval n (Const (Rdiv r1 r2)) K A)
      by (apply μeval_step_Op2_Div)
  (* Fun Knil *)
  | [ |- context[ μeval ?n (Fun ?b) Knil ?A ] ] =>
    setoid_replace (μeval n (Fun b) Knil A)
      with 0%R
      by (apply μeval_step_Fun_Knil)
  (* Factor Fun *)
  | [ |- context[ μeval ?n (Factor (Fun ?b)) ?K ?A ] ] =>
    setoid_replace (μeval n (Factor (Fun b)) K A)
      with 0%R
      by (apply μeval_step_Factor_Fun)
  | _ => fail "no μeval found"
  end;
  asimpl.

Ltac run_μeval_H_1 H :=
  match goal with
  | [ H : context[ μeval (S ?n) (App (Fun ?b) ?v) ?K ?A ] |- _ ] =>
    setoid_replace (μeval (S n) (App (Fun b) v) K A)
      with (μeval n b.[v/] K A)
      in H
      by (apply μeval_step_App;
          auto)
  | [ H : context[ μeval (S ?n) (Seq ?e1 ?e2) ?K ?A ] |- _ ] =>
    setoid_replace (μeval (S n) (Seq e1 e2) K A)
      with (μeval n e1 (e2-:K) A)
      in H
      by (apply μeval_step_Seq)
  | [ H : context[ μeval (S ?n) Sample ?K ?A ] |- _ ] =>
    setoid_replace (μeval (S n) Sample K A)
      with (integrate (fun σ => μeval n (Const (Entropy_extract σ)) K A) μentropy)
      in H
      by (apply μeval_step_Sample)
  | [ H : context[ μeval (S ?n) (Factor (Const ?r)) ?K ?A ] |- _ ] =>
    setoid_replace (μeval (S n) (Factor (Const r)) K A)
      with (Rbar_mult r (μeval n (Const r) K A))
      in H
      by (apply μeval_step_Factor;
          destruct (Rle_dec 0 r);
          auto)
  | [ H : context[ μeval (S ?n) ?v (?e-:?K) ?A ] |- _ ] =>
    setoid_replace (μeval (S n) v (e-:K) A)
      with (μeval n e.[v/] K A)
      in H
      by (apply μeval_step_Return;
          auto)
  | [ H : context[ μeval 0 ?e ?K ?A ] |- _ ] =>
    setoid_replace (μeval 0 e K A)
      with 0%R
      in H
      by (apply μeval_0;
          auto)
  | [ H : context[ μeval ?n (App (Const _) ?v) ?K ?A ] |- _ ] =>
    setoid_replace (μeval n (App (Const _) v) K A)
      with 0%R
      in H
      by (apply μeval_step_App_Const;
          auto)
  | [ |- context[ μeval ?n (Fun ?b) Knil ?A ] ] =>
    setoid_replace (μeval n (Fun b) Knil A)
      with 0%R
      in H
      by (apply μeval_step_Fun_Knil)
  | [ |- context[ μeval ?n (Factor (Fun ?b)) ?K ?A ] ] =>
    setoid_replace (μeval n (Factor (Fun b)) K A)
      with 0%R
      in H
      by (apply μeval_step_Factor_Fun)
  | _ => fail "no μeval found"
  end;
  asimpl.

Ltac run_μeval := repeat run_μeval_1;
                  try (apply μeval_nonnegative + apply μeval_star_nonnegative).
Ltac run_μevalH H := repeat (run_μeval_H_1 H).

Tactic Notation "run_μeval" "in" ident(H) := run_μevalH H.
Tactic Notation "run_μeval" "in" "*" := in_all (run_μevalH); run_μeval.

Ltac run_μeval_for_helper n :=
  match n with
  | 0%nat => idtac
  | S ?n' =>
    match goal with
    | [ |- context[μeval ?m ?e ?K]] =>
      destruct m;
      [run_μeval; auto; try (apply μeval_nonnegative + apply μeval_star_nonnegative)
      |run_μeval_1; run_μeval_for_helper n'
      ]
    end
  end.

Ltac run_μeval_for n :=
  run_μeval_for_helper n;
  try (apply μeval_nonnegative + apply μeval_star_nonnegative).

Ltac run_μeval_star_for n :=
  first [erewrite (μeval_star_step n);
         [|cbn;
           intros;
           run_μeval;
           reflexivity]
        |erewrite (μeval_star_step_end n);
         [|cbn;
           intros;
           run_μeval;
           reflexivity]].

Lemma pure_steps_monotonic_μeval : forall e K e' K' A,
    (forall σ σK w, step ⟨ σ | e | K | σK | w ⟩ = Some ⟨ σ | e' | K' | σK | w ⟩) ->
    forall n, Rbar_le (μeval n e K A) (μeval n e' K' A).
Proof.
  intros.
  unfold μeval.
  repeat (apply integrate_monotonic; intros).
  apply eval_step_monotonic.
  - auto using Rle_0_1.
  - destruct e; auto.
Qed.

Lemma pure_steps_preserve_μeval_star : forall e K e' K' A,
    (forall σ σK w, step ⟨ σ | e | K | σK | w ⟩ = Some ⟨ σ | e' | K' | σK | w ⟩) ->
    μeval_star e K A = μeval_star e' K' A.
Proof.
  intros.
  unfold μeval_star.
  f_equal.
  extensionality σ2.
  f_equal.
  extensionality σ1.
  unfold eval_star.
  rewrite <- Lim_seq_incr_1.
  f_equal.
  extensionality n.
  erewrite eval_step.
  - reflexivity.
  - apply H.
Qed.

Lemma pure_steps_preserve_μeval : forall n e K e' K' A,
    (forall σ σK w, step ⟨ σ | e | K | σK | w ⟩ = Some ⟨ σ | e' | K' | σK | w ⟩) ->
    μeval (S n) e K A = μeval n e' K' A.
Proof.
  intros.
  unfold μeval.
  f_equal.
  extensionality σ2.
  f_equal.
  extensionality σ1.
  erewrite eval_step.
  - reflexivity.
  - apply H.
Qed.

Local Open Scope nat.

Definition loop := (App (Fun (App (Var 0) (Var 0)))
                        (Fun (App (Var 0) (Var 0)))).

Lemma μeval_loop_0 : forall K A n, μeval n loop K A = 0%R.
Proof.
  induction n using lt_wf_ind; intros.
  destruct n as [|[|]];
    unfold loop;
    run_μeval;
    auto.
Qed.

Lemma μeval_star_loop_0 : forall K A, μeval_star loop K A = 0%R.
Proof.
  intros.
  rewrite μeval_lim_interchange.
  rewrite <- Sup_seq_const.
  apply Sup_seq_ext.
  apply μeval_loop_0.
Qed.