(* $Id: Composition.v,v 1.20 2003/03/13 12:06:17 lcf Exp $ *)

Require Export MoreFunctions.

Section Maps_into_Compacts.

Section Part_Funct.

(* Tex_Prose
\chapter{Composition}

Preservation results for functional composition are treated in this separate file.  We start by defining some auxiliary predicates, and then prove the preservation of continuity through composition and the chain rule for differentiation, both for compact and arbitrary intervals.

\begin{convention} Throughout this section:
\begin{itemize}
\item \verb!a,b:IR! and \verb!I! will denote $[a,b]$;
\item \verb!c,d:IR! and \verb!J! will denote $[a,b]$;
\item \verb!F,F',G,G'! will be partial functions.
\end{itemize}
\end{convention}

\section{Maps into Compacts}

Both continuity and differentiability proofs require extra hypothesis on the functions involved---namely, that every compact interval is mapped into another compact interval.  We define this concept for partial functions, and prove some trivial results.
*)

Variables F,G:PartIR.
Variables a,b:IR.
Hypothesis Hab:a[<=]b.

Variables c,d:IR.
Hypothesis Hcd:c[<=]d.
Local I:=(Compact Hab).

(* Begin_Tex_Verb *)
Hypothesis Hf:(included (Compact Hab) (Pred F)).
(* End_Tex_Verb *)

(* Begin_Tex_Verb *)
Definition maps_into_compacts :=
  (c[<]d)*((included (Compact Hcd) (Pred G))*
  (x:IR)(Hx:(Pred F x))(I x)->(Compact Hcd (F x Hx))).
(* End_Tex_Verb *)

(* Begin_Tex_Verb *)
Hypothesis maps:maps_into_compacts.
(* End_Tex_Verb *)

(* Begin_Tex_Verb *)
Lemma maps_lemma' :
   (x:IR)(Hx:(Pred F x))(I x)->(Compact Hcd (F x Hx)).
(* End_Tex_Verb *)
Inversion_clear maps.
Inversion_clear H0.
Assumption.
Qed.

(* Begin_Tex_Verb *)
Lemma maps_lemma :
  (x:IR)(I x)->(Hx:(Pred F x))(Compact Hcd (F x Hx)).
(* End_Tex_Verb *)
Intros.
Simpl.
Apply maps_lemma'.
Assumption.
Qed.

(* Begin_Tex_Verb *)
Lemma maps_lemma_less : c[<]d.
(* End_Tex_Verb *)
Inversion_clear maps; Assumption.
Qed.

(* Begin_Tex_Verb *)
Lemma maps_lemma_inc : (included (Compact Hcd) (Pred G)).
(* End_Tex_Verb *)
Inversion_clear maps.
Inversion_clear H0.
Assumption.
Qed.

End Part_Funct.

End Maps_into_Compacts.

Section Mapping.

(* Tex_Prose
As was the case for division of partial functions, this condition completely characterizes the domain of the composite function.
*)

Variables F,G:PartIR.
Variables a,b:IR.
Hypothesis Hab:a[<=]b.

Variables c,d:IR.
Hypothesis Hcd:c[<=]d.

(* Begin_Tex_Verb *)
Hypothesis Hf:(included (Compact Hab) (Pred F)).
Hypothesis Hg:(included (Compact Hcd) (Pred G)).
Hypothesis maps:(maps_into_compacts F G a b Hab c d Hcd).
(* End_Tex_Verb *)

(* Begin_Tex_Verb *)
Lemma included_comp : (included (Compact Hab) (Pred G{o}F)).
(* End_Tex_Verb *)
Red.
Intros.
Simpl.
Exists (Hf x H).
Apply Hg.
Apply maps_lemma' with G a b Hab; Assumption.
Qed.

End Mapping.

Section Interval_Continuity.

(* Tex_Prose
\section{Continuity}

We now prove that the composition of two continuous partial functions is continuous.
*)

Variables a,b:IR.
Hypothesis Hab:a[<=]b.
Local I:=(Compact Hab).

Variables c,d:IR.
Hypothesis Hcd:c[<=]d.

Variables F,G:PartIR.

(* Begin_Tex_Verb *)
Hypothesis contF:(Continuous_I Hab F).
Hypothesis contG:(Continuous_I Hcd G).
Hypothesis Hmap:(maps_into_compacts F G a b Hab c d Hcd).
(* End_Tex_Verb *)

(* Begin_Tex_Verb *)
Lemma Continuous_I_comp : (Continuous_I Hab G{o}F).
(* End_Tex_Verb *)
Red.
Elim contF; Intros incF contF'.
Elim contG; Intros incG contG'.
Split.
Exact (included_comp F G a b Hab c d Hcd incF incG Hmap).
Intros.
Elim (contG' e H).
Intros dh H0 H1.
Elim (contF' dh H0).
Intros df H2 H3.
Exists df.
Assumption.
Intros.
Simpl.
Cut (x:IR)(Compact Hab x)->(Hx:?)(Compact Hcd (F x Hx)); Intros.
Apply leEq_wdl with (AbsIR (G ? (incG ? (H7 x H4 (incF x H4))))[-](G ? (incG ? (H7 y H5 (incF y H5))))).
Apply H1; Simpl.
Apply H7; Assumption.
Apply H7; Assumption.
Apply H3; Assumption.
Apply AbsIR_wd; Rational.
Apply maps_lemma with G a b Hab; Simpl; Assumption.
Qed.

End Interval_Continuity.

Section Derivative.

(* Tex_Prose
\section{Derivative}

We now work with the derivative relation and prove the chain rule for partial functions.
*)

Variables F,F',G,G':PartIR.

Variables a,b:IR.
Hypothesis Hab':a[<]b.

Variables c,d:IR.
Hypothesis Hcd':c[<]d.

Local Hab:=(less_leEq ??? Hab').
Local Hcd:=(less_leEq ??? Hcd').
Local I:=(Compact Hab).

(* Begin_Tex_Verb *)
Hypothesis derF:(Derivative_I Hab' F F').
Hypothesis derG:(Derivative_I Hcd' G G').
Hypothesis Hmap:(maps_into_compacts F G a b Hab c d Hcd).
(* End_Tex_Verb *)

(* Begin_Tex_Verb *)
Lemma included_comp' : (included (Compact Hab) (Pred G'{o}F)).
(* End_Tex_Verb *)
Red.
Intros.
Simpl.
Exists (derivative_imp_inc ????? derF x H).
Apply (derivative_imp_inc' ????? derG).
Apply maps_lemma' with G a b Hab; Assumption.
Qed.

(* Begin_Tex_Verb *)
Lemma maps':(maps_into_compacts F G' a b Hab c d Hcd).
(* End_Tex_Verb *)
Inversion_clear Hmap; Inversion_clear H0.
Split.
Assumption.
Split.
Unfold Hcd; Apply derivative_imp_inc' with G; Assumption.
Assumption.
Qed.

(* Begin_Tex_Verb *)
Lemma Derivative_I_comp :
  (Derivative_I Hab' G{o}F (G'{o}F){*}F').
(* End_Tex_Verb *)
Elim derF; Intros incF H1.
Elim H1; Intros incF' H2.
Elim derG; Intros incG H4.
Elim H4; Intros incG' H5.
Clear H1 H4.
Apply Derivative_I_char.
Exact (included_comp ???????? incF incG Hmap).
Exact (included_FMult ??? (included_comp ???????? incF incG' maps') incF').
Intros e He.
LetTac contF' := (deriv_imp_contin'_I ????? Hab derF).
LetTac nF':=(Norm_Funct contF').
Cut Zero[<]One[+]nF'; Intros.
Cut (One[+]nF')[#]Zero.
Intro HnF'.
2: Apply Greater_imp_ap; Assumption.
LetTac alpha:=(One[/]?[//]HnF')[*](e[/]TwoNZ).
LetTac contG' := (deriv_imp_contin'_I ????? Hcd derG).
LetTac nH':=(Norm_Funct contG').
Cut Zero[<]alpha.
Intro Halpha.
Cut Zero[<]alpha[+]nH'; Intros.
Cut (alpha[+]nH')[#]Zero.
Intro HnH'.
2: Apply Greater_imp_ap; Assumption.
LetTac beta:=(One[/]?[//]HnH')[*](e[/]TwoNZ).
Cut (Zero[<]beta).
Intro Hbeta.
Elim (H2 ? Hbeta).
Intros df H1 H3.
Elim (H5 ? Halpha).
Intros dg H4 H6.
Elim (contin_prop ???? (deriv_imp_contin_I ????? Hab derF) ? H4).
Intros dc H7 H8.
Exists (Min dc df).
Apply less_Min; Assumption.
Intros.
Simpl.
LetTac fx:=(F x (ProjS1 Hx)).
LetTac fy:=(F y (ProjS1 Hy)).
LetTac gfx:=(G fx (ProjS2 Hx)).
LetTac gfy:=(G fy (ProjS2 Hy)).
LetTac fx':=(F' x (ProjIR2 Hx')).
LetTac gfx':=(G' (F x (ProjS1 (ProjIR1 Hx'))) (ProjS2 (ProjIR1 Hx'))).
Simpl in fx' gfx'; Fold fx' gfx'.
Apply leEq_wdl with (AbsIR ((gfy[-]gfx)[-]gfx'[*](fy[-]fx))[+]gfx'[*]((fy[-]fx)[-]fx'[*](y[-]x))).
2: Apply AbsIR_wd; Rational.
EApply leEq_transitive.
Apply triangle_IR.
Apply leEq_transitive with
  (alpha[*]nF'[*](AbsIR y[-]x)[+]alpha[*](AbsIR (fy[-]fx)[-]fx'[*](y[-]x)))[+](nH'[*](AbsIR (fy[-]fx)[-]fx'[*](y[-]x))).
Apply plus_resp_leEq_both.
Apply leEq_transitive with alpha[*](AbsIR fy[-]fx).
Unfold gfx'.
Cut (Pred G' fx); Intros.
Apply leEq_wdl with (AbsIR (gfy[-]gfx)[-](G' fx H12)[*](fy[-]fx)).
Unfold gfy gfx; Apply H6; Unfold fx fy.
Apply maps_lemma with G a b Hab; Assumption.
Apply maps_lemma with G a b Hab; Assumption.
Apply H8; Try Assumption.
EApply leEq_transitive.
Apply H11.
Apply Min_leEq_lft.
Apply AbsIR_wd; Unfold fx fy gfx gfy; Rational.
Apply (pfprwd ? G' ? fx (ProjS2 (ProjIR1 Hx'))).
Unfold fx; Rational.
RStepr alpha[*](nF'[*](AbsIR y[-]x)[+](AbsIR (fy[-]fx)[-]fx'[*](y[-]x))).
Apply mult_resp_leEq_lft.
2: Apply less_leEq; Assumption.
Apply leEq_wdl with (AbsIR fx'[*](y[-]x)[+]((fy[-]fx)[-]fx'[*](y[-]x))).
2: Apply un_op_wd_unfolded; Rational.
EApply leEq_transitive.
Apply triangle_IR.
Apply plus_resp_leEq.
EApply leEq_wdl.
2: Apply eq_symmetric_unfolded; Apply AbsIR_resp_mult.
Apply mult_resp_leEq_rht.
2: Apply AbsIR_nonneg.
Unfold fx' nF' I; Apply norm_bnd_AbsIR; Assumption.
EApply leEq_wdl.
2: Apply eq_symmetric_unfolded; Apply AbsIR_resp_mult.
Apply mult_resp_leEq_rht.
2: Apply AbsIR_nonneg.
Unfold gfx' nH'; Apply norm_bnd_AbsIR; Apply maps_lemma with G a b Hab; Assumption.
RStep alpha[*]nF'[*](AbsIR y[-]x)[+](alpha[+]nH')[*](AbsIR (fy[-]fx)[-]fx'[*](y[-]x)).
RStepr e[/]TwoNZ[*](ABSIR y[-]x)[+]e[/]TwoNZ[*](ABSIR y[-]x).
Apply plus_resp_leEq_both.
Apply mult_resp_leEq_rht.
2: Apply AbsIR_nonneg.
Unfold alpha.
RStep nF'[/]?[//]HnF'[*](e[/]TwoNZ).
Stepr One[*](e[/]TwoNZ).
Apply mult_resp_leEq_rht.
2: Apply less_leEq; Apply pos_div_two; Assumption.
Apply shift_div_leEq'.
Apply leEq_less_trans with nF'.
Unfold nF'; Apply positive_norm.
Stepr nF'[+]One; Apply less_plusOne.
Apply less_leEq; RStepr nF'[+]One; Apply less_plusOne.
Apply shift_mult_leEq' with HnH'.
Assumption.
Apply leEq_wdr with beta[*](ABSIR y[-]x).
2: Unfold beta; Rational.
Unfold fx fy fx'; Apply H3; Try Assumption.
EApply leEq_transitive.
Apply H11.
Apply Min_leEq_rht.
Unfold beta.
Step (Zero::IR)[*]Zero; Apply mult_resp_less_both; Try Apply leEq_reflexive.
Apply recip_resp_pos; Assumption.
Apply pos_div_two; Assumption.
Apply leEq_less_trans with nH'.
Unfold nH'; Apply positive_norm.
Step Zero[+]nH'; Apply plus_resp_less_rht; Assumption.
Unfold alpha.
Step (Zero::IR)[*]Zero; Apply mult_resp_less_both; Try Apply leEq_reflexive.
Apply recip_resp_pos; Assumption.
Apply pos_div_two; Assumption.
Apply leEq_less_trans with nF'.
Unfold nF'; Apply positive_norm.
Stepr nF'[+]One; Apply less_plusOne.
Qed.

(* Tex_Prose
The next lemma will be useful when we move on to differentiability.
*)

(* Begin_Tex_Verb *)
Lemma Diffble_I_comp_aux : (Diffble_I Hab' G{o}F).
(* End_Tex_Verb *)
Elim derF; Intros incF H1.
Elim H1; Intros incF' H2.
Elim derG; Intros incG H4.
Elim H4; Intros incG' H5.
Clear H1 H4.
Exists (IntPartIR (included_FMult ??? (included_comp ???????? incF incG' maps') incF')).
EApply Derivative_I_wdr.
2: Apply Derivative_I_comp.
FEQ.
Exact (included_FMult ??? (included_comp ???????? incF incG' maps') incF').
Qed.

End Derivative.

Section Differentiability.

(* Tex_Prose
\section{Differentiability}

Finally, we move on to differentiability.
*)

Variables F,G:PartIR.

Variables a,b:IR.
Hypothesis Hab':a[<]b.

Variables c,d:IR.
Hypothesis Hcd':c[<]d.

Local Hab:=(less_leEq ??? Hab').
Local Hcd:=(less_leEq ??? Hcd').
Local I:=(Compact Hab).

(* Begin_Tex_Verb *)
Hypothesis diffF:(Diffble_I Hab' F).
Hypothesis diffG:(Diffble_I Hcd' G).
Hypothesis Hmap:(maps_into_compacts F G a b Hab c d Hcd).
(* End_Tex_Verb *)

(* Begin_Tex_Verb *)
Lemma Diffble_I_comp : (Diffble_I Hab' G{o}F).
(* End_Tex_Verb *)
Elim diffF; Intros f' derF.
Elim diffG; Intros g' derG.
Apply Diffble_I_comp_aux with (PartInt f') (PartInt g') c d Hcd'; Auto.
Qed.

End Differentiability.

Section Generalized_Intervals.

(* Tex_Prose
\section{Generalizations}

We now generalize this results to arbitrary intervals.  We begin by generalizing the notion of mapping compacts into compacts.

\begin{convention} We assume \verb!I,J! to be proper intervals.
\end{convention}
*)

Variables I,J:interval.
Hypothesis pI:(proper I).
Hypothesis pJ:(proper J).

(* Begin_Tex_Verb *)
Definition maps_compacts_into [F:PartIR] := (a,b,Hab:?)
  (included (compact a b Hab) (iprop I))->{c:IR & {d:IR & {Hcd:? &
    (included (compact c d (less_leEq ??? Hcd)) (iprop J))*
  ((x:IR)(Hx:?)(Compact Hab x)->
    (Compact (less_leEq ??? Hcd) (F x Hx)))}}}.
(* End_Tex_Verb *)

(* Tex_Prose
Now everything comes naturally:
*)

(* Begin_Tex_Verb *)
Lemma comp_inc_lemma : (F:?)(maps_compacts_into F)->
  (x:IR)(Hx:?)(iprop I x)->(iprop J (F x Hx)).
(* End_Tex_Verb *)
Intros.
Cut (included (Compact (leEq_reflexive ? x)) (iprop I)); Intros.
Elim (H ??? H1); Intros c Hc.
Elim Hc; Clear Hc; Intros d Hd.
Elim Hd; Clear Hd; Intros Hcd Hmap'.
Inversion_clear Hmap'.
Apply H2; Apply H3; Auto.
Split; Apply leEq_reflexive.
Red; Intros.
Inversion_clear H1.
Apply iprop_wd with x; Auto.
Apply leEq_imp_eq; Auto.
Qed.

Variables F,F',G,G':PartIR.
(* Begin_Tex_Verb *)
Hypothesis Hmap:(maps_compacts_into F).
(* End_Tex_Verb *)

(* Begin_Tex_Verb *)
Lemma Continuous_comp : (Continuous I F)->(Continuous J G)->
  (Continuous I G{o}F).
(* End_Tex_Verb *)
Intros.
Elim H; Clear H; Intros incF contF.
Elim H0; Clear H0; Intros incG contG.
Split.
Red; Intros.
Exists (incF ? H).
Apply incG.
Apply comp_inc_lemma; Auto.
Intros.
Elim (Hmap ?? Hab H); Clear Hmap; Intros c Hc.
Elim Hc; Clear Hc; Intros d Hd.
Elim Hd; Clear Hd; Intros Hcd Hmap'.
Inversion_clear Hmap'.
Apply Continuous_I_comp with c d (less_leEq ??? Hcd); Auto.
Red; Intros.
Split; Auto.
Split; Auto.
Included.
Qed.

(* Begin_Tex_Verb *)
Hypothesis Hmap':(maps_compacts_into F').
(* End_Tex_Verb *)

(* Begin_Tex_Verb *)
Lemma Derivative_comp :
  (Derivative I pI F F')->(Derivative J pJ G G')->
  (Derivative I pI G{o}F (G'{o}F){*}F').
(* End_Tex_Verb *)
Intros.
Elim H; Clear H; Intros incF H'.
Elim H'; Clear H'; Intros incF' derF.
Elim H0; Clear H0; Intros incG H'.
Elim H'; Clear H'; Intros incG' derG.
Split.
Simpl; Red; Intros; Exists (incF ? H).
Apply incG; Apply comp_inc_lemma; Auto.
Split.
Apply included_FMult.
Simpl; Red; Intros; Exists (incF ? H).
Apply incG'; Apply comp_inc_lemma; Auto.
Included.
Intros.
Elim (Hmap ?? (less_leEq ??? Hab) H); Clear Hmap; Intros c Hc.
Elim Hc; Clear Hc; Intros d Hd.
Elim Hd; Clear Hd; Intros Hcd Hmap2.
Inversion_clear Hmap2.
Apply Derivative_I_comp with c d Hcd; Auto.
Red; Intros.
Split; Auto.
Split; Auto.
Included.
Qed.

End Generalized_Intervals.

Section Corollaries.

(* Tex_Prose
Finally, some criteria to prove that a function with a specific domain maps compacts into compacts:
*)

(* Begin_Tex_Verb *)
Definition positive_fun [P:IR->CProp][F:PartIR] :=
  (included P (Pred F))*
  ({c:IR & (Zero[<]c) | (y:IR)(P y)->(Hy:?)(c[<=](F y Hy))}).

Definition negative_fun [P:IR->CProp][F:PartIR] :=
  (included P (Pred F))*
  ({c:IR & (c[<]Zero) | (y:IR)(P y)->(Hy:?)((F y Hy)[<=]c)}).
(* End_Tex_Verb *)

(* Begin_Tex_Verb *)
Lemma positive_imp_maps_compacts_into : (J,F:?)
  (positive_fun (iprop J) F)->(Continuous J F)->
  (maps_compacts_into J (openl Zero) F).
(* End_Tex_Verb *)
Intros.
Red; Intros.
Elim H; Intros incF H2.
Elim H2; Clear H H2 incF; Intros MinF H H2.
LetTac MaxF:=(Norm_Funct (included_imp_Continuous ?? H0 ??? H1))[+]One.
Cut (MinF[<]MaxF); Intros.
Exists MinF; Exists MaxF; Exists H3.
Split.
EApply included_trans.
Apply compact_map2 with Hab':=(Min_leEq_Max MinF MaxF).
Apply included_interval; Simpl.
Auto.
Unfold MaxF; EApply leEq_less_trans.
2: Apply less_plusOne.
Apply positive_norm.
Intros; Split.
Auto.
Unfold MaxF; EApply leEq_transitive.
2: Apply less_leEq; Apply less_plusOne.
EApply leEq_transitive.
Apply leEq_AbsIR.
Apply norm_bnd_AbsIR; Auto.
Unfold MaxF; EApply leEq_less_trans.
2: Apply less_plusOne.
Apply leEq_transitive with (F a (Continuous_imp_inc ?? H0 ? (H1 a (compact_inc_lft ?? Hab)))).
Apply H2; Auto.
Apply H1; Apply compact_inc_lft.
EApply leEq_transitive.
Apply leEq_AbsIR.
Apply norm_bnd_AbsIR; Apply compact_inc_lft.
Qed.

(* Begin_Tex_Verb *)
Lemma negative_imp_maps_compacts_into : (J,F:?)
  (negative_fun (iprop J) F)->(Continuous J F)->
  (maps_compacts_into J (openr Zero) F).
(* End_Tex_Verb *)
Intros.
Red; Intros.
Elim H; Intros incF H2.
Elim H2; Clear H H2 incF; Intros MaxF H H2.
LetTac MinF:=[--](Norm_Funct (included_imp_Continuous ?? H0 ??? H1))[-]One.
Cut (MinF[<]MaxF); Intros.
Exists MinF; Exists MaxF; Exists H3.
Split.
EApply included_trans.
Apply compact_map2 with Hab':=(Min_leEq_Max MinF MaxF).
Apply included_interval; Simpl.
Unfold MinF; EApply less_leEq_trans.
Apply minusOne_less.
Stepr [--](Zero::IR); Apply inv_resp_leEq; Apply positive_norm.
Auto.
Intros; Split.
Unfold MinF; EApply leEq_transitive.
Apply less_leEq; Apply minusOne_less.
Stepr [--][--](pfpfun ? ? Hx); Apply inv_resp_leEq.
EApply leEq_transitive.
Apply inv_leEq_AbsIR.
Apply norm_bnd_AbsIR; Auto.
Auto.
Unfold MinF; EApply less_leEq_trans.
Apply minusOne_less.
Apply leEq_transitive with (F a (Continuous_imp_inc ?? H0 ? (H1 a (compact_inc_lft ?? Hab)))).
2: Apply H2; Auto.
2: Apply H1; Apply compact_inc_lft.
Stepr [--][--](pfpfun ? ? (Continuous_imp_inc ?? H0 ? (H1 ? (compact_inc_lft ?? Hab)))); Apply inv_resp_leEq.
EApply leEq_transitive.
Apply inv_leEq_AbsIR.
Apply norm_bnd_AbsIR; Apply compact_inc_lft.
Qed.

(* Begin_Tex_Verb *)
Lemma Continuous_imp_maps_compacts_into : (J,F:?)
  (Continuous J F)->(maps_compacts_into J realline F).
(* End_Tex_Verb *)
Intros.
Red; Intros.
LetTac ModF:=(Norm_Funct (included_imp_Continuous ?? H ??? H0)).
Cut [--]ModF[<]ModF[+]One; Intros.
Exists [--]ModF; Exists ModF[+]One; Exists H1; Split.
Repeat Split.
Intros; Unfold ModF; Split.
Stepr [--][--](pfpfun ? ? Hx); Apply inv_resp_leEq.
EApply leEq_transitive; [Apply inv_leEq_AbsIR | Apply norm_bnd_AbsIR]; Auto.
EApply leEq_transitive.
2: Apply less_leEq; Apply less_plusOne.
EApply leEq_transitive; [Apply leEq_AbsIR | Apply norm_bnd_AbsIR]; Auto.
Unfold ModF.
EApply leEq_less_trans; [Apply leEq_transitive with (Zero::IR) | Apply less_plusOne].
Stepr [--](Zero::IR); Apply inv_resp_leEq; Apply positive_norm.
Apply positive_norm.
Qed.

(* Tex_Prose
As a corollary, we get the generalization of differentiability property.
*)

(* Begin_Tex_Verb *)
Lemma Diffble_comp : (I,J,pI,pJ,F,G:?)(maps_compacts_into I J F)->(Diffble I pI F)->(Diffble J pJ G)->(Diffble I pI G{o}F).
(* End_Tex_Verb *)
Intros.
Apply Derivative_imp_Diffble with ((Deriv ??? H1){o}F){*}(Deriv ??? H0).
Apply Derivative_comp with J pJ; Auto; Apply Deriv_lemma.
Qed.

End Corollaries.

Hints Immediate included_comp : included.
Hints Immediate Continuous_I_comp Continuous_comp : continuous.


(** ProofCafe SF/PLF Support Page *)
(** Smallstep.v *)

(**
これは、「Software Foundations, Vol.2 Programming Language Foundations」 の
勉強会（ProofCafe）のサポートページです。復習などに利用しててください。

本ファイルの実行は、本ファイルを pfl ディレクトリの中に混ぜて置くか、
pfl のオリジナルの適当なファイルの適当な場所にcopy&pasteすることで可能です。
 *)

(** ご注意：

1. 実際の勉強会は、本ファイルではなく、オリジナルのファイルを直接編集・実行しておこないます。

2. 本ファイルには、演習問題の答えは含まれません。

*)

Require Import Coq.Arith.Arith.
Require Import Coq.Arith.EqNat.
Require Import Coq.omega.Omega.
Require Import Coq.Lists.List.
Import ListNotations.
Require Import Maps.
Require Import Imp.
Require Import Smallstep.

(* ################################################################# *)
(** ProofCafe ##72 2018/01/20 *)
(** * A Toy Language *)

(** 概要：

1. 定数と加算だけあるおもちゃの言語を定義する。この項をtmとする。

2. big-step style の評価器(evaluator)の定義。evalF。
 evalF tm の実行結果が n 。

3. big-step style の評価関係(evaluation releation)。eval
 論理式 (tm \\ n) 。 tm (項) と自然数(結果 )との関係である。

4. small-step style の評価関係(evaluation releation)。step
 論理式 (tm1 ==> tm2) 。 tm (項) どうしの関係であることに留意する。
 *)

Module PF_SimpleArith1.
Import SimpleArith1.

(** * おもちゃの言語のコンストラクタ *)
Check C : nat -> tm.
Check P : tm -> tm -> tm.

(** tm の例 *)
(* 1 + (2 + 3)) + (11 + (12 + 13)) *)
Definition sample := (P (P (C 1) (P (C 2) (C 3)))
                        (P (C 11) (P (C 12) (C 13)))) : tm.

(** * big-step evaluator *)
Check evalF : tm -> nat.                    (* 関数 *)

(** 例 *)
Compute evalF sample.                       (* = 42 : nat *)

(** * big-step evaluation relation *)
Check eval : tm -> nat -> Prop.

(** 導入した公理 *)
Check E_Const : forall n : nat, C n \\ n.
Check E_Plus : forall (t1 t2 : tm) (n1 n2 : nat),
    t1 \\ n1 -> t2 \\ n2 -> P t1 t2 \\ (n1 + n2).

(** 例 *)
Goal sample \\ 42.
Proof.
  unfold sample.
  apply E_Plus with (n1 := 6) (n2 := 36).
  - apply E_Plus with (n1 := 1) (n2 := 5).
    + now apply E_Const.
    + apply E_Plus with (n1 := 2) (n2 := 3).
      * now apply E_Const.
      * now apply E_Const.
  - apply E_Plus with (n1 := 11) (n2 := 25).
    + now apply E_Const.
    + apply E_Plus with (n1 := 12) (n2 := 13).
      * now apply E_Const.
      * now apply E_Const.
Qed.

(** * small-step evaluation relation *)
Check step : tm -> tm -> Prop.              (* tm1 ==> tm2 *)

(** 導入した公理 *)
Check ST_PlusConstConst :
  forall n1 n2, (P (C n1) (C n2) ==> C (n1 + n2)).
Check ST_Plus1 :
  forall t1 t1' t2, (t1 ==> t1') -> (P t1 t2 ==> P t1' t2).
Check ST_Plus2 :
  forall (n1 : nat) (t2 t2' : tm),
    (t2 ==> t2') -> P (C n1) t2 ==> P (C n1) t2'.

(** 例 *)
Goal sample ==> (P (P (C 1) (C 5))
                   (P (C 11) (P (C 12) (C 13)))).
Proof.
  constructor.
  constructor.
  constructor.
  Show Proof.

  Restart.
  apply ST_Plus1.
  apply ST_Plus2.
  apply ST_PlusConstConst.
Qed.

Goal (P (P (C 1) (C 2)) (C 3)) ==> (P (C 3) (C 3)).
Proof.
  constructor.
  constructor.
  Show Proof.

  Restart.
  apply ST_Plus1.
  apply ST_PlusConstConst.
Qed.

(** 補足説明：

Small-stepのひとつのステップでやっていること：

- 「==>」の左辺の、最も左（で最も深いところ）にある 「P (C n1) (C n2)」を探す。
- これを 「C (n1 + n2)」 に書き換えたものを「==>」の右辺とする。

stepの定義の読み方：

stepの定義は、「->」 を逆向きみ見ていく。
- 左側優先深さ優先で検索し(ST_Plus1)、
- P の第一引数が定数(C n1)になったら、第二引数を見ていって(PT_Plus2)、
- 両方の引数が定数になったら、定数に書き換える(ST_PlusConstConst)。

余力があれば、本章の終わりにある、
Concurrent Imp の PAR c1 with c2 END の定義と比較してみてください。
*)

(**
以下はうまくいかない例：
 *)
(**
2回分はできない。
 *)
Goal sample ==> (P (C 6)
                   (P (C 11) (P (C 12) (C 13)))).
Proof.
  constructor.
  admit.                                    (* OK. *)
Admitted.

(** 前の例の結果を使って、2回に分ければできる。  *)
Goal (P (P (C 1) (C 5))
        (P (C 11) (P (C 12) (C 13))))       (* 前の例の結果 *)
     ==>
     (P (C 6)
        (P (C 11) (P (C 12) (C 13)))).
  constructor.
  constructor.
Qed.

(**
最も左でなければならない。
 *)
Goal sample ==> (P (P (C 1) (P (C 2) (C 3)))
                   (P (C 11) (C 25))).
Proof.
  admit.                                    (* OK. *)
Admitted.

(**
当然、できない。
*)
Goal sample ==> (C 42).
Proof.
  admit.                                    (* OK. *)
Admitted.

End PF_SimpleArith1.

(* ################################################################# *)
(** ProofCafe ##73 2018/02/17 *)
(** * Relations *)

(** 概要：

1. Relations（二項関係）
stepが決定的な二項関係であることの証明、inversionタクティクを使う。

2. Values（値）

3. Strong Progress and Normal Form
stepが強進行性（正規形がある）ことの証明、Coqの定石タクティクを使う。
 *)

Module PF_SimpleArith2.
Import PF_SimpleArith1.
Import SimpleArith1.

(** * 二項関係 *)

(** 二項関係 R が決定的であるという命題 *)
Check @deterministic : forall X : Type, relation X -> Prop.
(** ここで、relation tm に step が渡される。 *)

Print deterministic.
(** =
fun (X : Type) (R : relation X) =>
forall x y1 y2 : X, R x y1 -> R x y2 -> y1 = y2 *)

(**
補足説明：

二項関係が決定的である。 <-> 二項関係は部分関数 partial function である。

R x y が決定的ならxに対してyが唯一決まるので関数っぽいけれども、
任意のxに対してyが決まるとは限らないので、部分関数である。

なお、任意のxに対してyが決まる全域関数は、部分関数の一種である。
*)

(** ** step が決定的であることの証明 *)

(** inversion を使う典型的な証明。オリジナルと同内容である。 *)

Theorem step_deterministic'' : deterministic step.
Proof.
  unfold deterministic.
  intros x y1 y2 Hy1 Hy2.
(**
[[
  Hy1 : x ==> y1
  Hy2 : x ==> y2
  ============================
   y1 = y2
]]
*)
  (** 0. Hy1 のコンストラクタで再帰的に場合分けする。 *)
  induction Hy1 as [n1 n2 H1 H2 | t1 t1' t2 H1 IHHy1 H2 |n t1' t2 H1 IHHy1 H2].
  Undo 1.
  generalize dependent y2.
  induction Hy1 as [n1 n2 | t1 t1' t2 H1 IHHy1 |n t1' t2 H1 IHHy1]; intros y2 Hy2'.
  (**
  ST_PlusConstConst の場合：
    Hy2' : P (C n1) (C n2) ==> y2
    x = P (C n1) (C n2) なので、
    ゴールは C (n1 + n2) = y2 である。

  ST_Plus1 の場合：
    Hy2' : P t1 t2 ==> y2
    x = P t1 t2 なので、
    ゴールは P t1' t2 = y2

  ST_Plus2 の場合 :
    P (C n) t1' ==> y2
    x = P (C n) t1' なので、
    ゴールは P (C n) t2 = y2
 *)

(**
[[
   Hy2' : P (C n1) (C n2) ==> y2
  ============================
   C (n1 + n2) = y2
]]
*)
  (** 1. Hy2' にコンストラクタを逆に適用する。 *)
  - inversion Hy2'; subst.

    (** 1.1 ST_PlusConstConst の場合、
       Hy2' : P (C n1) (C n2) ==> C (n1 + n2)
       y2 = C (n1 + n2),
       Goal : C (n1 + n2) = C (n1 + n2)
     *)
    + reflexivity.

    (** 1.2 ST_Plus1 の場合、
       H2 : C n1 ==> t1'
       これはコンストラクトできない（矛盾）。
       矛盾は inversion で消す！ *)
    + inversion H2.

    (** 1.3 ST_Plus2 の場合、
       H2 : C n2 ==> t2'
       これはコンストラクトできない（矛盾）。
       矛盾は inversion で消す！ *)
    + inversion H2.

(**
[[
   H1 : t1 ==> t1'
   IHHy1 : forall y2 : tm, t1 ==> y2 -> t1' = y2
   Hy2' : P t1 t2 ==> y2
  ============================
   P t1' t2 = y2
]]
*)
  (** 2. Hy2' にコンストラクタを逆に適用する。 *)
  - inversion Hy2'; subst.

    (** 2.1 ST_PlusConstConst の場合、
        H1 : C n1 ==> t1'
        これはコンストラクトできない（矛盾）。 *)
    (** 矛盾は inversion で消す！ *)
    + inversion H1.

    (** 2.2 ST_Plus1 の場合、
       IHHy1 : forall y2 : tm, t1 ==> y2 -> t1' = y2、帰納法
       Goal : P t1' t2 = P t1'0 t2
    *)
    (** generalize dependent y2 したのを活用する。 *)
    + rewrite <- (IHHy1 t1'0).
      * reflexivity.
      * apply H3.
    (** 2.3 ST_Plus2 の場合、
       H1 : C n1 ==> t1'
       これはコンストラクトできない（矛盾）。 *)
    (** 矛盾は inversion で消す！ *)
    + inversion H1.

(**
[[
   H1 : t1' ==> t2
   IHHy1 : forall y2 : tm, t1' ==> y2 -> t2 = y2
   Hy2' : P (C n) t1' ==> y2
  ============================
   P (C n) t2 = y2
]]
*)
  (** 3. Hy2' にコンストラクタを逆に適用する。 *)
  - inversion Hy2'; subst.

    (** 3.1 ST_PlusConstConst の場合、
       H1 : C n2 ==> t2
       これはコンストラクトできない（矛盾）。 *)
    (** 矛盾は inversion で消す！ *)
    + inversion H1.

    (** 3.2 ST_Plus1 の場合、
       H3 : C n ==> t1'0
       これはコンストラクトできない（矛盾）。 *)
    (** 矛盾は inversion で消す！ *)
    + inversion H3.

    (** 3.3 ST_Plus2 の場合、
       IHHy1 : forall y2 : tm, t1 ==> y2 -> t1' = y2、帰納法
       Goal : P (C n) t2 = P (C n) t2'
     *)
    (** generalize dependent y2 したのを活用する。 *)
    + rewrite <- (IHHy1 t2').
      * reflexivity.
      * apply H3.
Qed.

(** now と easy を使う例。 *)
(** Home The Coq Proof Assistant Chapter 8 Tactics 8.8.5 easy *)
(** https://coq.inria.fr/refman/tactics.html#hevea_tactic166 *)
Theorem step_deterministic' : deterministic step.
Proof.
  unfold deterministic.
  intros x y1 y2 Hy1 Hy2.
  generalize dependent y2.
  induction Hy1; intros y2 Hy2.
  - inversion Hy2; subst.
    + reflexivity.
    + easy.
    + easy.
  - inversion Hy2; subst.
    + easy.
    + now rewrite <- (IHHy1 t1'0).
    + easy.
  - inversion Hy2; subst.
    + easy.
    + easy.
    + now rewrite <- (IHHy1 t2'0).
Qed.

(** さらに短くした例。 *)
Theorem step_deterministic : deterministic step.
Proof.
  unfold deterministic.
  intros x y1 y2 Hy1 Hy2.
  generalize dependent y2.
  induction Hy1; intros y2 Hy2;
    inversion Hy2; subst; try easy.
  - now rewrite <- (IHHy1 t1'0).
  - now rewrite <- (IHHy1 t2'0).
Qed.

End PF_SimpleArith2.

(** ** inversion について *)

(**
- http://proofcafe.org/sf/Poly_J.html#lab114
- https://softwarefoundations.cis.upenn.edu/lf-current/Tactics.html#lab136

「任意のコンストラクタは単射であること、また、コンストラクタどうしは互いに素であること。」
 *)

(** step_deterministic は step に対して inversion を行っている。 *)
(** 以下は、 tm に対して inversion を行う例である。 *)

Goal forall n1 n2 n3 n4, P (C n1) (C n2) = P (C n3) (C n4) -> n1 = n3 /\ n2 = n4.
Proof.
  intros n1 n2 n3 n4 H.
  inversion H.
  (** Hにおけるコンストラクタの単射性から、前提に等式が追加される。 *)
  split.
  - reflexivity.
  - reflexivity.
Qed.

Goal forall n1 n2 n3, P (C n1) (C n2) = C n3 -> False.
Proof.
  intros n1 n2 n3 H.
  inversion H.
  (** コンストラクタは互いに素なので、Hは矛盾であり、ゴールの証明が終了する。 *)
Qed.

(*
(** おまけ。 *)
(** 順番が前後するが、λx.(x x) に型がつかないことを言うには、
型が有限性から、xの型 T1 -> T2 が T1 にひとしくないことを使う。
より一般的に、(Inductiveで定義された）コンストラクタの有限性を証明できないだろうか。
*)
(** 参考： TAPL 解答 9.3.2 *)
Goal forall tm1 tm2, P tm1 tm2 = tm1 -> False.
Proof.
  intros tm1 tm2 H.
  induction tm1.
  - easy.
  - inversion H.
    rewrite H1 in *.
    easy.
Qed.
*)

(* ================================================================= *)
(** * Values *)

(** 導入した公理 *)
Check v_const : forall n : nat, value (C n).

(** (C 3) は value であることが証明できる。 *)
Goal value (C 3).
Proof.
  apply v_const.
Qed.

(** Exercise: redo_determinism を解いてみましょう！！！
   ヒント：
   value はひとつだけだが、コンストラクタ v_const を持つ。
   それが前提にあるならば、場合分けをする必要がある。
*)

(* ================================================================= *)
(** ProofCafe ##74 2018/03/17 *)
(** * Strong Progress and Normal Forms *)
(**
概要：

(1) step (==>) が強進行性を満たす。strong_progress
    ∀t, value t ∨ (∃ t', t ==> t').
任意のtmであるtは、値（すなわち C n）であるか、別のtmにステップできる。

(2) tが(stepの)正規形である (normal_form step t) とは、
    ~(∃t', t ==> t')
すなわち、 t ==> t' なる t'が存在しない（もうstepできない）ことをいう。

(3) 値なら正規形である。value_is_nf
    ∀t, value t -> ~(∃t', t ==> t').

(4) 正規形なら値である。nf_is_value
    ∀t, ~(∃t', t ==> t') -> value t.

(5) (3)(4)より、値と正規形は同じである。
    ∀t, value t <-> ~(∃t', t ==> t').

参考：TAPL p.28
*)

(** ** step(==>)が強進行性であることの証明 *)

(** 任意の項 t は、値であるか、別の項 t' にstepできる。
「強」進行性とは、stepに戦略が無くても正規形が得られることをいう。
うまく選ばないと正規形が得られない場合は、単に「進行性」と呼ぶ。
 *)

(** オリジナルは、あいかわらずinversionだけで解いているが、inversionを使わなくても証明できる。
inversionを使うことの是非については議論しないが、ここでは、Coqの定石の説明する。
 *)

(** t は強進行性を満たす。 *)
Theorem strong_progress : forall t : tm,
    value t \/ (exists t', t ==> t').
Proof.
  induction t.                      (** q t を証明したい命題とし、tで帰納する。 *)
  - left.                           (** 帰納の底 q (C n) *)
    now apply v_const.
  - right.              (** 帰納の途中 : q t1 -> q t2 -> q (P t1 t2) *)
    destruct IHt1 as [H11 | H12].         (** 選言を場合分けする。 *)
    (** IHt1 の左側 *)
    + destruct IHt2 as [H21 | H22].       (** 選言を場合分けする。 *)
      (** IHt2 の左側、t1とt2がvalue であるとき。 *)
      * destruct H11 as [n1].            (** value を場合分けする。 *)
        destruct H21 as [n2].            (** value を場合分けする。 *)
        exists (C (n1 + n2)).
        now apply ST_PlusConstConst.
      (** IHt2 の右側、t1がvalue、t2がstep可能であるとき。 *)
      * destruct H22 as [t'].           (** exists を場合分けする。 *)
        exists (P t1 t').
        now apply ST_Plus2.
    (** IHt1 の右側、t1がstep可能であるとき。 *)
    + destruct H12 as [t'].             (** exists を場合分けする。 *)
      exists (P t' t2).
      now apply ST_Plus1.
Qed.

(** ** 正規形 *)
Print normal_form.
(**                                        not
fun (X : Type) (R : relation X) (t : X) => ~ (exists t' : X, R t t')
     : forall X : Type, relation X -> X -> Prop
 *)

(** R には step（==>）を渡すなら、
tが正規形であるとは、t ==> t' なる t'が存在しない（もうstepできない）ことをいう。 *)

(** ** 値なら正規形であることの証明 *)
(** t が値なら、t は正規形である。 *)
Lemma value_is_nf : forall v,
  value v -> normal_form step v.
Proof.
  unfold normal_form. (** ゴールが Define されたものの場合 *)
  intros v H.         (** ゴールに ∀や->がある場合。ただし、やりすぎに注意 *)
  destruct H.         (** 前提がデータ型のとき、帰納的でないなら場合分けする。 *)
  intro contra.       (** ゴールが否定のとき。引数の無い intros ではだめ。 *)
  destruct contra.    (** 前提が exists のとき *)
  easy.               (** 前提が矛盾（コンストラクトできない）場合 *) (** inversion H. *)
Qed.

(** ** 正規形なら値であることの証明 *)

(** 補題：t が強進行性を満たすなら、tが正規形なら、tは値である。 *)
(** ただし、これは任意の二項関係(s : tm -> tm -> Prop) で成立する。 *)
(** suhara オリジナルは、assert を使っているが、わかりやすく補題として外に出した。  *)
Lemma l_strong_progress__nf_is_value : forall t s,
    (value t \/ (exists t', s t t')) -> normal_form s t -> value t.
Proof.
  unfold normal_form.
  intros t G H.
  destruct H.              (** 前提が \/ のとき、左右で場合分けする。 *)
  (** 左側 *)
  + easy.                   (** 前提がゴールと同じ。 *) (** apply H0. *)
  (** 右側 *)
  + easy.                         (** 矛盾した前提があるとき。 *)
     (** exfalso. apply H. assumption. *)
Qed.

(** tが正規形なら、tは値である。 *)
Lemma nf_is_value : forall t,
    normal_form step t -> value t.
Proof.
  intros t.
  apply l_strong_progress__nf_is_value.
  apply strong_progress.
Qed.

(** ** 値と正規形は同じである。 *)
Corollary nf_same_as_value : forall t,
  normal_form step t <-> value t.
Proof.
  split.                                    (** ゴールが <-> のとき *)
  - now apply nf_is_value.
  - now apply value_is_nf.
Qed.
(** 後で使う。 *)

(**
本文より：

なぜ、値と正規形が同じあることが興味深いのでしょう？

なぜならvalue(値)は構文的概念です。つまり項の形を見ることで定義されま
す。一方normal_form(正規形)は意味論的なものです。 つまり項がどのように
ステップを進むかによって定義されます。 この2つの概念が一致することは自
明ではないのです!

実際、正規形と値の概念が一致「しない」言語はたくさん存在します。
*)

(**
定石集：

まじかんと さんのページから：

証明事例集: 前提が……のとき
https://magicant.github.io/programmingmemo/coq/byhyp.html

証明事例集: ゴールが……のとき
https://magicant.github.io/programmingmemo/coq/bygoal.html

tmiyaさんんページから：
http://study-func-prog.blogspot.jp/2010/12/coq-coq-advent-calender-apply-1-of-25.html
http://study-func-prog.blogspot.jp/2010/12/coq-coq-advent-calender-inversion-19-of.html
 *)

(* ################################################################# *)
(** ProofCafe ##75 2018/04/21 *)
(** * Multi-Step Reduction *)
(** 概要：

マルチステップ簡約(multi-step reduction)関係 ==>* は、
1ステップ関係 step ==> の0回以上の繰り返しであり、反射推移閉包です。

stepを1回した場合結果は、反射でも推移でもない。しかし、
例えば、
0回なら反射であり、
2回stepして3回stepした結果と5回stepした結果が同じになるので推移性がある。
*)

Check step : tm -> tm -> Prop.
Check step : relation tm.
Check multi step : tm -> tm -> Prop.        (* tm1 ==>* tm2 *)
Check multi step : relation tm.             (* tm1 ==>* tm2 *)

(** 導入される定義 *)
(** lf/Rel.v や、theories/Relations/Relation_Operators.v では、
clos_refl_trans_1n として定義されている。 *)
Print multi_refl.
(**
[[
Inductive multi (X : Type) (R : relation X) : relation X :=
  | multi_refl : forall x : X, multi R x x
  | multi_step : forall x y z : X, R x y -> multi R y z -> multi R x z
]]
*)
Check multi_refl step : forall x : tm, x ==>* x.
Check multi_step step : forall x y z : tm, x ==> y -> y ==>* z -> x ==>* z.
(** ふたつめの定義は、推移性そのものではないことに注意してください。
stepして、multi_step した結果は multi_step と言っているだけ。

推移性を自然に書いた次の定義だと、y の決め方が難しく、証明が難しくなる。
このあたりの説明は、lf/Rel.v にあります。

[[multi R x y  -> multi R y z -> multi R x z]]
  *)

(** ただし、この multi の定義がいくつかの性質を満たすことは、証明が必要である。  *)

(** multi R が R を含む、すなわち、R x y なら multi R x y である。 *)
Lemma multi_R : forall (X : Type) (R : relation X) (x y : X),
    R x y -> multi R x y.
Proof.
  intros X R x y HR.
  apply (multi_step R) with (y:=y).
  Check (multi_step R x y y).             (* apply multi_step with y. *)
  (* apply (multi_step R x y y). *)
  (* apply (multi_step R x y).             (* apply multi_step with y. *) *)
  apply HR.
  now apply multi_refl.
Qed.

(** 推移性を持つことも証明する必要がある。 *)
(** これらの補題は実際に使う。  *)
(** より詳しくは、theories/Relations/Operators_Properties.v  *)
Lemma multi_trans : forall (X : Type) (R : relation X) (x y z : X),
    multi R x y  ->
    multi R y z ->
    multi R x z.
Proof.
  intros X R x y z G H.
  induction G as [|x y' y HR G].
  - now apply H.                         (* (1) multi step R x z *)
  - apply (multi_step R x y' z).         (* (2) multi step R x z *)
    + now apply HR.                      (* (2.1) R x' z *)
    + apply IHG.                         (* (2.2) multi step R x' z *)
      now apply H.
Qed.

(** 前出の ==> ではだめだった例を証明する。 *)

Definition sample := (P (P (C 1) (P (C 2) (C 3)))
                        (P (C 11) (P (C 12) (C 13)))) : tm.

Goal sample ==>* (C 42).
Proof.
  apply multi_step with (y:=(P (P (C 1) (C 5)) (P (C 11) (P (C 12) (C 13))))).
  (** sample ==> P (P (C 1) (C 5)) (P (C 11) (P (C 12) (C 13))) *)
  - constructor.
    constructor.
    constructor.
    constructor.
  - apply multi_step with (y:=(P (C 6) (P (C 11) (P (C 12) (C 13))))).
    (** P (P (C 1) (C 5)) (P (C 11) (P (C 12) (C 13))) ==>
         P (C 6) (P (C 11) (P (C 12) (C 13))) *)
    + constructor.
      constructor.
    + apply multi_step with (y:=(P (C 6) (P (C 23) (C 13)))).
      * constructor.
        constructor.
        admit.
      * admit.
Admitted.

Goal sample ==>* (P (C 6)
                   (P (C 11) (P (C 12) (C 13)))).
Proof.
  apply multi_step with (y:=(P (P (C 1) (C 5)) (P (C 11) (P (C 12) (C 13))))).
  (** sample ==> P (P (C 1) (C 5)) (P (C 11) (P (C 12) (C 13))) *)
  - constructor.
    constructor.
    constructor.
    constructor.
  - apply multi_step with (y:=(P (C 6) (P (C 11) (P (C 12) (C 13))))).
    (** P (P (C 1) (C 5)) (P (C 11) (P (C 12) (C 13))) ==>
         P (C 6) (P (C 11) (P (C 12) (C 13))) *)
    + constructor.
      constructor.
    + apply multi_refl.
Qed.

(* ================================================================= *)
(** ** Normal Forms Again *)
(**
tが0以上のステップでt'に簡約され、
t'が正規形(normal form、前出、もうこれ以上stepできない形)のとき、
「t'はtの正規形である」と言います。

これを二項関係 [normal_form_of t t'] で定義する。
 *)

Print step_normal_form.                     (* [normal_form step] *)
Print normal_form.
(** [fun (X : Type) (R : relation X) (t : X) => ~(∃ t' : X, R t t')] *)
Print normal_form_of.
(** [fun (t t' : tm) => t ==>* t' /\ step_normal_form t')] *)
(** [fun (t t' : tm) => t ==>* t' /\ ~(∃t'', t' ==> t'')] *)

(**
概要：
この二項関係 [normal_form_of] は、次のふたつの性質をもつ。

(1) 正規形の一意性：この二項関係(normal_form_of)は決定的である。
(2) 簡約（評価）の停止性：すべての項に対して、正規形が存在する。

(1)(2)より、normal_form_of は全域関数である。

参考：TAPL p.29
 *)

(**
(1) 正規形の一意性を証明する。

xが正規形のy1とy2に簡約できるなら、y1 = y2 である。

[[
deterministic normal_form_of :
  ∀x y1 y2. normal_form_of x y1 -> normal_form_of x y2 -> y1 = y2
]]

[deterministic] は既出。
*)

(** 補題： 正規型なら stepしない。 suhara *)
(** [step_normal_form x] と [x ==> y] は矛盾 *)
(** ただし、これは任意の二項関係(s : tm -> tm -> Prop) で成立する。 *)
Lemma l_nf__not_step : forall (x y : tm) s, normal_form s x -> ~ s x y.
Proof.
  unfold normal_form.
  intros x y s H1 H2.
  apply H1.
  now exists y.
Qed.

Goal deterministic normal_form_of.
Proof.
  unfold deterministic.
  (** [forall x y1 y2 : tm, normal_form_of x y1 -> normal_form_of x y2 -> y1 = y2] *)
  unfold normal_form_of.
  unfold step_normal_form.                  (* normal_form step *)
  intros x y1 y2 P1 P2.
  inversion P1 as [P11 P12]; clear P1.
  inversion P2 as [P21 P22]; clear P2.
  generalize dependent y2.

  induction P11 as [x|x y z H]; intros y2 Hy2 P2.
  - destruct Hy2.
    + reflexivity.
    + destruct P12.
      now exists y.
  - apply IHP11.
    + now apply P12.
    + inversion Hy2; subst.
      * now apply (l_nf__not_step y2 y step) in P2.  (* P2 と Hy2 は矛盾、補題参照 *)
      * now rewrite (step_deterministic x y y0). (* H と H0 から y = y0 *)
    + easy.                                      (* apply P2 *)
Qed.
(** step の決定性 step_deterministic も使用します。  *)

(**
(2) 簡約（評価）の停止性を証明する。

直観的な証明：
stepを1回おこなうと[P]が1個減る。こののとから、stepを繰り返すといつかは[P]がなくなる。
(see. TAPL p.29)

形式的な証明：
stepは正規化性を持つ（任意のtは、0以上のステップで、正規形に到達できる）。
[[
∀t, ∃t', normal_form_of t t'
]]
つまり、任意のtに対して、あるt'があって、tからステップを進めるとt'に到達し、
かつ、t'はもうこれ以上stepできない（正規形である）。
[[
step_normalizing :
    ∀t, ∃t', t ==>* t' /\ ~(∃t'', t' ==> t'')
]]
*)

(**
ふたつの合同補題 (congruence lemma) を証明しておく。
*)
Check multistep_congr_1 : forall t1 t1' t2 : tm, t1 ==>* t1' -> P t1 t2 ==>* P t1' t2.
Check multistep_congr_2 : forall t1 t2 t2' : tm, value t1 ->
                                                 t2 ==>* t2' -> P t1 t2 ==>* P t1 t2'.
(** ふたつめは、左側の子(t1)が value の時が条件となる。stepは左から簡約するから。 *)

Lemma step_normalizing : forall t, exists t', normal_form_of t t'.
Proof.
  induction t.
  - exists (C n).
    split.
      + now apply multi_refl.
      + rewrite nf_same_as_value.
        now apply v_const.
  - destruct IHt1 as [t1' [H11 H12]].
    destruct IHt2 as [t2' [H21 H22]].
    rewrite nf_same_as_value in H12.
    rewrite nf_same_as_value in H22.
    inversion H12 as [n1 H].
    inversion H22 as [n2 H'].
    rewrite <- H in H11.
    rewrite <- H' in H21.
    exists (C (n1 + n2)).
    split.
    (* apply multi_step ではだめ。 *)
    + apply multi_trans with (P (C n1) t2).
      * now apply multistep_congr_1.        (* 合同補題 *)
      * apply multi_trans with (P (C n1) (C n2)).
        ** apply multistep_congr_2.         (* 合同補題 *)
           *** apply v_const.
           *** apply H21.
        ** apply multi_R.
           apply ST_PlusConstConst.
    + rewrite nf_same_as_value.
      now apply v_const.
Qed.

(* ================================================================= *)
(** ** Equivalence of Big-Step and Small-Step *)

(** evalF と multi step [==>*] のどちらも、全域関数である。 *)

Compute evalF sample.

(** 概要：

（略）

*)

(** END *)


Load Category.

Definition Op (C: Category) : Category.
  apply (Build_Category
           (Ob C)
           (fun x y => Hom C y x)
           (fun a => @Id C a)
           (fun a b c f g => @Comp C c b a g f)
        ).

  intros.
  apply idr.

  intros.
  apply idl.

  intros.
  symmetry.
  apply assoc.
Qed.


(** * factors: additional properties of left and right factors *)

Require Import kleene.
Set Implicit Arguments.

Lemma ldv_dotx `{laws} `{DIV ≪ l} n m p q (x: X n m) (y: X m p) (z: X n q): x⋅y -o z ≡ y -o x -o z.
Proof.
  apply from_below. intro t.
  now rewrite 3ldv_spec, dotA.
Qed.

Lemma ldv_xdot `{laws} `{DIV ≪ l} n m p (x: X n m) (y: X m p): y ≦ x -o (x⋅y).
Proof. now rewrite ldv_spec. Qed.

Lemma ldv_1x `{laws} `{DIV ≪ l} n m (x: X n m): 1 -o x ≡ x.
Proof. apply from_below. intro y. now rewrite ldv_spec, dot1x. Qed.

Lemma ldv_0x `{laws} `{DIV+BOT+TOP ≪ l} n m p (x: X n m): 0 -o x ≡ top' p m.
Proof. apply from_below. intro y. rewrite ldv_spec, dot0x. split; intros _; lattice. Qed.

Lemma ldv_xt `{laws} `{DIV+TOP ≪ l} n m p (x: X n m): x -o top ≡ top' m p.
Proof. apply from_below. intro y. rewrite ldv_spec. split; intros _; lattice. Qed.

Lemma str_ldv `{laws} `{STR+DIV ≪ l} n m (x: X n m): (x -o x)^* ≡ x -o x.
Proof. apply antisym. apply str_ldv_. apply str_ext. Qed.

Lemma ldv_rdv `{laws} `{DIV ≪ l} n m p q (x: X n m) y (z: X p q): x -o (y o- z) ≡ (x -o y) o- z.
Proof. apply from_below. intro. now rewrite ldv_spec, 2rdv_spec, ldv_spec, dotA. Qed.

Lemma ldv_unfold `{laws} `{BL+DIV+CNV ≪ l} n m p (x: X n m) (y: X n p): x -o y ≡ !(x° ⋅ !y).
Proof. apply from_below. intro. now rewrite ldv_spec, neg_leq_iff', <-Schroeder_l. Qed.

(** dual properties for right factors *)

Lemma rdv_cancel `{laws} `{DIV ≪ l} n m p (x: X m n) (y: X p n): (y o- x)⋅x ≦ y.
Proof. dual @ldv_cancel. Qed.

Lemma rdv_dotx `{laws} `{DIV ≪ l} n m p q (x: X m n) (y: X p m) (z: X q n): z o- y⋅x ≡ z o- x o- y.
Proof. dual @ldv_dotx. Qed.

Lemma rdv_xdot `{laws} `{DIV ≪ l} n m p (x: X m n) (y: X p m): y ≦ y⋅x o- x.
Proof. dual @ldv_xdot. Qed.

Lemma leq_rdv `{laws} `{DIV ≪ l} n m (x y: X m n): x ≦ y <-> 1 ≦ y o- x.
Proof. dual @leq_ldv. Qed.

Lemma rdv_xx `{laws} `{DIV ≪ l} n m (x: X m n): 1 ≦ x o- x.
Proof. dual @ldv_xx. Qed.

Lemma rdv_1x `{laws} `{DIV ≪ l} n m (x: X m n): x o- 1 ≡ x.
Proof. dual @ldv_1x. Qed.

Lemma rdv_0x `{laws} `{DIV+BOT+TOP ≪ l} n m p (x: X m n): x o- 0 ≡ top' m p.
Proof. dual @ldv_0x. Qed.

Lemma rdv_xt `{laws} `{DIV+TOP ≪ l} n m p (x: X m n): top o- x ≡ top' p m.
Proof. dual @ldv_xt. Qed.

Lemma rdv_trans `{laws} `{DIV ≪ l} n m p q (x: X m n) (y: X p n) (z: X q n):
  (z o- y)⋅(y o- x) ≦ z o- x.
Proof. dual @ldv_trans. Qed.

Lemma str_rdv `{laws} `{STR+DIV ≪ l} n m (x: X m n): (x o- x)^* ≡ x o- x.
Proof. dual @str_ldv. Qed.

Lemma rdv_unfold `{laws} `{BL+DIV+CNV ≪ l} n m p (x: X m n) (y: X p n): y o- x ≡ !(!y⋅x°).
Proof. dual @ldv_unfold. Qed.


Require Export GeoCoq.Tarski_dev.Annexes.midpoint_theorems.
Require Export GeoCoq.Highschool.circumcenter.
Require Export GeoCoq.Highschool.orthocenter.
Require Export GeoCoq.Highschool.midpoint_thales.
Require Export GeoCoq.Highschool.concyclic.
Require Export GeoCoq.Highschool.gravityCenter.

Import concyclic.

Ltac assert_cops :=
 repeat match goal with
      | H:Perp ?X1 ?X2 ?X3 ?X4 |- _ =>
     not_exist_hyp_perm_cop X1 X2 X3 X4; assert (Coplanar X1 X2 X3 X4) by (apply perp__coplanar, H)
      | H:TS ?X1 ?X2 ?X3 ?X4 |- _ =>
     not_exist_hyp_perm_cop X1 X2 X3 X4; assert (Coplanar X1 X2 X3 X4) by (apply ts__coplanar, H)
      | H:OS ?X1 ?X2 ?X3 ?X4 |- _ =>
     not_exist_hyp_perm_cop X1 X2 X3 X4; assert (Coplanar X1 X2 X3 X4) by (apply os__coplanar, H)
      | H:ReflectL ?X1 ?X2 ?X3 ?X4 |- _ =>
     not_exist_hyp_perm_cop X1 X2 X3 X4; assert (Coplanar X1 X2 X3 X4) by (apply reflectl__coplanar, H)
      | H:Reflect ?X1 ?X2 ?X3 ?X4 |- _ =>
     not_exist_hyp_perm_cop X1 X2 X3 X4; assert (Coplanar X1 X2 X3 X4) by (apply reflect__coplanar, H)
      | H:InAngle ?X1 ?X2 ?X3 ?X4 |- _ =>
     not_exist_hyp_perm_cop X1 X2 X3 X4; assert (Coplanar X1 X2 X3 X4) by (apply inangle__coplanar, H)
      | H:Par_strict ?X1 ?X2 ?X3 ?X4 |- _ =>
     not_exist_hyp_perm_cop X1 X2 X3 X4; assert (Coplanar X1 X2 X3 X4) by (apply pars__coplanar, H)
      | H:Par ?X1 ?X2 ?X3 ?X4 |- _ =>
     not_exist_hyp_perm_cop X1 X2 X3 X4; assert (Coplanar X1 X2 X3 X4) by (apply par__coplanar, H)
      | H:Plg ?X1 ?X2 ?X3 ?X4 |- _ =>
     not_exist_hyp_perm_cop X1 X2 X3 X4; assert (Coplanar X1 X2 X3 X4) by (apply plg__coplanar, H)
      | H:Parallelogram_strict ?X1 ?X2 ?X3 ?X4 |- _ =>
     not_exist_hyp_perm_cop X1 X2 X3 X4; assert (Coplanar X1 X2 X3 X4) by (apply plgs__coplanar, H)
      | H:Parallelogram_flat ?X1 ?X2 ?X3 ?X4 |- _ =>
     not_exist_hyp_perm_cop X1 X2 X3 X4; assert (Coplanar X1 X2 X3 X4) by (apply plgf__coplanar, H)
      | H:Parallelogram ?X1 ?X2 ?X3 ?X4 |- _ =>
     not_exist_hyp_perm_cop X1 X2 X3 X4; assert (Coplanar X1 X2 X3 X4) by (apply parallelogram__coplanar, H)
      | H:Rhombus ?X1 ?X2 ?X3 ?X4 |- _ =>
     not_exist_hyp_perm_cop X1 X2 X3 X4; assert (Coplanar X1 X2 X3 X4) by (apply rhombus__coplanar, H)
      | H:Rectangle ?X1 ?X2 ?X3 ?X4 |- _ =>
     not_exist_hyp_perm_cop X1 X2 X3 X4; assert (Coplanar X1 X2 X3 X4) by (apply rectangle__coplanar, H)
      | H:Square ?X1 ?X2 ?X3 ?X4 |- _ =>
     not_exist_hyp_perm_cop X1 X2 X3 X4; assert (Coplanar X1 X2 X3 X4) by (apply square__coplanar, H)
      | H:Saccheri ?X1 ?X2 ?X3 ?X4 |- _ =>
     not_exist_hyp_perm_cop X1 X2 X3 X4; assert (Coplanar X1 X2 X3 X4) by (apply sac__coplanar, H)
      | H:Lambert ?X1 ?X2 ?X3 ?X4 |- _ =>
     not_exist_hyp_perm_cop X1 X2 X3 X4; assert (Coplanar X1 X2 X3 X4) by (apply lambert__coplanar, H)
      | H:is_circumcenter ?X1 ?X2 ?X3 ?X4 |- _ =>
     not_exist_hyp_perm_cop X1 X2 X3 X4; assert (Coplanar X1 X2 X3 X4) by (apply is_circumcenter_coplanar, H)
      | H:is_orthocenter ?X1 ?X2 ?X3 ?X4 |- _ =>
     not_exist_hyp_perm_cop X1 X2 X3 X4; assert (Coplanar X1 X2 X3 X4) by (apply is_orthocenter_coplanar, H)
      | H:is_gravity_center ?X1 ?X2 ?X3 ?X4 |- _ =>
     not_exist_hyp_perm_cop X1 X2 X3 X4; assert (Coplanar X1 X2 X3 X4) by (apply is_gravity_center_coplanar, H)
 end.

Ltac Cop := auto; try (intros; solve [apply col__coplanar; Col
     |apply coplanar_perm_1, col__coplanar; Col|apply coplanar_perm_4, col__coplanar; Col
     |apply coplanar_perm_18, col__coplanar; Col
     |assert_cops; auto 2 with cop_perm]).

Ltac copr_aux :=
 repeat match goal with
      | H: ~ Col ?X1 ?X2 ?X3, X4 : Tpoint |- _ =>
     not_exist_hyp_perm_cop X1 X2 X3 X4;
     first[exist_hyp_perm_col X1 X2 X4; assert (Coplanar X1 X2 X4 X3) by (apply col__coplanar; Col)
          |exist_hyp_perm_col X2 X3 X4; assert (Coplanar X2 X3 X4 X1) by (apply col__coplanar; Col)
          |exist_hyp_perm_col X1 X3 X4; assert (Coplanar X1 X3 X4 X2) by (apply col__coplanar; Col)]
 end.

Ltac CopR :=
 let tpoint := constr:(Tpoint) in
 let col := constr:(Col) in
 let cop := constr:(Coplanar) in
   treat_equalities; assert_cols; clean; assert_ncols; assert_cops; auto 2 with cop_perm;
   solve[apply col__coplanar; Col|apply coplanar_perm_1, col__coplanar; Col
        |apply coplanar_perm_4, col__coplanar; Col|apply coplanar_perm_18, col__coplanar; Col
        |copr_aux; Cop_refl tpoint col cop] || fail "Can not be deduced".

Section Euler_line.

Context `{TE:Tarski_euclidean}.

(**
<applet name="ggbApplet" code="geogebra.GeoGebraApplet" archive="geogebra.jar"
        codebase="http://www.geogebra.org/webstart/4.0/unsigned/"
        width="796" height="466">
        <param name="ggbBase64" value="UEsDBBQACAAIALt4u0QAAAAAAAAAAAAAAAAWAAAAZ2VvZ2VicmFfamF2YXNjcmlwdC5qc0srzUsuyczPU0hPT/LP88zLLNHQVKiuBQBQSwcI1je9uRkAAAAXAAAAUEsDBBQACAAIALt4u0QAAAAAAAAAAAAAAAAMAAAAZ2VvZ2VicmEueG1s3VvbcptIGr7OPEWXLvYqQn0GsnKmnGRm4qpkPLXObm3tTQpBWyJGoAFkS6l5qX2Rfab9uxsQCEuxHNtRksRpoH/68H3/qbvx+OfVPEHXKi/iLD0ZEAcPkErDLIrT6clgWV4OvcHPL38aT1U2VZM8QJdZPg/KkwHXknF0MsBeNPGFr4ZcRRL+CydDf3JJhhPJsO9j5bJADBBaFfGLNPs9mKtiEYTqIpypefAuC4PSdDwry8WL0ejm5sapu3KyfDqaTifOqogGCIaZFieD6uIFNNd56YYZcYoxGf37/Tvb/DBOizJIQzVAegrL+OVPz8Y3cRplN+gmjsrZycDDMI2ZiqczmJPUNyMttABAFios42tVwKutWzPncr4YGLEg1fXP7BVKmukMUBRfx5HKAR+HCuYCBFkeq7SsBEjV0ahuYnwdqxvblr4y3fABKrMsmQS6GfTXX4hiitFzXRBbUCiktFXYPsPMFtQW3BbCynD7Orei3MpwK8PZAF3HRTxJ1MngMkgKgC1OL3OgrLkvynWizHiqB5spk+cwpyL+DMJM42hxhucYP9c/AO5zXgPcmiRp9VrmywM7rbsUHrt7l/RrumR1lxTf0iUVO2Yp94Brx3CXaRLRQha6Mv/MT69HRg/o0d5/XYeSP8kUx6PaUsaVcaBipmUrJks1L7S5MB8JX2s9QQJMQ7qg5AIRHwqXIjAGRATiAm6Jh6QuXcRcqOCIIQ9pOcKQsQ3hwX/cNY1JJKAx/dQFk0QEOuJIMESMSXEEhoSMWYKJUgYSQiABL+nuCdVNMIm4hDvmIQ5j1BbpEhBk8CLcQ/cUMYKYfpm4iEokdXuEa0uXnh46NEmRxEgS3SAYNRi0NWaQ9xDTs5EVXHG6WJYdiMJ5VF+W2aLhAqTBHW08nXVPHUf4bJwEE5VAbLjQTCJ0HSTaIkxHl1laoppEap9N82Axi8PiQpUlvFWgT8F18C4o1epXkC7qvo1smKXFH3lWvs6S5TwtEAqzBDdjzhLSuqbNqOGGtSp4u0K0KmTr2r213wxq0LJQ0H+WF7V4EEVnWmLjGgDJ8zRZv8pVcLXI4u40xiMTZsZqGSZxFAfpv0BZdS8aF1RHHeOt6qjDuVcPJMuji3UBGoxW/1F5Bj6GE4eL1l93gNa2imHpEG/zF8y9CANte1x034HYs95ZZXpW1w1BwUpt5jrNtWG3bs6KV1myeWSm/zpYlMvc5Aswq1xP6jSdJsqoiDFsCMbh1SRbXVjdYLatD+sF3GE7gsnUwI7ANVABA55W5cSWRkYPrZHCRgYbCVwrWxw19cSnRsKUE1saKdBeO7RqqqSeJsF1N3FhM5tBZTa1s9K6r2P7Mo3Ld/VNGYdXm6nqF35fzieq0aBum+Sh2hyPtlRsfKXyVCWVRgOZy2xZWANtKXukwngOt7aigiTQdP0TBmCfRmqaq3rgicnFLGCmFreVtffYNPVrns3P0usPoAtbAxiP6lGOizCPF1rn0ASiwJXaaFUUFwEEkaj9njZBmHqogwXAU2powDiX5SzLTboFPgVKbXmJmkOehUqjXkZDG5hPTdam8UTZ5BO4tSby2foNYVB9q6oZpQySxSzQmV016SRYq7wDg2nvfRZtgwPYmxmAjS8stwulrFrY8cLFApoz1tTxUYB2gVYwAAf0ea3zbx/i7WebstucVU9Vm1jHK9unWzyB8liUvoDXq+8fryFzhGcQw452BY+M2OvvHzHu6GR1rXFiD6NiYTafB2mEUpMK/pEl62mWDjbJSYC1aaKAaI1DAdUwWoyWZV2/gLeIlQmtTAAFhP6J7a3q4xZ6bG81AbadbiAoIUW5gmVYYZYGZRWXzMXbOIqUSU9H+4ltQdlmlghmuBWkilQbaskh1O7Wv0JN9V0zkPALGnj4QA/UwbYmwXq1/UcYvRoKx/WsYvmOi/2WDNuO0XenRv2Z2lcKGzjj+SKJw7hsNCnROn+WlhBGlYkj/eh4pdRCpyXn6Yc8SAu912FlWlH3jjQEx0PDEDu8ywPmhgjXca2BDz1HUs439eSH4WFyRDwwR3ZpqOyBOL609uCCBG3x8D3ZQ9fLv48jGxlvdfN9//7mS268HWXf3CvK6g2KqS0mtvh6ThmswQyJcPEYwfIdML8F4SsL4ZsehNF+CLUSNQhFfQS7K5IddtFddj2EUUBCazNa6bjWCoZEpyDS25hBb+n2MGZwsPZW0J/2oP/lEO395Wi0FyKD9A341PHZ06jvL7s8gDpAfdWxqC9xhF+txzxRaS+4AgKZ8xOrbOPJt/COLN6qh/dvh+jsb0ejs5Az+syVmPnVH2bwF8SRTFZxlAItRPAHVOTzvJxlsI4IkltUugpqQQ/iywNU+vJYVHpo08L1rsTR5u0E02/poPfyUbnpSY+P6QF8TI+FD5sdrnfkj5oN7DDqtdh4pOz9cN9zaYmY9oh4e4jveXs0vkdyhzPie7wB2uyTQNrOPMlb1mCcECyqPLdlPw/pj7TWv4o15Fm+BXrfDc0OUPvZsaj9HdwQdVzS3j14rOXSvWjoe5/4ABriY6Hhi95HONglLRKePBTscj4z63ziHg/nhzif86NxPq4jhU9JQ4J1Ppw7wsMbN1OtQh/V+byP87yn71USdN6D+/RvwSIr/n4I6PUr94H+wfbSW64IckspMfGES13OKOey3rjxIBxwxrkAXijB3iOsoV7HeZhspzjn9Xb5NtpX+3EOszQOGwSv7rc59kBO5l4uIp6q9Nr42wKhFa4+WVtj2z/6XD9ZERM4dB2pHn0mLWrmQZnHK3Ray5/WUqdUE6tDi8CccNcnVAq9X33Kqj5OuWmaSun74PuYpB5zjYQwOiEEh+SYui6HVMGvT/e3nZv+rCK+BDL2kr/3sKQ2E3Mc0lcFfdRBq1T4I6kOTcwFzCS4m1X2D0/o0x+emLJnzvwQbTtgw/gj+bot49tHe/+c03Hdto8hdTT2Oi7JBmPuEN/3hCRSr4yJFI+0DfEtDlSOjJchuAjRcf5us5tPmO8RTl0qpCuEqM9YsE+wzyXFwncfa4PoWzBzp2j9xOzsOHtsjh6H3/XZYzdImM+ttkNEExs2p+r9fev//Xd/ADCf8zQUgrR+H0a1rHCHYOdi15eMShcinS+9L7n6fUkbwf2c4q6n5F+x7AjysJWj1V9SJEl28w91maiVgfeuXNwesF9bHt7WodqE4FZi3IvbrPrUoY7bszpuTz7qkM4bq/tIDg/h7OlCOO4Y91N8/nDfMLF7pA8XIojcGyIIOC1CPb3BxJmPBfueXNJ+WmZHRAtzSDejaj5L8WhnlWdJkXopwDdx+8cJ3NqXHAspO7KpHZbyo+dSR2Qtw21zqZi53VqEwzyPNx6M+nuYYUfGzJ0+AXjbXXpvx+6zQ7a5zo5mbxE71O/tsBvzI6zz+DE+EriobOAgoD/tB3rbrj59052uDdDC8SlYiPR8zPQv4NF6Ne8TiplLuOCehESa1QccGDJr7rrg6KRHiHsXR0eOxJ5G7Y/2za/GVL/Z+fL/UEsHCHiX1BNKCgAAdjoAAFBLAQIUABQACAAIALt4u0TWN725GQAAABcAAAAWAAAAAAAAAAAAAAAAAAAAAABnZW9nZWJyYV9qYXZhc2NyaXB0LmpzUEsBAhQAFAAIAAgAu3i7RHiX1BNKCgAAdjoAAAwAAAAAAAAAAAAAAAAAXQAAAGdlb2dlYnJhLnhtbFBLBQYAAAAAAgACAH4AAADhCgAAAAA=" />
        <param name="image" value="http://www.geogebra.org/webstart/loading.gif" />
        <param name="boxborder" value="false" />
        <param name="centerimage" value="true" />
        <param name="java_arguments" value="-Xmx512m -Djnlp.packEnabled=true" />
        <param name="cache_archive" value="geogebra.jar, geogebra_main.jar, geogebra_gui.jar, geogebra_cas.jar, geogebra_algos.jar, geogebra_export.jar, geogebra_javascript.jar, jlatexmath.jar, jlm_greek.jar, jlm_cyrillic.jar, geogebra_properties.jar" />
        <param name="cache_version" value="4.0.19.0, 4.0.19.0, 4.0.19.0, 4.0.19.0, 4.0.19.0, 4.0.19.0, 4.0.19.0, 4.0.19.0, 4.0.19.0, 4.0.19.0, 4.0.19.0" />
        <param name="showResetIcon" value="false" />
        <param name="showAnimationButton" value="true" />
        <param name="enableRightClick" value="false" />
        <param name="errorDialogsActive" value="true" />
        <param name="enableLabelDrags" value="false" />
        <param name="showMenuBar" value="false" />
        <param name="showToolBar" value="false" />
        <param name="showToolBarHelp" value="false" />
        <param name="showAlgebraInput" value="false" />
        <param name="useBrowserForJS" value="true" />
        <param name="allowRescaling" value="true" />
C'est une appliquette Java créée avec GeoGebra ( www.geogebra.org) - Il semble que Java ne soit pas installé sur votre ordinateur, merci d'aller sur www.java.com
</applet>
*)

Lemma concyclic_not_col_or_eq_aux :
  forall A B C D, Concyclic A B C D -> A = B \/ A = C \/ B = C \/ ~ Col A B C.
Proof.
intros A B C D HC.
elim (eq_dec_points A B); intro HAB; Col.
elim (eq_dec_points A C); intro HAC; Col.
elim (eq_dec_points B C); intro HBC; Col5.
right; right; right; intro HCol.
destruct HC as [HCop [O [HCong1 [HCong2 HCong3]]]].
assert (H := midpoint_existence A B); destruct H as [M1 HMid1].
assert (HOM1 : O <> M1).
  {
  intro; treat_equalities.
  assert (H := l7_20 O A C); elim H; clear H; try intro H; Cong;
  try (apply HBC; apply symmetric_point_uniqueness with A O; Col);
  assert_cols; ColR.
  }
assert (H := midpoint_existence A C); destruct H as [M2 HMid2].
assert (HOM2 : O <> M2).
  {
  intro; treat_equalities.
  assert (H := l7_20 O A B); elim H; clear H; try intro H; Cong;
  try (apply HBC; apply symmetric_point_uniqueness with A O; Col);
  assert_cols; ColR.
  }
assert (HM1M2 : M1 <> M2) by (intro; treat_equalities; Col).
assert (HPerp1 : Perp_bisect O M1 A B)
  by (apply cong_mid_perp_bisect; spliter; Cong).
assert (HPerp2 : Perp_bisect O M2 A C)
  by (apply cong_mid_perp_bisect; spliter; Cong).
assert (HOM1M2 : ~ Col O M1 M2).
  {
  intro HOM1M2; assert (H := l7_20 O A B); elim H; clear H; try intro H; Cong;
  try (apply HOM1; apply l7_17 with A B; Col); assert_diffs; assert_cols; ColR.
  }
assert (HPar_strict : Par_strict O M1 O M2).
  {
  apply par_not_col_strict with M2; Col.
  apply l12_9 with A B; try CopR.
    apply coplanar_perm_16, col_cop__cop with C; Col; Cop.
    apply perp_bisect_perp; Col.
  apply perp_col0 with A C; Col; perm_apply perp_bisect_perp.

  }
assert (H := not_par_strict_id O M1 M2); Col.
Qed.

Lemma concyclic_not_col_or_eq :
  forall A B C A', Concyclic A B C A' ->
  A'=C \/ A'=B \/ A=B \/ A=C \/ A=A' \/ (~ Col A B A' /\ ~ Col A C A').
Proof.
intros A B C A' H.
assert (H' := H); apply concyclic_perm_1 in H; apply concyclic_perm_3 in H'.
apply concyclic_not_col_or_eq_aux in H; apply concyclic_not_col_or_eq_aux in H'.
elim (eq_dec_points A' C); intro; try tauto.
elim (eq_dec_points A' B); intro; try tauto.
elim (eq_dec_points A B); intro; try tauto.
elim (eq_dec_points A C); intro; try tauto.
elim (eq_dec_points A A'); intro; try tauto.
do 3 (elim H; clear H; intro H; try tauto); Col.
do 3 (elim H'; clear H'; intro H'; try tauto); Col.
Qed.

Lemma Euler_line_special_case :
  forall A B C G H O,
  Per A B C ->
  is_gravity_center G A B C ->
  is_orthocenter H A B C ->
  is_circumcenter O A B C ->
  Col G H O.
Proof.
intros.
assert (H=B).
  apply orthocenter_per with A C;finish.
subst.
assert (Midpoint O A C).
 apply circumcenter_per with B;finish.
 unfold is_orthocenter in *;spliter;assert_diffs;finish.
 unfold is_orthocenter in *;spliter;assert_diffs;finish.
assert (is_gravity_center G A C B).
 apply is_gravity_center_perm in H1;intuition.
perm_apply (is_gravity_center_col A C B G O).
Qed.

Lemma gravity_center_change_triangle:
 forall A B C G I B' C',
 is_gravity_center G A B C ->
 Midpoint I B C ->
 Midpoint I B' C' ->
 ~ Col A B' C' ->
 is_gravity_center G A B' C'.
Proof.
intros.
Name G' the midpoint of A and G.
assert (Midpoint G I G')
  by (apply (is_gravity_center_third A B C G G' I);finish).
apply (is_gravity_center_third_reci A B' C' G I G');finish.
Qed.

Lemma Euler_line :
 forall A B C G H O,
  ~ Col A B C ->
  is_gravity_center G A B C ->
  is_orthocenter H A B C ->
  is_circumcenter O A B C ->
  Col G H O.
Proof.
intros.
elim (cong_dec A B A C); intro.

Name A' the midpoint of B and C.
Name B' the midpoint of A and C.
Name C' the midpoint of A and B.

assert (Perp_bisect A A' B C)
  by (apply cong_mid_perp_bisect; Cong; intro; treat_equalities; apply H0; Col).

assert (Col G A' A)
  by (apply is_gravity_center_perm in H1; apply is_gravity_center_col with B C; spliter; Col).

unfold is_orthocenter in *; spliter.

elim (eq_dec_points O G); intro; treat_equalities; Col;
elim (eq_dec_points O H); intro; treat_equalities; Col.

elim (eq_dec_points O A'); intro; treat_equalities.

assert (Col A H O) by (apply cop_perp2__col with B C; Col; Cop; apply perp_bisect_perp; Col).
apply is_gravity_center_coplanar in H1.
apply col_permutation_1; apply cop_perp2__col with B C.

CopR.
apply perp_sym; apply perp_col0 with A O; try apply perp_bisect_perp; Col.
apply perp_sym; apply perp_col0 with A H; Col.

assert (Col A A' H) by (apply cop_perp2__col with B C; Cop; apply perp_bisect_perp; auto).
assert (Perp_bisect O A' B C) by (assert_diffs; apply circumcenter_perp with A; auto).
assert (Col A' A O)
  by (apply cop_perp2__col with B C; Perp; Cop).
show_distinct A A'.
  apply H0; Col.
ColR.

Name A' the symmetric of A wrt O.

assert_diffs.

assert (Concyclic A B C A').
 unfold Concyclic.
 split.
 destruct (eq_dec_points A O).
  treat_equalities; Cop.
 apply coplanar_perm_12, col_cop__cop with O; Col; Cop.
 exists O.
 apply circumcenter_cong in H3.
 spliter.
 assert_congs_perm.
 spliter;repeat (split;finish).

assert (T:=concyclic_not_col_or_eq A B C A' H5).
decompose [or] T;clear T;try contradiction.
 - subst.
   assert (Per A B C).
    apply midpoint_thales with O;finish.
    unfold is_circumcenter in *;spliter;finish.
   apply (Euler_line_special_case A B C G H O);finish.
 - subst.
   assert (Per A C B).
    apply midpoint_thales with O;finish.
    unfold is_circumcenter in *;spliter.
    apply cong_transitivity with O B;finish.

   apply (Euler_line_special_case A C B G H O);finish.
   apply is_gravity_center_perm_1; assumption.
   auto with Orthocenter.
   auto with Circumcenter.

 - unfold is_circumcenter in *;spliter.
   treat_equalities.
   intuition.
 - spliter.

assert_diffs.

assert (Per A B A').
 apply midpoint_thales with O;finish.
 unfold is_circumcenter in *;spliter;finish.

assert (Perp C H A B)
 by (unfold is_orthocenter in *;spliter;finish).

assert (Perp A' B B A)
 by (apply per_perp;finish).

assert (Par C H A' B).
 unfold Concyclic in *; spliter.
 apply is_orthocenter_coplanar in H2.
 apply l12_9 with A B; try CopR; Perp.

assert (Perp B H A C)
 by (unfold is_orthocenter in *;spliter;finish).

assert (Per A C A').
 {
 apply midpoint_thales with O;finish.
 unfold is_circumcenter in *;spliter;finish.
 apply cong_transitivity with B O;finish.
 }

assert (Perp A' C C A) by (apply per_perp;finish).

assert (Par B H C A').
 unfold Concyclic in *; spliter.
 apply l12_9 with A C; try CopR; Perp.

induction (col_dec B H C).
 * assert (H=B \/ H=C) by (apply (orthocenter_col A B C H);finish).
   induction H26.
   + subst H.
     assert (Midpoint O A C) by (apply (circumcenter_per) with B;finish).
     assert (Col G O B).
        apply (is_gravity_center_col A C B G O).
        apply is_gravity_center_perm in H1;intuition idtac.
        assumption.
     Col.
   (*  perm_apply (is_gravity_center_col A C B G O). bug in 8.5 *)
   + subst H;assert_diffs; intuition.
 * assert (Parallelogram B H C A')
     by (apply par_2_plg;finish).

   assert (T:exists I : Tpoint, Midpoint I B C /\ Midpoint I H A')
     by (apply plg_mid;finish).

   destruct T as [I [HI1 HI2]].

   elim (per_dec B A C); intro.

   apply Euler_line_special_case with B A C;
   try apply is_gravity_center_cases; auto;
   try apply is_orthocenter_cases; auto;
   try apply is_circumcenter_cases; auto.

   assert (is_gravity_center G A H A').
     {
     apply gravity_center_change_triangle with B C I;finish.
     show_distinct A' H; treat_equalities.
     apply plg_par in H26; spliter; assert_diffs; Col.
     intro.
     Name A'' the midpoint of B and C.
     show_distinct A'' O; treat_equalities.
     apply H27; apply perp_per_1; assert_diffs; Perp.
     assert (Perp_bisect O A'' B C) by (apply circumcenter_perp with A; Col).
     elim (eq_dec_points A A''); intro; treat_equalities.
     eauto using perp_bisect_cong_2 with cong.
     assert (Perp_bisect A'' A B C).
     apply perp_mid_perp_bisect; Col.
     apply perp_sym; apply perp_col0 with O A''; Col;
     try (apply perp_bisect_perp; assumption); assert_cols; try ColR.
     eauto using perp_bisect_cong_2 with cong.
     }

   assert (is_gravity_center G A A' H)
     by (apply is_gravity_center_cases;auto).

   perm_apply (is_gravity_center_col A A' H G O).
Qed.

End Euler_line.


(* [10],Fig.1 for Performance Evaluation of COMPSAC'17 paper*)

Require Export parser.
Require Export refine.

(** the security of single component Transaction Service *)
Definition TS: IA := parse
"IA [s1,s2,s3,s4,s5,s6,s7] (s1) [acceptT, endT, newT, startM, endM] [startT, logM] []
[s1->(acceptT)s1, s1->(newT)s2, s2->(startT)s3, s3->(endT)s1, s1->(startM)s4,
s4->(endM)s1, s4->(newT)s5, s5->(startT)s6, s6->(endT)s7, s7->(logM)s4]".

(*SIR-GNNI: true*)
Definition TS_hid: IA :=
 IAutomaton.hiding TS (ASet.GenActs [&"startM",&"endM",&"logM"]).

Definition TS_res: IA :=
 IAutomaton.hiding
 ( IAutomaton.restriction TS (ASet.GenActs [&"startM",&"endM"]) )
 (ASet.GenActs [&"logM"]).

Eval compute in :> TS_hid.
Eval compute in :> TS_res.
Eval compute in SIRGNNI_refinement TS_res TS_hid.

(*SME-NI: true *)
Definition TS_rep: IA :=
 IAutomaton.hiding
 ( IAutomaton.replacement TS (&"tau") (ASet.GenActs [&"startM",&"endM"]) )
 (ASet.GenActs [&"logM"]).

Eval compute in :> TS_rep.
Eval compute in SMENI_refinement TS_rep TS_hid.

(** the security of Supervisor *)
Definition SV: IA := parse
"IA [u1,u2,u3,u4,u5] (u1) [mOn, logM, logF] [startM, endM] []
 [u1->(mOn)u2, u1->(logF)u1, u2->(startM)u3, u3->(logM)u3, u3->(logF)u4,
 u4->(logM)u5, u5->(endM)u1]".

(*SIR-GNNI: true *)
Definition SV_hid: IA :=
 IAutomaton.hiding SV (ASet.GenActs [&"mOn",&"logM",&"startM",&"endM"]).

Definition SV_res: IA :=
 IAutomaton.hiding
 ( IAutomaton.restriction SV (ASet.GenActs [&"mOn",&"logM"]) )
 (ASet.GenActs [&"endM",&"startM"]).

Eval compute in :> SV_hid.
Eval compute in :> SV_res.
Eval compute in SIRGNNI_refinement SV_res SV_hid.

(*SME-NI: true *)
Definition SV_rep: IA :=
 IAutomaton.hiding
 ( IAutomaton.replacement SV (&"tau") (ASet.GenActs [&"mOn", &"logM"]) )
 (ASet.GenActs [&"startM",&"endM"]).

Eval compute in :> SV_rep.
Eval compute in SMENI_refinement SV_rep SV_hid.

(** the security of the result of composition *)
Definition TPU: IA := parse
"IA [t1,t2,t3,t4] (t1) [startT] [nOk,ok,logF,endT] []
[t1->(startT)t2, t2->(nOk)t4, t4->(logF)t3, t2->(ok)t3,t3->(endT)t1]".

Definition compIA: IA := IAutomaton.composition TS (IAutomaton.composition TPU SV).
Eval compute in :> compIA.

(*SIR-GNNI: true *)
Definition compIA_hid: IA :=
 IAutomaton.hiding compIA (ASet.GenActs [&"mOn"]).

Definition compIA_res: IA :=
 IAutomaton.restriction compIA (ASet.GenActs [&"mOn"]).

Eval compute in SIRGNNI_refinement compIA_res compIA_hid.


Require Export OrderedType.
Require Export Structures.OrderedTypeEx.
Require Import mathcomp.ssreflect.ssreflect.
Require Import Omega.

Definition dyadic {A : Type} : Type := A + (A * A).

Inductive dyadic_lt {A : Type} {lt : A -> A -> Prop} : dyadic -> dyadic -> Prop :=
| dyadic_lt_t_t : forall (l l' : A), lt l l' -> dyadic_lt (inl l) (inl l')
| dyadic_lt_t_dyad : forall (l l1 l1': A), dyadic_lt (inl l) (inr (l1, l1'))
| dyadic_lt_dyad_lt : forall (l0 l0' l1 l1' : A), lt l0 l1 -> dyadic_lt (inr (l0, l0')) (inr (l1, l1'))
| dyadic_lt_dyad_eq : forall (l l0' l1' : A), lt l0' l1' -> dyadic_lt (inr (l, l0')) (inr (l, l1')).

Module Type DyadicUsualOrderedType (UOT : UsualOrderedType) <: UsualOrderedType.
  Definition t := @dyadic UOT.t.
  Definition eq := @eq t.
  Parameter Inline lt : t -> t -> Prop.
  Definition eq_refl := @eq_refl t.
  Definition eq_sym := @eq_sym t.
  Definition eq_trans := @eq_trans t.
  Parameter lt_trans : forall x y z : t, lt x y -> lt y z -> lt x z.
  Parameter lt_not_eq : forall x y : t, lt x y -> ~ eq x y.
  Parameter compare : forall x y : t, Compare lt eq x y.
  Parameter eq_dec : forall x y : t, { eq x y } + { ~ eq x y }.
End DyadicUsualOrderedType.

Module LexDyadicUsualOrderedType (UOT : UsualOrderedType) <: DyadicUsualOrderedType UOT.
  Definition t := @dyadic UOT.t.

  Definition eq := @eq t.
  Definition eq_refl := @eq_refl t.
  Definition eq_sym := @eq_sym t.
  Definition eq_trans := @eq_trans t.

  Definition eq_dec : forall t0 t1 : t, {t0 = t1}+{t0 <> t1}.
    decide equality; auto using UOT.eq_dec.
    destruct b, p.
    decide equality; auto using UOT.eq_dec.
  Defined.

  Definition lt := @dyadic_lt _ UOT.lt.

  Theorem lt_trans : forall x y z, lt x y -> lt y z -> lt x z.
  Proof.
  move => x y z H_xy H_yz.
  inversion H_xy; subst.
  - inversion H_yz; subst.
    * by apply dyadic_lt_t_t; apply UOT.lt_trans with (y := l').
    * by apply dyadic_lt_t_dyad.
  - inversion H_yz; subst.
    * by apply dyadic_lt_t_dyad.
    * by apply dyadic_lt_t_dyad.
  - inversion H_yz; subst.
    * by apply dyadic_lt_dyad_lt; apply UOT.lt_trans with (y := l1).
    * by apply dyadic_lt_dyad_lt.
  - inversion H_yz; subst.
    * by apply dyadic_lt_dyad_lt.
    * by apply dyadic_lt_dyad_eq; apply UOT.lt_trans with (y := l1').
  Qed.

  Theorem lt_not_eq : forall x y, lt x y -> x <> y.
  Proof.
  move => x y H_xy; inversion H_xy; subst => H_neq.
  - injection H_neq => H_eq.
    subst.
    apply UOT.lt_not_eq in H.
    by unfold UOT.eq in H.
  - by [].
  - injection H_neq => H_eq1 H_eq2.
    subst.
    apply UOT.lt_not_eq in H.
    by unfold UOT.eq in H.
  - injection H_neq => H_eq.
    subst.
    apply UOT.lt_not_eq in H.
    by unfold UOT.eq in H.
  Qed.

  Definition compare (x y : t) : Compare lt eq x y.
  refine
  (match x as x0, y as y0 return (x = x0 -> y = y0 -> _) with
   | inl l0, inl l1 =>
     fun (H_eq : _) (H_eq' : _) =>
     match UOT.compare l0 l1 with
     | LT H_cmp => LT _
     | EQ H_cmp => EQ _
     | GT H_cmp => GT _
     end
   | inl l0, inr (l1, l1') => fun (H_eq : _) (H_eq' : _) => LT _
   | inr (l0, l0'), inl l1 => fun (H_eq : _) (H_eq' : _) => GT _
   | inr (l0, l0'), inr (l1, l1') => fun (H_eq : _) (H_eq' : _) =>
     match UOT.compare l0 l1 with
     | LT H_cmp => LT _
     | EQ H_cmp =>
       match UOT.compare l0' l1' with
       | LT H_cmp' => LT _
       | EQ H_cmp' => EQ _
       | GT H_cmp' => GT _
       end
     | GT H_cmp => GT _
     end
   end (refl_equal _) (refl_equal _)); rewrite H_eq H_eq'.
  - exact: dyadic_lt_t_t.
  - by rewrite H_cmp.
  - exact: dyadic_lt_t_t.
  - exact: dyadic_lt_t_dyad.
  - exact: dyadic_lt_t_dyad.
  - exact: dyadic_lt_dyad_lt.
  - rewrite H_cmp.
    exact: dyadic_lt_dyad_eq.
  - by rewrite H_cmp H_cmp'.
  - rewrite H_cmp.
    exact: dyadic_lt_dyad_eq.
  - exact: dyadic_lt_dyad_lt.
  Defined.
End LexDyadicUsualOrderedType.

(*
Require Import FMapList.
Module NatDyadicUsualOrderedType <: DyadicUsualOrderedType Nat_as_OT := LexDyadicUsualOrderedType Nat_as_OT.
Module Map <: FMapInterface.S with Module E := NatDyadicUsualOrderedType := FMapList.Make NatDyadicUsualOrderedType.
Eval compute in Map.find (inr (5, 3)) (Map.add (inr (5, 3)) 2 (Map.empty nat)).
*)


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

Require Import tacs rel.

Set Implicit Arguments.

Definition square X (R : X -> X -> Prop) := forall f a b, R f a -> R f b -> exists g, R a g /\ R b g.

Section square_crt.

  Variables (X : Type) (R : X -> X -> Prop) (HR : @square X R).

  Let ri_square_1 n f a b :
           f [R,1>> a
        -> f [R,n>> b
        -> exists g, a [R,n>> g
                  /\ b [R,1>> g.
  Proof.
    revert f a.
    induction n as [ | n IHn ]; intros f a Ha Hf; simpl in Hf.
    subst; exists a; simpl; auto.
    destruct Hf as (x & H1 & H2).
    apply rel_iter_one in Ha.
    destruct (HR Ha H1) as (c & H3 & H4).
    rewrite rel_iter_one in H4.
    destruct (IHn _ _ H4 H2) as (g & H5 & H6).
    exists g; split; auto.
    exists c; auto.
  Qed.

  Theorem rel_iter_square n m f a b :
           f [R,n>> a
        -> f [R,m>> b
        -> exists g, a [R,m>> g
                  /\ b [R,n>> g.
  Proof.
    revert m f a b; induction n as [ | n IHn ]; intros m f a b Ha Hb; simpl in Ha.
    subst; exists b; simpl; auto.
    destruct Ha as (x & H1 & H2).
    rewrite rel_iter_one in H1.
    destruct (ri_square_1 _ _ H1 Hb) as (g & H3 & H4).
    destruct (IHn _ _ _ _ H2 H3) as (h & H5 & H6).
    exists h; simpl; split; auto.
    exists g; split; auto.
    apply rel_iter_one; auto.
  Qed.

  Theorem square_crt : square (crt R).
  Proof.
    intros f a b.
    do 2 rewrite rel_iter_eq_crt.
    intros (na & Ha) (nb & Hb).
    destruct rel_iter_square with (1 := Ha) (2 := Hb)
      as (g & H1 & H2); auto.

    exists g; split; apply rel_iter_eq_crt;
      try (exists nb; exact H1);
      try (exists na; exact H2).
  Qed.

End square_crt.

Definition confluent X (R : X -> X -> Prop) := square (crt R).
Definition church_rosser X (R : X -> X -> Prop) :=
    forall a b, crst R a b <-> exists f, crt R a f /\ crt R b f.

Section confluent_church_rosser.

  Variable (X : Type) (R : X -> X -> Prop) (HR : @confluent X R).

  Fact confluent_church_rosser : church_rosser R.
  Proof.
    intros a b; split.
    induction 1 as [ x y | x | x y _ (f & H1 & H2) | x y z _ (a & H1 & H2) _ (b & H3 & H4)].
    exists y; split; [ constructor 1 | constructor 2]; auto.
    exists x; split; constructor 2; auto.
    exists f; auto.
    destruct (HR H2 H3) as (f & ? & ?).
    exists f; split.
    constructor 3 with a; auto.
    constructor 3 with b; auto.

    intros (f & H1 & H2).
    constructor 4 with f.
    apply crt_inc_crst; auto.
    constructor 3.
    apply crt_inc_crst; auto.
  Qed.

End confluent_church_rosser.

Section church_rosser_confluent.

  Variable (X : Type) (R : X -> X -> Prop) (HR : @church_rosser X R).

  Fact church_rosser_confluent : confluent R.
  Proof.
    intros f a b Ha Hb.
    apply HR.
    constructor 4 with f.
    constructor 3.
    apply crt_inc_crst; auto.
    apply crt_inc_crst; auto.
  Qed.

End church_rosser_confluent.


Definition update_map(M1 M2: map K V): map K V :=
  (filter (fun '(k1, v1) =>
             if (find (fun '(k2, v2) => if keq k1 k2 then true else false) M2)
             then false else true) M1) ++ M2.


Require Export Coquelicot.Coquelicot.
Require Export Reals.
Require Export mathcomp.ssreflect.ssreflect.
Require Export FunctionalExtensionality.
Require Export hilbert.
Require Import Decidable.
Require Export lax_milgram.

(** * Finite spaces : canonical structure approach *)

Module FiniteDim.

Record mixin_of (E : ModuleSpace R_Ring) := Mixin {
  dim : nat ;
  B : nat -> E ;
  BO : B 0 = zero ;
  ax : forall u : E, exists L : nat -> R,
           u = sum_n (fun n => scal (L n) (B n)) dim
}.

Section ClassDef.

Record class_of (T : Type) := Class {
  base : ModuleSpace.class_of R_Ring T ;
  mixin : mixin_of (ModuleSpace.Pack R_Ring T base T)
}.
Local Coercion base : class_of >-> ModuleSpace.class_of.

Structure type := Pack { sort; _ : class_of sort ; _ : Type }.
Local Coercion sort : type >-> Sortclass.

Variable cT : type.

Definition class := let: Pack _ c _ := cT return class_of cT in c.

Let xT := let: Pack T _ _ := cT in T.
Notation xclass := (class : class_of xT).

Definition AbelianGroup := AbelianGroup.Pack cT xclass xT.
Definition ModuleSpace := ModuleSpace.Pack _ cT xclass xT.

End ClassDef.

Module Exports.

Coercion base : class_of >-> ModuleSpace.class_of.
Coercion mixin : class_of >-> mixin_of.
Coercion sort : type >-> Sortclass.
Coercion AbelianGroup : type >-> AbelianGroup.type.
Canonical AbelianGroup.
Coercion ModuleSpace : type >-> ModuleSpace.type.
Canonical ModuleSpace.

Notation FiniteDim := type.

End Exports.

End FiniteDim.

Export FiniteDim.Exports.

Section AboutFiniteDim.

Context {E : FiniteDim}.

Definition dim : nat := FiniteDim.dim _ (FiniteDim.class E).

Definition B : nat -> E := FiniteDim.B _ (FiniteDim.class E).

End AboutFiniteDim.

Section FiniteSpaces.

Definition BR := (fun n : nat => match (le_gt_dec n 0) with
                     | left _ => (@zero R_Ring)
                     | right _ => (@one R_Ring)
                 end).

(** R is finite *)
Lemma R_one_c : forall u : Ring_ModuleSpace R_Ring,exists L : nat -> R,
         u = sum_n (fun n => scal (L n) (BR n)) 1.
Proof.
intros u.
exists (fun n => match n with |O => (@zero R_Ring) | _ => u end).
rewrite sum_Sn.
rewrite sum_O.
rewrite scal_zero_l.
rewrite plus_zero_l.
intuition.
Qed.

Lemma BR0 : BR 0 = zero.
Proof.
intuition.
Qed.

Definition R_FiniteDim_mixin :=
   FiniteDim.Mixin _ 1%nat (fun n => BR n) BR0 R_one_c.

Canonical R_FiniteDim :=
  FiniteDim.Pack R (FiniteDim.Class _ _ R_FiniteDim_mixin) R.

Definition dimE (E : FiniteDim) := FiniteDim.dim _ (FiniteDim.class E).
Definition Base (E : FiniteDim) := FiniteDim.B _ (FiniteDim.class E).

Lemma Dim0 (E : FiniteDim) : dimE E = O -> forall u : E, u = zero.
Proof.
intros.
assert (H0 : exists L : nat -> R,
           u = sum_n (fun n => scal (L n) ((Base E) n)) (dimE E)).
apply FiniteDim.ax.
rewrite H in H0.
destruct H0 as (L,H0).
rewrite sum_O in H0.
assert (H1 : Base E O = zero).
apply FiniteDim.BO.
rewrite H1 in H0.
rewrite H0.
rewrite scal_zero_r.
reflexivity.
Qed.

(** Cartesian product of finite space is finite *)

Definition BProd (E1 : FiniteDim) (E2 : FiniteDim) (B1 : nat -> E1) (B2 : nat -> E2) :=
   (fun n => match le_gt_dec n 0 with
               | left _ => zero
               | right _ => (match (le_gt_dec n (dimE E1)) with
                    | left _  => (B1 n,(@zero E2))
                    | right _ => (match (le_gt_dec n
                                 (dimE E1 + dimE E2)%nat) with
                        | left _ => ((@zero E1),B2 (n - (dimE E1))%nat)
                        | right _ => zero
                        end)
                    end)
               end).

Lemma BPR0 (E1 E2 : FiniteDim) (B1 : nat-> E1) (B2 : nat -> E2) :
            BProd E1 E2 B1 B2 O = zero.
Proof.
unfold BProd.
destruct (le_gt_dec 0 0).
reflexivity.
exfalso; intuition.
Qed.

Definition LProd (E1 E2 : FiniteDim) (L1 L2 : nat -> R) :=
  (fun n => match le_gt_dec n (dimE E1) with
             | left _ => L1 n
             | right _ => L2 ((n - dimE E1)%nat)
        end).

Lemma sum_n_fst (E1 E2 : ModuleSpace R_Ring) : forall (n : nat) (L : nat -> (E1*E2)),
        fst (sum_n (fun n => L n) n) = sum_n (fun n => fst (L n)) n.
Proof.
intros.
induction n.
simpl.
rewrite sum_O.
rewrite plus_zero_r.
reflexivity.
symmetry.
rewrite sum_Sn.
rewrite sum_Sn.
simpl.
f_equal.
unfold sum_n.
unfold sum_n_m.
unfold Iter.iter_nat.
simpl.
simpl in IHn.
unfold sum_n in IHn.
unfold sum_n_m, Iter.iter_nat in IHn.
simpl in IHn.
symmetry.
trivial.
Qed.

Lemma sum_n_snd (E1 E2 : ModuleSpace R_Ring) : forall (n : nat) (L : nat -> (E1*E2)),
        snd (sum_n (fun n => L n) n) = sum_n (fun n => snd (L n)) n.
Proof.
intros.
induction n.
simpl.
rewrite sum_O.
rewrite plus_zero_r.
reflexivity.
symmetry.
rewrite sum_Sn.
rewrite sum_Sn.
simpl.
f_equal.
unfold sum_n.
unfold sum_n_m.
unfold Iter.iter_nat.
simpl.
simpl in IHn.
unfold sum_n in IHn.
unfold sum_n_m, Iter.iter_nat in IHn.
simpl in IHn.
symmetry.
trivial.
Qed.

Lemma sum_n_m_decal (E : ModuleSpace R_Ring) : forall (n m d: nat) (L : nat -> E),
        sum_n_m (fun n => L n) m n = sum_n_m (fun n => L ((n - d)%nat)) (m + d)%nat (n + d)%nat.
Proof.
intros n m d L.
induction d.
assert ((fun n0 : nat => L (n0 - 0)%nat)
         =
        (fun n0 : nat => L n0)).
apply functional_extensionality.
intros x.
replace (x-0)%nat with x by intuition.
reflexivity.
rewrite H.
replace (m + 0)%nat with m by intuition.
replace (n + 0)%nat with n by intuition.
reflexivity.
rewrite IHd.
replace (m + S d)%nat with (S ((m + d)%nat)) by auto.
replace (n + S d)%nat with (S ((n + d)%nat)) by auto.
rewrite <- sum_n_m_S.
assert (Hss :(fun n0 : nat => L (n0 - d)%nat)
       =
       (fun n0 : nat => L (S n0 - S d)%nat)).
apply functional_extensionality.
intros n0.
replace (S n0 - S d)%nat with (n0 - d)%nat by auto.
reflexivity.
rewrite Hss.
reflexivity.
Qed.

Lemma Product_c (E1 E2 : FiniteDim) : forall (u : E1*E2), exists L : nat -> R,
    u = sum_n (fun n => scal (L n) ((BProd E1 E2 (Base E1) (Base E2) n))) ((dimE E1) + (dimE E2)).
Proof.
intros (u1,u2).
assert (H1 : forall (u1 : E1), exists L : nat -> R,
    u1 = sum_n (fun n => scal (L n) ((Base E1) n)) (dimE E1)).
apply FiniteDim.ax.
specialize (H1 u1).
destruct H1 as (L1,H1).
assert (H2 : forall (u2 : E2), exists L : nat -> R,
u2 = sum_n (fun n => scal (L n) ((Base E2) n)) (dimE E2)).
apply FiniteDim.ax.
specialize (H2 u2).
destruct H2 as (L2,H2).
exists (LProd E1 E2 L1 L2).
rewrite H1 H2.
apply injective_projections.
(* projection 1 *)
rewrite (sum_n_fst E1 E2).
simpl.
unfold BProd.
unfold sum_n.
rewrite (sum_n_m_Chasles _ 0 (dimE E1) (dimE E1 + dimE E2) ).
replace (sum_n_m (fun n : nat => scal (L1 n) (Base E1 n)) 0 (dimE E1))
      with (plus (sum_n_m (fun n : nat => scal (L1 n) (Base E1 n)) 0 (dimE E1))
           (sum_n_m (fun n : nat => (@zero E1))  (S (dimE E1)) (dimE E1 + dimE E2))).
f_equal.
apply sum_n_m_ext_loc.
intros k Hk.
destruct (le_gt_dec k 0).
assert (Hk0 : k = O).
intuition.
rewrite Hk0.
assert (Base E1 0 = zero).
apply FiniteDim.BO.
rewrite H.
intuition.
destruct (le_gt_dec k (dimE E1)).
simpl.
unfold LProd.
destruct (le_gt_dec k (dimE E1)).
reflexivity.
exfalso; intuition.
exfalso; intuition.
apply sum_n_m_ext_loc.
intros k Hk.
destruct (le_gt_dec k 0).
assert (Hk0 : k = O).
intuition.
rewrite Hk0.
simpl.
rewrite scal_zero_r.
reflexivity.
destruct (le_gt_dec k (dimE E1)).
exfalso; intuition.
destruct (le_gt_dec k (dimE E1 + dimE E2)).
simpl.
rewrite scal_zero_r.
reflexivity.
simpl.
rewrite scal_zero_r.
reflexivity.
rewrite sum_n_m_const_zero.
rewrite plus_zero_r.
reflexivity.
intuition.
intuition.
(* projection 2 *)
rewrite (sum_n_snd E1 E2).
simpl.
unfold sum_n.
rewrite (sum_n_m_Chasles _ 0 (dimE E1) (dimE E1 + dimE E2)).
replace (sum_n_m (fun n : nat => scal (L2 n) (Base E2 n)) 0 (dimE E2))
        with
        (plus
           (sum_n_m (fun n : nat => (@zero E2)) 0 (dimE E1))
           (sum_n_m (fun n : nat => scal (L2 n) (Base E2 n)) 0 (dimE E2))
        ).
f_equal.
apply sum_n_m_ext_loc.
intros k Hk.
unfold BProd.
destruct (le_gt_dec k 0).
simpl.
rewrite scal_zero_r.
reflexivity.
destruct (le_gt_dec k (dimE E1)).
simpl.
rewrite scal_zero_r.
reflexivity.
exfalso; intuition.
rewrite (sum_n_m_decal E2 (dimE E2) 0 (dimE E1)
        (fun n : nat => scal (L2 n) (Base E2 n))).
replace (dimE E1 + dimE E2)%nat with (dimE E2 + dimE E1)%nat
        by intuition.
assert (sum_n_m (fun n : nat => scal (L2 (n - dimE E1)%nat)
                        (Base E2 (n - dimE E1)))
             (0 + dimE E1) (dimE E2 + dimE E1) =
        sum_n_m (fun n : nat => scal (L2 (n - dimE E1)%nat)
                        (Base E2 (n - dimE E1)))
             (S (dimE E1)) (dimE E2 + dimE E1)).
simpl.
rewrite sum_Sn_m.
replace (dimE E1 - dimE E1)%nat with O by intuition.
replace (Base E2 0) with (@zero E2).
rewrite scal_zero_r.
rewrite plus_zero_l.
reflexivity.
symmetry.
apply FiniteDim.BO.
intuition.
rewrite H.
apply sum_n_m_ext_loc.
intros k Hk.
unfold BProd.
simpl.
destruct (le_gt_dec k 0).
assert (HO : (k = O)%nat).
intuition.
rewrite HO.
replace (0 - dimE E1)%nat with O by intuition.
replace (Base E2 0) with (@zero E2).
simpl.
repeat (rewrite scal_zero_r); reflexivity.
symmetry.
apply FiniteDim.BO.
destruct (le_gt_dec k (dimE E1)).
exfalso; intuition.
destruct (le_gt_dec k (dimE E1 + dimE E2)).
simpl.
replace (k-0)%nat with k by intuition.
unfold LProd.
destruct (le_gt_dec k (dimE E1)).
unfold LProd.
destruct (dimE E1).
exfalso; intuition.
exfalso; intuition.
reflexivity.
unfold LProd.
destruct (le_gt_dec k (dimE E1)).
exfalso; intuition.
exfalso; intuition.
rewrite sum_n_m_const_zero.
rewrite plus_zero_l.
reflexivity.
intuition.
intuition.
Qed.

Context {E1 E2 : FiniteDim}.

Definition E1xE2_FiniteDim_mixin :=
    FiniteDim.Mixin _ (dimE E1 + dimE E2) (BProd E1 E2 (Base E1) (Base E2))
                          (BPR0 E1 E2 (Base E1) (Base E2)) (Product_c E1 E2).

Canonical E1xE2_FiniteDim :=
  FiniteDim.Pack (E1*E2) (FiniteDim.Class _ _ E1xE2_FiniteDim_mixin) (E1*E2).

End FiniteSpaces.


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

From Undecidability.Shared.Libs.DLW
  Require Import utils.

Set Implicit Arguments.

Set Default Proof Using "Type".

Section recursor.

  Variables (F : nat -> Prop)
            (Ffun : forall n m, F n -> F m -> n = m)
            (HF : ex F -> sig F)
            (G : nat -> nat -> nat -> Prop)
            (Gfun : forall x y n m, G x y n -> G x y m -> n = m)
            (HG : forall x y, ex (G x y) -> sig (G x y)).

  Fixpoint recursor n x :=
    match n with
      | 0   => F x
      | S n => exists y, recursor n y /\ G n y x
      end.

  Fact recursor_fun n x y : recursor n x -> recursor n y -> x = y.
  Proof using Ffun Gfun.
    revert x y; induction n as [ | n IHn ]; simpl; auto.
    intros x y (a & H1 & H2) (b & H3 & H4).
    specialize (IHn _ _ H1 H3); subst b.
    revert H2 H4; apply Gfun.
  Qed.

  Fixpoint recursor_coq n (Hn : ex (recursor n)) : sig (recursor n).
  Proof using Ffun Gfun HF HG.
    destruct n as [ | n ].
    apply HF, Hn.
    refine (match recursor_coq n _ with
        | exist _ xn Hxn => match @HG n xn _ with
          | exist _ xSn HxSn => exist _ xSn _
        end
      end).
    * destruct Hn as (_ & y & ? & _); exists y; auto.
    * destruct Hn as (x & y & H1 & H2).
      exists x; revert H2; eqgoal; do 2 f_equal.
      revert H1 Hxn. eapply recursor_fun.
    * exists xn; auto.
  Defined.

End recursor.


Module M.
  Inductive I : Set := C : nat -> I.
End M.

Module M1 := M.

Goal forall x, M.C x = M1.C 0 -> x = 0 .
  intros x H.
  (*
     injection sur deux constructeurs egaux mais appeles
     par des modules differents
     *)
  injection H.
  tauto.
Qed.

Goal  M.C 0 <> M1.C 1.
  (*
     Discriminate sur deux constructeurs egaux mais appeles
     par des modules differents
     *)
  intro H;discriminate H.
Qed.

Goal forall x,  M.C x = M1.C 0 -> x = 0.
  intros x H.
  (*
     inversion sur deux constructeurs egaux mais appeles
     par des modules differents
     *)
  inversion H. reflexivity.
Qed.


Require Export XR_le_IZR.

Local Open Scope R_scope.

Lemma le_IZR_R1 : forall n:Z, IZR n <= R1 -> (n <= 1)%Z.
Proof.
  intros n h.
  apply le_IZR.
  simpl.
  exact h.
Qed.


Require Import List Omega.

Require Import bigstep.
Require Import datatypes.
Require Import join.

Fixpoint shift (T:Spec) (n:nat) {struct T}: Spec :=
         match T with | nil => nil
                      | (cons A T') =>
         match A with (p, a, r, x) =>
                      (cons (n+p, a, n+r, x) (shift T' n))
         end end.

Lemma app_shift: forall M i n L,
      In i (proj_target (app (shift M n) L)) ->
      i >= n \/ In i (proj_target L).
induction M; intros.

simpl in H. tauto.

destruct a. destruct p. destruct p.
simpl in H. inversion_clear H.
rewrite <- H0. left. omega.
apply IHM. assumption.
Qed.

Lemma shift_stop: forall T s p,
      is_value T s p ->
      forall n, is_value (shift T n) s (n+p).
induction T; intros.

unfold is_value. simpl. reflexivity.

destruct a. destruct p0. destruct p0. simpl.
unfold is_value in IHT, H |-*. simpl in H |-*.
elim (Nat.eq_dec p s1); intro.
elim (eq_sym_dec (read s) s2); intro.

rewrite a, a0 in H.
rewrite eq_state in H. rewrite eq_sym in H. inversion H.

rewrite a in H |- *.
rewrite eq_state in H |- *. rewrite neq_sym in H |- *.
apply IHT. assumption. auto. auto.

rewrite neq_state in H |- *.
apply IHT. assumption. assumption.
unfold not; intro. unfold not in b; apply b.
apply plus_reg_l with n. assumption.
Qed.

Lemma shift_move: forall T s p i x,
      tr T p s = Some (i, x) ->
      forall n, tr (shift T n) (n+p) s = Some (n+i, x).
induction T; intros.

simpl in H. inversion H.

destruct a. destruct p0. destruct p0.
simpl in H |-*.
elim (Nat.eq_dec p s1); intro.
elim (eq_sym_dec s s2); intro.

rewrite a, a0 in H |-*.
rewrite eq_state in H |-*. rewrite eq_sym in H |-*.
inversion_clear H. reflexivity.

rewrite a in H |- *.
rewrite eq_state in H |- *. rewrite neq_sym in H |- *.
apply IHT. assumption. auto. auto.

rewrite neq_state in H |- *.
apply IHT. assumption. assumption.
unfold not; intro. unfold not in b; apply b.
apply plus_reg_l with n. assumption.
Qed.

(*************** Convergence ***************)

Lemma shift_preserves_stop: forall T s p t q,
      bf T s p t q ->
      forall n, bf (shift T n) s (n+p) t (n+q).
induction 1; intros.

apply bfH.
apply shift_stop. assumption.

apply bfR with (n+i).
apply shift_move. assumption.
apply IHbf.

apply bfL with (n+i).
apply shift_move. assumption.
apply IHbf.

apply bfW with (n+i) a.
apply shift_move. assumption.
apply IHbf.
Qed.

(*************** Divergence ***************)

Lemma shift_preserves_loop: forall T s p,
      bi T s p ->
      forall n, bi (shift T n) s (n+p).
cofix co_hp; intros.
inversion_clear H.

apply biR with (n+q).
apply shift_move. assumption.
apply co_hp. assumption.

apply biL with (n+q).
apply shift_move. assumption.
apply co_hp. assumption.

apply biW with (n+q) a.
apply shift_move. assumption.
apply co_hp. assumption.
Qed.