(* (c) Copyright 2006-2016 Microsoft Corporation and Inria.                  *)
(* Distributed under the terms of CeCILL-B.                                  *)
From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat div seq.
From mathcomp Require Import choice tuple bigop ssralg poly polydiv.
From mathcomp Require Import generic_quotient.

(* This file builds the field of fraction of any integral domain. *)
(* The main result of this file is the existence of the field *)
(* and of the tofrac function which is a injective ring morphism from R *)
(* to its fraction field {fraction R} *)

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

Import GRing.Theory.
Local Open Scope ring_scope.
Local Open Scope quotient_scope.

Reserved Notation "{ 'ratio' T }" (at level 0, format "{ 'ratio'  T }").
Reserved Notation "{ 'fraction' T }" (at level 0, format "{ 'fraction'  T }").
Reserved Notation "x %:F" (at level 2, format "x %:F").

Section FracDomain.
Variable R : ringType.

(* ratios are pairs of R, such that the second member is nonzero *)
Inductive ratio := mkRatio { frac :> R * R; _ : frac.2 != 0 }.
Definition ratio_of of phant R := ratio.
Local Notation "{ 'ratio' T }" := (ratio_of (Phant T)).

Canonical ratio_subType := Eval hnf in [subType for frac].
Canonical ratio_of_subType := Eval hnf in [subType of {ratio R}].
Definition ratio_EqMixin := [eqMixin of ratio by <:].
Canonical ratio_eqType := EqType ratio ratio_EqMixin.
Canonical ratio_of_eqType := Eval hnf in [eqType of {ratio R}].
Definition ratio_ChoiceMixin := [choiceMixin of ratio by <:].
Canonical ratio_choiceType := ChoiceType ratio ratio_ChoiceMixin.
Canonical ratio_of_choiceType := Eval hnf in [choiceType of {ratio R}].

Lemma denom_ratioP : forall f : ratio, f.2 != 0. Proof. by case. Qed.

Definition ratio0 := (@mkRatio (0, 1) (oner_neq0 _)).
Definition Ratio x y : {ratio R} := insubd ratio0 (x, y).

Lemma numer_Ratio x y : y != 0 -> (Ratio x y).1 = x.
Proof. by move=> ny0; rewrite /Ratio /insubd insubT. Qed.

Lemma denom_Ratio x y : y != 0 -> (Ratio x y).2 = y.
Proof. by move=> ny0; rewrite /Ratio /insubd insubT. Qed.

Definition numden_Ratio := (numer_Ratio, denom_Ratio).

Variant Ratio_spec (n d : R) : {ratio R} -> R -> R -> Type :=
  | RatioNull of d = 0 : Ratio_spec n d ratio0 n 0
  | RatioNonNull (d_neq0 : d != 0) :
    Ratio_spec n d (@mkRatio (n, d) d_neq0) n d.

Lemma RatioP n d : Ratio_spec n d (Ratio n d) n d.
Proof.
rewrite /Ratio /insubd; case: insubP=> /= [x /= d_neq0 hx|].
  have ->: x = @mkRatio (n, d) d_neq0 by apply: val_inj.
  by constructor.
by rewrite negbK=> /eqP hx; rewrite {2}hx; constructor.
Qed.

Lemma Ratio0 x : Ratio x 0 = ratio0.
Proof. by rewrite /Ratio /insubd; case: insubP; rewrite //= eqxx. Qed.

End FracDomain.

Notation "{ 'ratio' T }" := (ratio_of (Phant T)).
Identity Coercion type_fracdomain_of : ratio_of >-> ratio.

Notation "'\n_' x"  := (frac x).1
  (at level 8, x at level 2, format "'\n_' x").
Notation "'\d_' x"  := (frac x).2
  (at level 8, x at level 2, format "'\d_' x").

Module FracField.
Section FracField.

Variable R : idomainType.

Local Notation frac := (R * R).
Local Notation dom := (ratio R).
Local Notation domP := denom_ratioP.

Implicit Types x y z : dom.

(* We define a relation in ratios *)
Local Notation equivf_notation x y := (\n_x * \d_y == \d_x * \n_y).
Definition equivf x y := equivf_notation x y.

Lemma equivfE x y : equivf x y = equivf_notation x y.
Proof. by []. Qed.

Lemma equivf_refl : reflexive equivf.
Proof. by move=> x; rewrite /equivf mulrC. Qed.

Lemma equivf_sym : symmetric equivf.
Proof. by move=> x y; rewrite /equivf eq_sym; congr (_==_); rewrite mulrC. Qed.

Lemma equivf_trans : transitive equivf.
Proof.
move=> [x Px] [y Py] [z Pz]; rewrite /equivf /= mulrC => /eqP xy /eqP yz.
by rewrite -(inj_eq (mulfI Px)) mulrA xy -mulrA yz mulrCA.
Qed.

(* we show that equivf is an equivalence *)
Canonical equivf_equiv := EquivRel equivf equivf_refl equivf_sym equivf_trans.

Definition type := {eq_quot equivf}.
Definition type_of of phant R := type.
Notation "{ 'fraction' T }" := (type_of (Phant T)).

(* we recover some structure for the quotient *)
Canonical frac_quotType := [quotType of type].
Canonical frac_eqType := [eqType of type].
Canonical frac_choiceType := [choiceType of type].
Canonical frac_eqQuotType := [eqQuotType equivf of type].

Canonical frac_of_quotType := [quotType of {fraction R}].
Canonical frac_of_eqType := [eqType of {fraction R}].
Canonical frac_of_choiceType := [choiceType of {fraction R}].
Canonical frac_of_eqQuotType := [eqQuotType equivf of {fraction R}].

(* we explain what was the equivalence on the quotient *)
Lemma equivf_def (x y : ratio R) : x == y %[mod type]
                                    = (\n_x * \d_y == \d_x * \n_y).
Proof. by rewrite eqmodE. Qed.

Lemma equivf_r x : \n_x * \d_(repr (\pi_type x)) = \d_x * \n_(repr (\pi_type x)).
Proof. by apply/eqP; rewrite -equivf_def reprK. Qed.

Lemma equivf_l x : \n_(repr (\pi_type x)) * \d_x = \d_(repr (\pi_type x)) * \n_x.
Proof. by apply/eqP; rewrite -equivf_def reprK. Qed.

Lemma numer0 x : (\n_x == 0) = (x == (ratio0 R) %[mod_eq equivf]).
Proof. by rewrite eqmodE /= !equivfE // mulr1 mulr0. Qed.

Lemma Ratio_numden : forall x, Ratio \n_x \d_x = x.
Proof.
case=> [[n d] /= nd]; rewrite /Ratio /insubd; apply: val_inj=> /=.
by case: insubP=> //=; rewrite nd.
Qed.

Definition tofrac := lift_embed {fraction R} (fun x : R => Ratio x 1).
Canonical tofrac_pi_morph := PiEmbed tofrac.

Notation "x %:F"  := (@tofrac x).

Implicit Types a b c : type.

Definition addf x y : dom := Ratio (\n_x * \d_y + \n_y * \d_x) (\d_x * \d_y).
Definition add := lift_op2 {fraction R} addf.

Lemma pi_add : {morph \pi : x y / addf x y >-> add x y}.
Proof.
move=> x y; unlock add; apply/eqmodP; rewrite /= equivfE.
rewrite /addf /= !numden_Ratio ?mulf_neq0 ?domP //.
rewrite mulrDr mulrDl eq_sym; apply/eqP.
rewrite !mulrA ![_ * \n__]mulrC !mulrA equivf_l.
congr (_ + _); first by rewrite -mulrA mulrCA !mulrA.
rewrite -!mulrA [X in _ * X]mulrCA !mulrA equivf_l.
by rewrite mulrC !mulrA -mulrA mulrC mulrA.
Qed.
Canonical pi_add_morph := PiMorph2 pi_add.

Definition oppf x : dom := Ratio (- \n_x) \d_x.
Definition opp := lift_op1 {fraction R} oppf.
Lemma pi_opp : {morph \pi : x / oppf x >-> opp x}.
Proof.
move=> x; unlock opp; apply/eqmodP; rewrite /= /equivf /oppf /=.
by rewrite !numden_Ratio ?(domP,mulf_neq0) // mulNr mulrN -equivf_r.
Qed.
Canonical pi_opp_morph := PiMorph1 pi_opp.

Definition mulf x y : dom := Ratio (\n_x * \n_y) (\d_x * \d_y).
Definition mul := lift_op2 {fraction R} mulf.

Lemma pi_mul : {morph \pi : x y / mulf x y >-> mul x y}.
Proof.
move=> x y; unlock mul; apply/eqmodP=> /=.
rewrite equivfE /= /addf /= !numden_Ratio ?mulf_neq0 ?domP //.
rewrite mulrAC !mulrA -mulrA equivf_r -equivf_l.
by rewrite mulrA ![_ * \d_y]mulrC !mulrA.
Qed.
Canonical pi_mul_morph := PiMorph2 pi_mul.

Definition invf x : dom := Ratio \d_x \n_x.
Definition inv := lift_op1 {fraction R} invf.

Lemma pi_inv : {morph \pi : x / invf x >-> inv x}.
Proof.
move=> x; unlock inv; apply/eqmodP=> /=; rewrite equivfE /invf eq_sym.
do 2?case: RatioP=> /= [/eqP|];
  rewrite ?mul0r ?mul1r -?equivf_def ?numer0 ?reprK //.
  by move=> hx /eqP hx'; rewrite hx' eqxx in hx.
by move=> /eqP ->; rewrite eqxx.
Qed.
Canonical pi_inv_morph := PiMorph1 pi_inv.

Lemma addA : associative add.
Proof.
elim/quotW=> x; elim/quotW=> y; elim/quotW=> z; rewrite !piE.
rewrite /addf /= !numden_Ratio ?mulf_neq0 ?domP // !mulrDl !mulrA !addrA.
by congr (\pi (Ratio (_ + _ + _) _)); rewrite mulrAC.
Qed.

Lemma addC : commutative add.
Proof.
by elim/quotW=> x; elim/quotW=> y; rewrite !piE /addf addrC [\d__ * _]mulrC.
Qed.

Lemma add0_l : left_id 0%:F add.
Proof.
elim/quotW=> x; rewrite !piE /addf !numden_Ratio ?oner_eq0 //.
by rewrite mul0r mul1r mulr1 add0r Ratio_numden.
Qed.

Lemma addN_l : left_inverse 0%:F opp add.
Proof.
elim/quotW=> x; apply/eqP; rewrite piE /equivf.
rewrite /addf /oppf !numden_Ratio ?(oner_eq0, mulf_neq0, domP) //.
by rewrite mulr1 mulr0 mulNr addNr.
Qed.

(* fracions form an abelian group *)
Definition frac_zmodMixin :=  ZmodMixin addA addC add0_l addN_l.
Canonical frac_zmodType := Eval hnf in ZmodType type frac_zmodMixin.

Lemma mulA : associative mul.
Proof.
elim/quotW=> x; elim/quotW=> y; elim/quotW=> z; rewrite !piE.
by rewrite /mulf !numden_Ratio ?mulf_neq0 ?domP // !mulrA.
Qed.

Lemma mulC : commutative mul.
Proof.
elim/quotW=> x; elim/quotW=> y; rewrite !piE /mulf.
by rewrite [_ * (\d_x)]mulrC [_ * (\n_x)]mulrC.
Qed.

Lemma mul1_l : left_id 1%:F mul.
Proof.
elim/quotW=> x; rewrite !piE /mulf.
by rewrite !numden_Ratio ?oner_eq0 // !mul1r Ratio_numden.
Qed.

Lemma mul_addl : left_distributive mul add.
Proof.
elim/quotW=> x; elim/quotW=> y; elim/quotW=> z; apply/eqP.
rewrite !piE /equivf /mulf /addf !numden_Ratio ?mulf_neq0 ?domP //; apply/eqP.
rewrite !(mulrDr, mulrDl) !mulrA; congr (_ * _ + _ * _).
  rewrite ![_ * \n_z]mulrC -!mulrA; congr (_ * _).
  rewrite ![\d_y * _]mulrC !mulrA; congr (_ * _ * _).
  by rewrite [X in _ = X]mulrC mulrA.
rewrite ![_ * \n_z]mulrC -!mulrA; congr (_ * _).
rewrite ![\d_x * _]mulrC !mulrA; congr (_ * _ * _).
by rewrite -mulrA mulrC [X in X * _] mulrC.
Qed.

Lemma nonzero1 : 1%:F != 0%:F :> type.
Proof. by rewrite piE equivfE !numden_Ratio ?mul1r ?oner_eq0. Qed.

(* fracions form a commutative ring *)
Definition frac_comRingMixin := ComRingMixin mulA mulC mul1_l mul_addl nonzero1.
Canonical frac_ringType := Eval hnf in RingType type frac_comRingMixin.
Canonical frac_comRingType := Eval hnf in ComRingType type mulC.

Lemma mulV_l : forall a, a != 0%:F -> mul (inv a) a = 1%:F.
Proof.
elim/quotW=> x /=; rewrite !piE.
rewrite /equivf !numden_Ratio ?oner_eq0 // mulr1 mulr0=> nx0.
apply/eqmodP; rewrite /= equivfE.
by rewrite !numden_Ratio ?(oner_eq0, mulf_neq0, domP) // !mulr1 mulrC.
Qed.

Lemma inv0 : inv 0%:F = 0%:F.
Proof.
rewrite !piE /invf !numden_Ratio ?oner_eq0 // /Ratio /insubd.
do 2?case: insubP; rewrite //= ?eqxx ?oner_eq0 // => u _ hu _.
by congr \pi; apply: val_inj; rewrite /= hu.
Qed.

(* fractions form a ring with explicit unit *)
Definition RatFieldUnitMixin := FieldUnitMixin mulV_l inv0.
Canonical frac_unitRingType := Eval hnf in UnitRingType type RatFieldUnitMixin.
Canonical frac_comUnitRingType := [comUnitRingType of type].

Lemma field_axiom : GRing.Field.mixin_of frac_unitRingType.
Proof. exact. Qed.

(* fractions form a field *)
Definition RatFieldIdomainMixin := (FieldIdomainMixin field_axiom).
Canonical frac_idomainType :=
  Eval hnf in IdomainType type (FieldIdomainMixin field_axiom).
Canonical frac_fieldType := FieldType type field_axiom.

End FracField.
End FracField.

Notation "{ 'fraction' T }" := (FracField.type_of (Phant T)).
Notation equivf := (@FracField.equivf _).
Hint Resolve denom_ratioP : core.

Section Canonicals.

Variable R : idomainType.

(* reexporting the structures *)
Canonical FracField.frac_quotType.
Canonical FracField.frac_eqType.
Canonical FracField.frac_choiceType.
Canonical FracField.frac_zmodType.
Canonical FracField.frac_ringType.
Canonical FracField.frac_comRingType.
Canonical FracField.frac_unitRingType.
Canonical FracField.frac_comUnitRingType.
Canonical FracField.frac_idomainType.
Canonical FracField.frac_fieldType.
Canonical FracField.tofrac_pi_morph.
Canonical frac_of_quotType := Eval hnf in [quotType of {fraction R}].
Canonical frac_of_eqType := Eval hnf  in [eqType of {fraction R}].
Canonical frac_of_choiceType := Eval hnf in [choiceType of {fraction R}].
Canonical frac_of_zmodType := Eval hnf in [zmodType of {fraction R}].
Canonical frac_of_ringType := Eval hnf in [ringType of {fraction R}].
Canonical frac_of_comRingType := Eval hnf in [comRingType of {fraction R}].
Canonical frac_of_unitRingType := Eval hnf in [unitRingType of {fraction R}].
Canonical frac_of_comUnitRingType := Eval hnf in [comUnitRingType of {fraction R}].
Canonical frac_of_idomainType := Eval hnf in [idomainType of {fraction R}].
Canonical frac_of_fieldType := Eval hnf in [fieldType of {fraction R}].

End Canonicals.

Section FracFieldTheory.

Import FracField.

Variable R : idomainType.

Lemma Ratio_numden (x : {ratio R}) : Ratio \n_x \d_x = x.
Proof. exact: FracField.Ratio_numden. Qed.

(* exporting the embeding from R to {fraction R} *)
Local Notation tofrac := (@FracField.tofrac R).
Local Notation "x %:F" := (tofrac x).

Lemma tofrac_is_additive: additive tofrac.
Proof.
move=> p q /=; unlock tofrac.
rewrite -[X in _ = _ + X]pi_opp -[X in _ = X]pi_add.
by rewrite /addf /oppf /= !numden_Ratio ?(oner_neq0, mul1r, mulr1).
Qed.

Canonical tofrac_additive := Additive tofrac_is_additive.

Lemma tofrac_is_multiplicative: multiplicative tofrac.
Proof.
split=> [p q|//]; unlock tofrac; rewrite -[X in _ = X]pi_mul.
by rewrite /mulf /= !numden_Ratio ?(oner_neq0, mul1r, mulr1).
Qed.

Canonical tofrac_rmorphism := AddRMorphism tofrac_is_multiplicative.

(* tests *)
Lemma tofrac0 : 0%:F = 0. Proof. exact: rmorph0. Qed.
Lemma tofracN : {morph tofrac: x / - x}. Proof. exact: rmorphN. Qed.
Lemma tofracD : {morph tofrac: x y / x + y}. Proof. exact: rmorphD. Qed.
Lemma tofracB : {morph tofrac: x y / x - y}. Proof. exact: rmorphB. Qed.
Lemma tofracMn n : {morph tofrac: x / x *+ n}. Proof. exact: rmorphMn. Qed.
Lemma tofracMNn n : {morph tofrac: x / x *- n}. Proof. exact: rmorphMNn. Qed.
Lemma tofrac1 : 1%:F = 1. Proof. exact: rmorph1. Qed.
Lemma tofracM : {morph tofrac: x y  / x * y}. Proof. exact: rmorphM. Qed.
Lemma tofracX n : {morph tofrac: x / x ^+ n}. Proof. exact: rmorphX. Qed.

Lemma tofrac_eq (p q : R): (p%:F == q%:F) = (p == q).
Proof.
apply/eqP/eqP=> [|->//]; unlock tofrac=> /eqmodP /eqP /=.
by rewrite !numden_Ratio ?(oner_eq0, mul1r, mulr1).
Qed.

Lemma tofrac_eq0 (p : R): (p%:F == 0) = (p == 0).
Proof. by rewrite tofrac_eq. Qed.
End FracFieldTheory.


(*
(precise)administrator@localhost:~$ coqtop
Welcome to Coq 8.3pl4 (April 2012)

Coq < Section Practice_02.

Coq < Goal forall a b c:Prop, ((a \/ b) /\ (b \/ c)) -> (a \/ b \/ c).
1 subgoal

  ============================
   forall a b c : Prop, (a \/ b) /\ (b \/ c) -> a \/ b \/ c

Unnamed_thm < intros.
1 subgoal

  a : Prop
  b : Prop
  c : Prop
  H : (a \/ b) /\ (b \/ c)
  ============================
   a \/ b \/ c

Unnamed_thm < elim H.
1 subgoal

  a : Prop
  b : Prop
  c : Prop
  H : (a \/ b) /\ (b \/ c)
  ============================
   a \/ b -> b \/ c -> a \/ b \/ c

Unnamed_thm < intro.
1 subgoal

  a : Prop
  b : Prop
  c : Prop
  H : (a \/ b) /\ (b \/ c)
  H0 : a \/ b
  ============================
   b \/ c -> a \/ b \/ c

Unnamed_thm < intro.
1 subgoal

  a : Prop
  b : Prop
  c : Prop
  H : (a \/ b) /\ (b \/ c)
  H0 : a \/ b
  H1 : b \/ c
  ============================
   a \/ b \/ c

Unnamed_thm < firstorder.
Proof completed.

Unnamed_thm < Qed.
intros.
elim H.
intro.
intro.
firstorder  .

Unnamed_thm is defined

Coq <
*)

Section Practice_02.
Goal forall a b c:Prop, ((a \/ b) /\ (b \/ c)) -> (a \/ b \/ c).
intros.
elim H.
intro.
intro.
 firstorder.
 Qed.


(** To put in a chapter about inductive types *)

(** Multiplication Schemes (CPS) *)

Require Import bin_nums tutorial_type_classes.SRC.Monoid Omega List.
Generalizable Variables op one.
Inductive Computation {A:Type} : Type :=
| Return (a : A)
| Mult (x y : A) (k : A -> Computation).

Notation "z '<---'  x 'times' y ';' e2 " := (Mult x y  (fun z => e2))
                                              (right associativity, at level 60).

Definition chain := forall (A:Type), A -> @Computation A.

(*
Axiom suggestion so as to get a hand on complexity properties.

Inductive similar {A B:Type}: @Computation A -> @Computation B -> Prop :=
| S_return: forall (a:A) (b:B), similar (Return a) (Return b)
| Mult_return: forall kA kB a1 a2 b1 b2, (forall a b, similar (kA a) (kB b)) ->
                                         similar (Mult a1 a2 kA) (Mult b1 b2 kB).

Axiom free_chain:
  forall (c:chain) A B a b,
    similar (c A a) (c B b).
 *)

Inductive equiv {A B:Type}: list (A*B) -> @Computation A -> @Computation B -> Prop :=
| Ereturn: forall (x:A) (y:B) (l:list (A*B)),
    In (x,y) l -> equiv l (Return x) (Return y)
| Emult: forall (x1 y1:A) (x2 y2:B) (l:list (A*B))
                (kA:A-> @Computation A) (kB:B -> @Computation B),
    In (x1,x2) l -> In (y1,y2) l ->
    (forall (x':A) (y':B),equiv  ((x',y')::l) (kA x') (kB y')) ->
    equiv l (Mult x1 y1 kA) (Mult x2 y2 kB).

(*Inductive well_formed {A:Type}: @Computation A -> @Computation A -> Prop:=
| Wf_return: forall (x:A), equiv (Return x) (Return x)
| Wf_mult: forall (x1 y1:A)(kA kA': A->@Computation A),
    (forall a:A, well_formed (kA a) (kA' a))
      well_formed (Mult x1 y1 kA) (Mult x1 y1 kA').*)

Axiom parametric_equiv: forall c:chain, forall A B (a:A) (b:B),
      equiv ((a,b)::nil) (c A a) (c B b).

Fixpoint execute {A:Type} `{M:Monoid A op one}   (c : @Computation A) : A :=
  match c with Return x => x
          | Mult x y k => execute (k (op x  y))
  end.

Definition apply_chain (c: chain){A}`{M:Monoid A op one} (a:A) :=
  execute (c A a).

(** number of mutiplications *)

Fixpoint comp_complexity   (c : @Computation unit) : nat :=
  match c with
  | Mult _ _ k => S (comp_complexity (k tt))
  | _ => 0%nat
  end.

Definition complexity (c: chain) := comp_complexity (c _ tt).

Require Import ArithRing.
Instance NatPlus : Monoid  plus 0%nat.
split; intros; ring.
Qed.

Definition the_exponent (c:chain) :=
  apply_chain c (M:= NatPlus) 1%nat.

(** the exponent associated to a chain *)

(** computation of x ^ 3 *)

Example  C3 : chain :=
  fun {A:Type} (a : A) =>
    a2 <--- a times a ;
    a3 <--- a2 times a ;
    Return a3.

Compute complexity C3.

(** computation of x ^ 7 *)

Example C7 : chain  :=
  fun {A} (x:A) =>
    x2 <--- x times x ;
    x3 <--- x2 times x ;
    x6 <--- x3 times x3 ;
    x7 <--- x6 times x ;
    Return x7.

Remark C7_correct : forall A `{M: Monoid A op one} (x:A),
    apply_chain C7 x = op x (op x (op x (op x (op x (op x x))))).
Proof.
  intros ; cbn.   now repeat rewrite  <- dot_assoc.
Qed.

(** Scheme for computing a x ^ p  (p positive)
 *)

Fixpoint axp_scheme  p {A:Type} : A -> A -> @Computation A :=
  match p with
  | xH =>  (fun a x => y <--- a  times x ; Return y)
  | xO q => (fun a x => x2 <--- x times  x ; axp_scheme q a x2)
  | xI q => (fun a x => ax <--- a times x ;
             x2 <--- x times x ;
             axp_scheme q ax x2)
  end.

Definition Pos_pow_chain (p:positive) :=
  match p with xH => fun (A:Type) (x:A) => Return x
          | _ => fun (A:Type) (x:A) => axp_scheme (Pos.pred p) x x
  end.

Definition C11 :=  Pos_pow_chain 11%positive.

Compute apply_chain (M:=ZMult) C11 2%Z.

(*
 = fun (A : Type) (x0 : A) =>
       x1 <--- x0 times x0; (* x^2 *)
       x2 <--- x0 times x1; (* x^3 *)
       x3 <--- x1 times x1; (* x ^ 4 *)
       x4 <--- x3 times x3; (* x ^8 *)
       x5 <--- x2 times x4; Return x5
 *)

Definition C87 : chain := fun A (x:A) =>
                            x2 <--- x times x ;
                            x3 <--- x2 times x ;
                            x6 <--- x3 times x3 ;
                            x7 <--- x6 times x ;
                            x10 <--- x7 times x3 ;
                            x20 <--- x10 times x10 ;
                            x40 <--- x20 times x20 ;
                            x80 <--- x40 times x40 ;
                            x87 <--- x80 times x7 ;
                            Return x87.

Compute the_exponent C87.
Compute the_exponent C11.

Definition chain_correct (c : chain) (p:positive) :=
  forall A `(M:Monoid A op one) (a:A), apply_chain c  a  =
                                       power a  (Pos.to_nat p).

Definition correct_chain_generator (f : positive  ->chain ) :=
  forall p, chain_correct (f p) p.

(** JUSQU'ICI TOUT VA BIEN *)

(** Correctness of the binary method *)

Lemma L : forall p A `(M:Monoid A op one) (a:A) x,
    execute (axp_scheme p a x) = op a (power x (Pos.to_nat p)).
Proof.
  induction p.
  -   intros a x; simpl axp_scheme.
      replace (Pos.to_nat p~1) with (S (Pos.to_nat p + Pos.to_nat p)%nat).
      cbn.
      intros;rewrite IHp; rewrite power_of_square, <- power_x_plus.
      now rewrite dot_assoc.
      rewrite  Pnat.Pos2Nat.inj_xI;omega.
  - intros a x; simpl  axp_scheme.
    replace (Pos.to_nat p~0 ) with (Pos.to_nat p + Pos.to_nat p)%nat.
    intros; simpl;  rewrite IHp, power_of_square,  <- power_x_plus;   auto.
    rewrite  Pnat.Pos2Nat.inj_xO;omega.
  - simpl; intros; now rewrite  (one_right x).
Qed.

Lemma binary_correct : correct_chain_generator Pos_pow_chain.
Proof.
  intros n x.  intros; unfold apply_chain.
  destruct n.
  simpl.
  rewrite  L.
  f_equal.
  rewrite <- (sqr  (A:=x) M).
  rewrite power_of_power.
  f_equal.
  rewrite (mult_comm  (Pos.to_nat n) 2)%nat.
  replace (2* Pos.to_nat n)%nat with (Pos.to_nat n + Pos.to_nat n)%nat.
  SearchAbout Pos.iter_op.
  now rewrite ZL6.
  ring.
  - simpl.
    rewrite  L.
    rewrite Pos2Nat.inj_xO.
    SearchAbout Pos.pred_double.
    SearchAbout power.
    replace (op a (power a (Pos.to_nat (Pos.pred_double n)))) with
    (power a (S (Pos.to_nat (Pos.pred_double n)))).
    SearchRewrite (S (Pos.to_nat _)).
    f_equal.
    rewrite <- Pos2Nat.inj_succ.
    SearchRewrite (Pos.succ (Pos.pred_double _)).
    rewrite Pos.succ_pred_double.
    SearchRewrite (Pos.to_nat (xO _)).
    now rewrite Pos2Nat.inj_xO.
    now  simpl.
  - simpl.
    now rewrite one_right.
Qed.

(** We can define "optimal" algorithms for generating computation schemes *)

Definition optimal (f : positive -> chain) :=
  forall (g : positive  -> chain),
    correct_chain_generator  g ->
    forall p, (complexity (f p) <= complexity (g p))%nat.

(** In the following section, we show that the binary method is not optimal *)

Section bin_pow_scheme_not_optimal.

  Hypothesis binary_opt : optimal Pos_pow_chain.

  (** First, let's have a look at the computation scheme generated for, let's say, 87  *)
  Compute Pos_pow_chain 87.

  (*   The variables output by Coq have been renamed by hand
      (x_i associated with x ^ i)

 =
fun (A : Type) (x : x) =>
       x_2 <--- x times x;
       x_3 <--- x times x_2;
       x_4 <--- x_2 times x_2;
       x_7 <--- x_3 times x_4;
       x_8 <--- x_4 times x_4;
       x_16 <--- x_8 times x_8;
       x_23 <--- x_7 times x_16;
       x_32 <--- x_16 times x_16;
       x_64 <--- x_32 times x_32;
       x_87 <--- x_23 times x_64;
       Return x_87
     : forall A : Type, A -> Computation
   *)

  Compute complexity (Pos_pow_chain 87 ).

  Compute complexity C87.

  (** Notice that C87 has been automatically generated with the
   "euclidean addition chains" method

http://www-igm.univ-mlv.fr/~berstel/Articles/1994AdditionChains.pdf

https://eudml.org/doc/92517

   *)

  Lemma L87 : chain_correct C87 87.
  Proof.
    red.
    intros.
    compute.
    now repeat (rewrite dot_assoc || rewrite (one_right (Monoid :=M))).
  Qed.

  (** we slightly modify the binary scheme
   *)

  Definition h (p:positive) := if Pos.eqb p 87%positive
                               then C87
                               else Pos_pow_chain p.

  Lemma h_correct : correct_chain_generator h.
  Proof.
    intro p; case_eq (Pos.eqb p 87).
    -   intros H a;  unfold h;   rewrite H.
        rewrite   Pos.eqb_eq in H;  subst p; apply L87.
    -   intros ; unfold h;   rewrite H;   apply binary_correct.
  Qed.

  Lemma absurd : False.
  Proof.
    generalize (binary_opt h  h_correct 87%positive).
    compute;
      intros. omega.
  Qed.

End bin_pow_scheme_not_optimal.

(*** The computation scheme associated to naive power *)

(** In fact, the computation scheme for the naive algorithm is just
    the iteration of the following function *)

(*

Definition transform (f : (A -> Computation) -> (A -> Computation))
                     (k: A -> Computation) (x: A) :=
                     f (fun y:A => z <--- y times x ; k z) x.

Definition naive_power_scheme (i:N) :=
match i with 0 => fun x => Return one
          | Npos q => Pos.iter  transform (fun k => k) (Pos.pred q)
                                 Return
end.
 *)

Definition transform{A:Type}
           (f: (A -> @Computation A) -> (A -> @Computation A))
           (c : (A ->  @Computation A)) :  A -> @Computation A
  := fun (x:A) =>
       f (fun (y:A) => z <--- y times x ; c z) x.

Definition naive_power_scheme (i:positive) : chain :=
  fun (A: Type) =>
    Pos.iter  (transform (A:=A)) (fun k => k) (Pos.pred i)
              Return
.

Compute naive_power_scheme 6.
Compute the_exponent (naive_power_scheme 6).


MacBook-Air:~ billw$ /Applications/CoqIDE_8.4pl5.app/Contents/Resources/bin/coqtop
Welcome to Coq 8.4pl5 (October 2014)

Coq < Section Examples.

Coq < Require Import Classical.

Coq < Variables P Q R J K M : Prop.
P is assumed
Q is assumed
R is assumed
J is assumed
K is assumed
M is assumed

Coq < Goal ((P \/ ~Q) /\ (Q \/ ~R) /\ (R <-> ( J \/ K)) /\ (K <-> M) /\ (M \/ P)) -> P.
1 subgoal

  P : Prop
  Q : Prop
  R : Prop
  J : Prop
  K : Prop
  M : Prop
  ============================
   (P \/ ~ Q) /\ (Q \/ ~ R) /\ (R <-> J \/ K) /\ (K <-> M) /\ (M \/ P) -> P

Unnamed_thm < intros.
1 subgoal

  P : Prop
  Q : Prop
  R : Prop
  J : Prop
  K : Prop
  M : Prop
  H : (P \/ ~ Q) /\ (Q \/ ~ R) /\ (R <-> J \/ K) /\ (K <-> M) /\ (M \/ P)
  ============================
   P

Unnamed_thm < elim H.
1 subgoal

  P : Prop
  Q : Prop
  R : Prop
  J : Prop
  K : Prop
  M : Prop
  H : (P \/ ~ Q) /\ (Q \/ ~ R) /\ (R <-> J \/ K) /\ (K <-> M) /\ (M \/ P)
  ============================
   P \/ ~ Q -> (Q \/ ~ R) /\ (R <-> J \/ K) /\ (K <-> M) /\ (M \/ P) -> P

Unnamed_thm < intro.
1 subgoal

  P : Prop
  Q : Prop
  R : Prop
  J : Prop
  K : Prop
  M : Prop
  H : (P \/ ~ Q) /\ (Q \/ ~ R) /\ (R <-> J \/ K) /\ (K <-> M) /\ (M \/ P)
  H0 : P \/ ~ Q
  ============================
   (Q \/ ~ R) /\ (R <-> J \/ K) /\ (K <-> M) /\ (M \/ P) -> P

Unnamed_thm < intro.
1 subgoal

  P : Prop
  Q : Prop
  R : Prop
  J : Prop
  K : Prop
  M : Prop
  H : (P \/ ~ Q) /\ (Q \/ ~ R) /\ (R <-> J \/ K) /\ (K <-> M) /\ (M \/ P)
  H0 : P \/ ~ Q
  H1 : (Q \/ ~ R) /\ (R <-> J \/ K) /\ (K <-> M) /\ (M \/ P)
  ============================
   P

Unnamed_thm < destruct H1.
1 subgoal

  P : Prop
  Q : Prop
  R : Prop
  J : Prop
  K : Prop
  M : Prop
  H : (P \/ ~ Q) /\ (Q \/ ~ R) /\ (R <-> J \/ K) /\ (K <-> M) /\ (M \/ P)
  H0 : P \/ ~ Q
  H1 : Q \/ ~ R
  H2 : (R <-> J \/ K) /\ (K <-> M) /\ (M \/ P)
  ============================
   P

Unnamed_thm < firstorder.
No more subgoals.

Unnamed_thm < Qed.
intros.
elim H.
intro.
intro.
destruct H1.
firstorder .

Unnamed_thm is defined

Coq <


Set Implicit Arguments.
Require Import List.
(*Require Import HoTT.*)

(** * The Functor Type Class *)

Notation "f ∘ g" := (fun x => f (g x)) (at level 40, left associativity).

Class Functor (f : Type -> Type) : Type :=
{ fmap         : forall {A B}, (A -> B) -> f A -> f B }.
Class Functor_Correct (f : Type -> Type) `{F : Functor f} :=
{ fmap_id      : forall A, fmap (fun (x:A)=> x) = (fun x => x);
  fmap_compose : forall A B C (g : A -> B) (f : B -> C),
                 fmap (f ∘ g) = fmap f ∘ fmap g
}.
Class Applicative (f : Type -> Type) `{F : Functor f} : Type :=
{ pure : forall {A}, A -> f A;
  liftA : forall {A B}, f (A -> B) -> f A -> f B
}.
Notation "f <*> a" := (liftA f a) (left associativity, at level 25).

Class Applicative_Correct (f : Type -> Type) `{Applicative f} :=
{ applicative_id : forall A, liftA (pure (fun  (x:A) => x)) = (fun  x => x);
  applicative_composition : forall {A B C} (u : f (B -> C)) (v : f (A -> B)) (w : f A),
    pure (fun  x => fun  y => x ∘ y) <*> u <*> v <*> w = u <*> (v <*> w);
  applicative_homomorphism : forall {A B} (f : A -> B) (x : A),
    pure f <*> pure x = pure (f x);
  applicative_interchange : forall {A B} (u : f (A -> B)) (y : A),
    u <*> pure y = pure (fun x => x y) <*> u
}.

Class Monad (m: Type -> Type) `{M : Applicative m} : Type :=
{ bind: forall {A}, m A -> forall {B}, (A -> m B) -> m B
}.
Definition return_ {m : Type -> Type} `{M : Monad m} {A : Type} : A -> m A := pure.
Notation "a >>= f" := (bind a f) (at level 50, left associativity).

Class Monad_Correct (m : Type -> Type) `{M : Monad m} := {
  bind_right_unit: forall A (a: m A), a = a >>= return_;
  bind_left_unit: forall A (a: A) B (f: A -> m B),
             f a = return_ a >>= f;
  bind_associativity: forall A (ma: m A) B f C (g: B -> m C),
                 bind ma (fun  x=> f x >>= g) = (ma >>= f) >>= g
}.

Arguments Functor f.
Arguments Functor_Correct f [F].
Arguments Applicative f [F].
Arguments Applicative_Correct f [F].
Arguments Monad m [F] [M].
Arguments Monad_Correct m [F] [A] [M] : rename.

Section monadic_functions.
 Variable m : Type -> Type.
 Variable F : Functor m.
 Variable A : Applicative m.
 Variable M : Monad m.

 Definition wbind {A: Type} (ma: m A) {B: Type} (mb: m B) :=
 ma >>= fun  _=>mb.

 Definition liftM {A B: Type} (f: A->B) (ma: m A): m B :=
 ma >>= (fun  a => return_ (f a)).

 Definition join {A: Type} (mma: m (m A)): m A :=
 mma >>= (fun  ma => ma).
End monadic_functions.

Notation "a >> f" := (wbind _ a f) (at level 50, left associativity).
Notation "'do' a ← e ; c" := (e >>= (fun  a => c)) (at level 60, right associativity).

(** * Some classic Monads *)

(** ** The list monad *)

Open Scope list_scope.
Definition list_fmap {A B} (f : A -> B) :=
  fix map (l : list A) : list B :=
  match l with
  | nil => nil
  | a :: t => f a :: map t
  end.
(*
Fixpoint list_fmap {A B} (f : A -> B) (ls : list A) : list B :=
  match ls with
  | nil => nil
  | a :: ls' => f a :: list_fmap f ls'
  end.  *)

Fixpoint concat {A} (xs : list (list A)) : list A :=
  match xs with
  | nil => nil
  | ys :: xs' => ys ++ concat xs'
  end.

Definition list_liftA {A B} (fs : list (A -> B)) (xs : list A) : list B :=
  let g := fun a => list_fmap (fun f => f a) fs
  in
  concat (list_fmap g xs).

Fixpoint list_bind {A} (xs : list A) {B} (f : A -> list B) : list B :=
  match xs with
  | nil => nil
  | a :: xs' => f a ++ list_bind xs' f
  end.

Instance listF : Functor list := { fmap := @list_fmap }.
Instance listA : Applicative list := { pure := fun _ x => x :: nil
                                     ; liftA := @list_liftA }.
Instance listM : Monad list :=
  { bind := @list_bind }.

(** ** The Maybe monad (using option type) *)

Definition option_fmap {A B} (f : A -> B) (x : option A) : option B :=
  match x with
  | None => None
  | Some a => Some (f a)
  end.
Definition option_liftA {A B} (f : option (A -> B)) (x : option A) : option B :=
  match f, x with
  | Some f', Some a => Some (f' a)
  | _, _ => None
  end.
Instance optionF : Functor option := { fmap := @option_fmap}.
Instance optionA : Applicative option := { pure := @Some;
                                           liftA := @option_liftA}.
Instance optionM : Monad option :=
  { bind := fun  A m B f => match m with None => None | Some a => f a end
  }.
Instance optionM_Laws : Monad_Correct option.
Proof. split.
  - destruct a; auto.
  - intros; auto.
  - destruct ma; intros; auto.
Defined.

(* Monad Transformer *)
Class MonadTrans (t : (Type -> Type) -> (Type -> Type)) :=
  { liftT : forall {m} `{Monad m} {A}, m A -> t m A }.

(** Option monad transformer *)
Definition optionT m (A : Type) : Type := m (option A).

Definition optionT_liftT {m} `{Monad m} {A} (x : m A) : optionT m A.
Proof.
  unfold optionT.
  refine (do a ← x; return_ (Some a)).
Defined.
Instance optionT_T : MonadTrans optionT := {liftT := @optionT_liftT}.

Definition optionT_fmap {f} `{Functor f}
                        {A B} (g : A -> B) (x : optionT f A) : optionT f B :=
  @fmap f _ _ _ (fmap g) x.
Definition optionT_liftA {f} `{Applicative f}
                         {A B} (g : optionT f (A -> B)) (x : optionT f A)
                       : optionT f B.
(*  @liftA f _ _ _ _ (fmap liftA g) x.*)
Proof.
  unfold optionT in *.
  exact (fmap liftA g <*> x).
Defined.
Definition optionT_pure {f} `{Applicative f}
                        {A} (a : A) : optionT f A := @pure f _ _ _ (pure a).
Definition optionT_bind {m} `{Monad m}
                        {A} (ma : optionT m A) {B} (f : A -> optionT m B)
                        : optionT m B.
  unfold optionT in *.
  exact (do oa ← ma;
         match oa with
         | None => pure None
         | Some a => f a
         end
  ).
Defined.

Instance optionT_F {f} `{Functor f} : Functor (optionT f) :=
    {fmap := @optionT_fmap f _}.
Instance optionT_A {f} `{Applicative f} : Applicative (optionT f) :=
  { pure := @optionT_pure f _ _;
    liftA := @optionT_liftA f _ _ }.
Instance optionT_M {m} `{Monad m} : Monad (optionT m) :=
  { bind := @optionT_bind m _ _ _ }.

(** The Reader monad *)
Axiom Eta: forall A (B: A -> Type) (f: forall a, B a), f = fun  a=>f a.

Definition Reader (E : Type) := fun  X => E -> X.
Definition reader_fmap E A B (f : A -> B) (r : Reader E A) : Reader E B :=
  fun x => f (r x).
Definition reader_liftA E A B (f : Reader E (A -> B)) (r : Reader E A) :=
  fun x => (f x) (r x).
Definition reader_bind E A (r : Reader E A) B (f : A -> Reader E B) : Reader E B :=
  fun x => f (r x) x.

Instance readerF E : Functor (Reader E) :=
 { fmap := @reader_fmap E }.
Instance readerA E : Applicative (Reader E) :=
 { pure := fun  A (a:A) e=> a;
   liftA := @reader_liftA E }.
Instance readerM (E : Type): Monad (Reader E) :=
 { bind := @reader_bind E }.
(*
(* Checking the 3 laws *)
 - (* unit_left *)
   intros; apply Eta.
 - (* unit_right *)
   intros; apply Eta.
 - (* associativity *)
   reflexivity.
Defined.
*)
(** ** The State monad *)

Axiom Ext: forall A (B: A->Type) (f g: forall a, B a), (forall a, f a = g a) -> f = g.

Definition State (S : Type) (A : Type) := S -> A * S.
Definition state_fmap S A B (f : A -> B) (st : State S A) : State S B :=
  fun  s => let (a,s) := st s in (f a,s).
Definition state_liftA S A B (st_f : State S (A -> B)) (st_a : State S A) :=
  fun  s => let (f,s) := st_f s in
        let (a,s) := st_a s in
        (f a,s).
Definition state_bind S A (st_a : State S A) B  (f : A -> State S B) :=
  fun  s => let (a,s) := st_a s in
        f a s.

Instance stateF S : Functor (State S) :=
  { fmap := @state_fmap S }.
Instance stateA S : Applicative (State S) :=
  { pure := fun  A a s=> (a,s);
    liftA := @state_liftA S }.
Instance stateM S : Monad (State S) :=
  { bind := @state_bind S }.

(*
(* Checking the 3 laws *)
 (* unit_left *)
 abstract (intros;apply Ext;intros s;destruct (a s);split).
 (* unit_right *)
 abstract (intros;apply Eta).
 (* associativity *)
 abstract (intros;apply Ext;intros s;destruct (ma s);reflexivity).
Defined.
*)

(*

(** ** The tree monad *)
Inductive Tree (A:  Type) :=
| Leaf: A -> Tree A
| Branch: Tree A -> Tree A -> Tree A
.

Definition bind_tree {A B: Type} (f: A -> Tree B) :=
 fix bind_tree t :=
 match t with
 | Leaf a => f a
 | Branch t1 t2 => Branch (bind_tree t1) (bind_tree t2)
 end.

Instance tree : Monad Tree.
refine {| return_ := Leaf;
  bind := fun  A t B f => bind_tree f t
|}.
(* Checking the 3 laws *)
 (* unit_left *)
 Lemma tree_unit_left: forall A a, a = bind_tree (@Leaf A) a.
 Proof.
    intros A. induction a; auto.
    simpl. f_ap.
 Qed.
 exact tree_unit_left.
 (* unit_right *)
 Lemma tree_unit_right: forall A a B (f : A -> Tree B), f a = bind_tree f (Leaf a).
 Proof.
  simpl; split.
 Qed.
 exact tree_unit_right.
 (* associativity *)
 Lemma tree_associativity: forall A (m : Tree A) B f C (g : B -> Tree C),
 bind_tree (bind_tree g ∘ f) m = bind_tree g (bind_tree f m).
 Proof.
  induction m; intros; simpl; auto.
  f_ap.
 Qed.
 exact tree_associativity.
Defined.

(** ** A light version of the IO monad *)
Require Import Ascii.
Open Scope char_scope.

CoInductive stream: Type :=
| Stream: ascii -> stream -> stream
| EmptyStream.

Record std_streams: Type :=
{ stdin: stream;
  stdout: stream;
  stderr: stream
}.

Definition io (A: Type) := std_streams -> (A * std_streams).

Instance IO : Monad io :=
{| return_ := fun  A (a: A) s => (a, s);
   bind := fun  A a B (f: A -> io B) s => let (a, s) := (a s) in f a s
|}.
(* Checking the 3 laws *)
 (* unit_left *)
 Lemma io_unit_left:
 forall A (a: io A), a = (fun  s : std_streams => let (a, s) := a s in (a, s)).
 Proof.
 intros; apply Ext.
 intros s; case (a s); split.
Qed.
 exact io_unit_left.
 (* unit_right *)
 Lemma io_unit_right:
 forall A a B (f : A -> io B), f a = (fun  s : std_streams => f a s).
 Proof.
 intros; apply Ext.
 split.
Qed.
 exact io_unit_right.
 (* associativity *)
 Lemma io_associativity: forall A (m : io A) B (f: A -> io B) C (g : B -> io C),
 (fun  s => let (a, s0) := m s in let (a0, s1) := f a s0 in g a0 s1) =
 (fun  s => let (a, s0) := let (a, s0) := m s in f a s0 in g a s0).
 Proof.
 intros; apply Ext.
 intros; case (m a); split.
Qed.
 exact io_associativity.
Defined.

Definition getchar: io ascii :=
 fun  i=>
 let (c, stdin) :=
 match i.(stdin) with
 | EmptyStream => ("#", EmptyStream) (*I do not remember the code of EOF *)
 | Stream a i => (a, i)
 end
 in (c, {|stdin := stdin; stdout := i.(stdout); stderr := i.(stderr)|}).

Definition putchar (a: ascii): io unit :=
 fun  i=>
 let stdout :=
 (cofix putchar i :=
 match i with
 | EmptyStream => Stream a EmptyStream
 | Stream a i => Stream a (putchar i)
 end) i.(stdout)
 in (tt, {|stdin:=i.(stdin); stdout:=stdout; stderr:=i.(stderr)|}).

Definition err_putchar (a: ascii): io unit :=
 fun i=>
 let stderr :=
 (cofix putchar i :=
 match i with
 | EmptyStream => Stream a EmptyStream
 | Stream a i => Stream a (putchar i)
 end) i.(stderr)
 in (tt, {|stdin:=i.(stdin); stdout:=i.(stdout); stderr:=stderr|}).

Require Import Datatypes.
Require Import Data.List.
(*Require Import List.*)

Fixpoint lts l :=
match l with
| nil => EmptyString
| c::l => String c (lts l)
end.

Fixpoint ltS l :=
match l with
| nil => EmptyStream
| c::l => Stream c (ltS l)
end.

Example some_std_streams :=
{| stdin := ltS ("H"::"e"::"l"::"l"::"o"::","::" "::"W"::"o"::"r"::"l"::"d"::
                 "!"::nil);
   stdout := EmptyStream;
   stderr := EmptyStream
|}.

Example prog :=
 (do h    ← getchar;
  do e    ← getchar;
  do l1   ← getchar;
  do l2   ← getchar;
  do o1   ← getchar;
  do coma ← getchar;
  putchar "E" >>
  do space← getchar;
  do w    ← getchar;
  do o2   ← getchar;
  putchar "n" >>
  do r    ← getchar;
  do l3   ← getchar;
  do d    ← getchar;
  putchar d >>
  do bang ← getchar;
  do eof1 ← getchar;
  do eof2 ← getchar;
  do eof3 ← getchar;
  return_ (lts (h::e::l1::l2::o1::coma::space::w::o2::r::l3::d::
                bang::eof1::eof2::eof3::nil))).

Eval compute in (prog some_std_streams).
Eval compute in (let out := (snd (prog some_std_streams)).(stdout) in
                prog {|stdin := out;
                       stdout := EmptyStream;
                       stderr := EmptyStream|}).

*)


(*|
=============================================================
 6.822 Formal Reasoning About Programs, Spring 2021 - Pset 9
=============================================================
|*)

Require Import Pset9Sig.

(*|
Hoare Logic with Input/Output Traces
====================================

Hoare logic as covered in lecture is only the beginning, in terms of programming
features that can be supported. In this problem set, we will use a variant, a
Hoare logic that deals with input/output traces.

This problem set is not about defining a program logic; instead, we'll focus
on proving programs.
|*)

Module Impl.

(*|
Language syntax
===============

There is nothing special with the definitions of `exp` and `bop`; they are
similar to what we've seen in lecture.
|*)

Inductive nat_op :=
| Plus
| Minus
| Times.

Inductive exp :=
| Const (n : nat)
| Var (x : string)
| Read (e1 : exp)
| NatOp (b: nat_op) (e1 e2 : exp).

Inductive bool_op :=
| Equal
| Less.

Inductive bexp :=
| BoolOp (b: bool_op) (e1 e2 : exp).

(*|
`heap` and `valuation` are also as usual.
|*)

Definition heap := fmap nat nat.
Definition valuation := fmap var nat.

(*|
Besides `heap` and `valuation` objects, we now have `trace` objects.  Traces are
lists of `io` events used to track communication with the outside world.
|*)

Inductive io := In (v : nat) | Out (v : nat).
Definition trace := list io.

(*|
Assertions now talk about traces in addition to internal states.
|*)

Definition assertion := trace -> heap -> valuation -> Prop.

(*|
`cmd` has two new constructors: `Input` and `Output`.
|*)

Inductive cmd :=
| Skip
| Assign (x : var) (e : exp)
| Write (e1 e2 : exp)
| Seq (c1 c2 : cmd)
| If_ (be : bexp) (then_ else_ : cmd)
| While_ (inv : assertion) (be : bexp) (body : cmd)
  (* `Input` takes an input from the external world and assigns
     the value to the local variable `x`. *)
| Input (x : var)
  (* `Output` sends the value of `e` to the outside world. *)
| Output (e : exp).

(* BEGIN NOTATION MAGIC *)
Coercion Const : nat >-> exp.
Coercion Var : string >-> exp.
Declare Scope cmd_scope.
Notation "*[ e ]" := (Read e) : cmd_scope.
Notation "a + b" := (NatOp Plus a b) : cmd_scope.
Notation "a - b" := (NatOp Minus a b) : cmd_scope.
Notation "a * b" := (NatOp Times a b) : cmd_scope.
Notation "a = b" := (BoolOp Equal a b) : cmd_scope.
Notation "a < b" := (BoolOp Less a b) : cmd_scope.
Definition set (dst src : exp) : cmd :=
  match dst with
  | Read dst' => Write dst' src
  | Var dst' => Assign dst' src
  | _ => Assign "Bad LHS" 0
  end.
Infix "<-" := set (no associativity, at level 70) : cmd_scope.
Infix ";;" := Seq (right associativity, at level 75) : cmd_scope.
Notation "'when' b 'then' then_ 'else' else_ 'done'" :=
  (If_ b then_ else_) (at level 75, b at level 0) : cmd_scope.
Notation "'when' b 'then' then_ 'done'" :=
  (If_ b then_ Skip) (at level 75, b at level 0) : cmd_scope.
Notation "{{ I }}  'while' b 'loop' body 'done'" := (While_ I%nat%type b body) (at level 75) : cmd_scope.
Notation "x '<--' 'input'" := (Input x) (at level 75) : cmd_scope.
Notation "'output' e" := (Output e) (at level 75) : cmd_scope.
Delimit Scope cmd_scope with cmd.
(* END NOTATION MAGIC *)

(*|
Big-step operational semantics for commands
===========================================

Here is the definition of a big-step operational semantics for commands.  It is
very similar to what we've seen in class, but it also describes how `trace`
objects are accumulated as a program runs.  Note that IO events happen in
reverse chronological order: the most recent IO event appears at the *front* of
the list in the trace.

In the definition of `exec` below, the first three arguments are the trace,
heap, and valuation before execution, and the final three arguments are the
trace, heap, and valuation after execution.
|*)

(* Convenience notation: look up and default to 0 *)
Notation "m $! k" := (match m $? k with Some n => n | None => O end) (at level 30).

Fixpoint eval (e : exp) (h : heap) (v : valuation) : nat :=
  match e with
  | Const n => n
  | Var x => v $! x
  | Read e1 => h $! eval e1 h v
  | NatOp b e1 e2 =>
    let e1 := eval e1 h v in
    let e2 := eval e2 h v in
    match b with
    | Plus => e1 + e2
    | Minus => e1 - e2
    | Times => e1 * e2
    end
  end.

Fixpoint beval (b : bexp) (h : heap) (v : valuation) : bool :=
  match b with
  | BoolOp b e1 e2 =>
    let e1 := eval e1 h v in
    let e2 := eval e2 h v in
    match b with
    | Equal => if eval e1 h v ==n eval e2 h v then true else false
    | Less => if eval e2 h v <=? eval e1 h v then false else true
    end
  end.

Inductive exec : trace -> heap -> valuation -> cmd ->
                 trace -> heap -> valuation -> Prop :=
| ExSkip : forall tr h v,
    exec tr h v Skip tr h v
| ExAssign : forall tr h v x e,
    exec tr h v (Assign x e) tr h (v $+ (x, eval e h v))
| ExWrite : forall tr h v e1 e2,
    exec tr h v (Write e1 e2) tr (h $+ (eval e1 h v, eval e2 h v)) v
| ExSeq : forall tr1 h1 v1 c1 tr2 h2 v2 c2 tr3 h3 v3,
    exec tr1 h1 v1 c1 tr2 h2 v2 ->
    exec tr2 h2 v2 c2 tr3 h3 v3 ->
    exec tr1 h1 v1 (Seq c1 c2) tr3 h3 v3
| ExIfTrue : forall tr1 h1 v1 b c1 c2 tr2 h2 v2,
    beval b h1 v1 = true ->
    exec tr1 h1 v1 c1 tr2 h2 v2 ->
    exec tr1 h1 v1 (If_ b c1 c2) tr2 h2 v2
| ExIfFalse : forall tr1 h1 v1 b c1 c2 tr2 h2 v2,
    beval b h1 v1 = false ->
    exec tr1 h1 v1 c2 tr2 h2 v2 ->
    exec tr1 h1 v1 (If_ b c1 c2) tr2 h2 v2
| ExWhileFalse : forall I tr h v b c,
    beval b h v = false ->
    exec tr h v (While_ I b c) tr h v
| ExWhileTrue : forall I tr1 h1 v1 b c tr2 h2 v2 tr3 h3 v3,
    beval b h1 v1 = true ->
    exec tr1 h1 v1 c tr2 h2 v2 ->
    exec tr2 h2 v2 (While_ I b c) tr3 h3 v3 ->
    exec tr1 h1 v1 (While_ I b c) tr3 h3 v3
| ExInput : forall tr h v x inp,
    exec tr h v (Input x) (In inp :: tr) h (v $+ (x, inp))
| ExOutput : forall tr h v e,
    exec tr h v (Output e) (Out (eval e h v) :: tr) h v.

(*|
Note an interesting property of `ExInput`: it's *nondeterministic*, as we
consider that any `Input` command could read any value.  Without that rule,
our semantics would remain deterministic.

Hoare logic
===========

Up to this point in the class, we've mostly proved properties directly using
operational semantics, but it turns out that using a program logic is usually
much more convenient.

The logic below derives triples of the form `<{ P }> c <{ Q }>`, where `P` and
`Q` have type `assertion` and `c` has type `cmd`. It is also very similar to
the Hoare logic we've defined in class.

For succinctness, we write pre and post-conditions with `fun/inv tr h v => …`,
as an alias for `fun (tr: trace) (h: heap) (v: valuation) => …`

Definition of the logic
-----------------------
|*)

(* Cool Coq trick: forward-declare a notation to use it in a definition. *)
Reserved Notation "<{ P }> c <{ Q }>"
         (at level 90, c at next level,
          format "'[hv' <{  P  }> '/'  c  '/' <{  Q  }> ']'").

Notation "'fun/inv' tr h v => e" :=
  (fun (tr : trace) (h : heap) (v : valuation) => e%nat%type)
    (at level 90, tr ident, h ident, v ident).

Inductive hoare_triple : assertion -> cmd -> assertion -> Prop :=
| HtSkip : forall P, <{ P }> Skip <{ P }>
| HtAssign : forall P x e,
    <{ P }>
    Assign x e
    <{ fun/inv tr h v => exists v', P tr h v' /\ v = v' $+ (x, eval e h v') }>
| HtWrite : forall P (e1 e2 : exp),
    <{ P }>
    Write e1 e2
    <{ fun/inv tr h v =>
         exists h', P tr h' v /\ h = h' $+ (eval e1 h' v, eval e2 h' v) }>
| HtSeq : forall (P Q R : assertion) c1 c2,
    <{ P }> c1 <{ Q }> -> <{ Q }> c2 <{ R }> -> <{ P }> c1;; c2 <{ R }>
| HtIf : forall (P Q1 Q2 : assertion) b c1 c2,
    <{ fun/inv tr h v => P tr h v /\ beval b h v = true }> c1 <{ Q1 }> ->
    <{ fun/inv tr h v => P tr h v /\ beval b h v = false }> c2 <{ Q2 }> ->
    <{ P }> (when b then c1 else c2 done) <{ fun/inv tr h v => Q1 tr h v \/ Q2 tr h v }>
| HtWhile : forall (I P : assertion) b c,
    (forall tr h v, P tr h v -> I tr h v) ->
    <{ fun/inv tr h v => I tr h v /\ beval b h v = true }> c <{ I }> ->
    <{ P }>
    {{ I }} while b loop c done
    <{ fun/inv tr h v => I tr h v /\ beval b h v = false }>
| HtInput : forall (P : assertion) x,
    <{ P }>
    x <-- input
    <{ fun/inv tr h v =>
         exists tr' v' inp, P tr' h v' /\ tr = In inp :: tr' /\ v = v' $+ (x, inp) }>
| HtOutput : forall (P : assertion) e,
    <{ P }>
    output e
    <{ fun/inv tr h v => exists tr', P tr' h v /\ tr = Out (eval e h v) :: tr' }>
| HtConsequence : forall (P Q P' Q' : assertion) c,
    <{ P }> c <{ Q }> ->
    (forall tr h v, P' tr h v -> P tr h v) ->
    (forall tr h v, Q tr h v -> Q' tr h v) ->
    <{ P' }> c <{ Q' }>
where "<{ P }> c <{ Q }>" := (hoare_triple P c%cmd Q).

(*|
Consistency proof
-----------------

This logic is consistent with the semantics we've defined.  The consistency
theorem below will be needed to prove the correctness of our programs.
|*)

Lemma hoare_triple_big_step_while:
  forall I b c,
    (forall tr h v tr' h' v',
        exec tr h v c tr' h' v' ->
        I tr h v /\ beval b h v = true ->
        I tr' h' v') ->
    forall tr h v tr' h' v',
      exec tr h v (While_ I b c) tr' h' v' ->
      I tr h v ->
      I tr' h' v' /\ beval b h' v' = false.
Proof.
  induct 2; eauto.
Qed.

Theorem hoare_triple_big_step :
  forall pre c post,
    hoare_triple pre c post ->
    forall tr h v tr' h' v',
      exec tr h v c tr' h' v' ->
      pre tr h v -> post tr' h' v'.
Proof.
  induct 1; eauto.
  all: invert 1; simplify.
  all: eauto 6 using hoare_triple_big_step_while.
Qed.

(*|
Helper tactics
--------------

Phew, almost done with the setup!  The last step is to define some convenient
tactics for proving programs, which we'll demonstrate by example shortly.
That is, it's not important to understand these tactic definitions.
|*)

Lemma HtStrengthenPost :
  forall (P Q Q' : assertion) c,
    hoare_triple P c Q ->
    (forall tr h v, Q tr h v -> Q' tr h v) ->
    hoare_triple P c Q'.
Proof.
  simplify; eapply HtConsequence; eauto.
Qed.

Ltac cleanup :=
  lazymatch goal with
  | [  |- <{ _ }> _ <{ _ }> ] => fail "Can't clean up a Hoare triple"
  | _ => autounfold with core; cbv beta; first_order; subst; simplify
  end.

Ltac autosolve_t :=
  match goal with
  | [ _ : context[?a <=? ?b] |- _ ] => destruct (a <=? b); try discriminate
  | [ _ : context[?a ==n ?b] |- _ ] => destruct (a ==n b); try discriminate
  | [ H: _ <= 0 |- _ ] => apply Nat.le_0_r in H
  | [ H : ?E = ?E |- _ ] => clear H
  | [ H : ?E <= ?E |- _ ] => clear H
  | _ => progress subst
  end.

Ltac autosolve :=
  repeat autosolve_t; simplify; propositional; eauto 10; try equality; try linear_arithmetic.

Ltac ht1 :=
  lazymatch goal with
  | [  |- <{ _ }> _ <{ ?P }> ] =>
    tryif is_evar P then
      apply HtSkip || apply HtAssign || apply HtWrite || eapply HtSeq
      || eapply HtIf || eapply HtWhile
      || eapply HtInput || eapply HtOutput
    else eapply HtStrengthenPost
  | _ => fail "Goal is not a Hoare triple"
  end.

Ltac ht := simplify; repeat ht1; cleanup; autosolve.

(*|
Hoare-logic-based program proofs
================================

Now it's time to verify programs using the Hoare logic we've just defined!
Your task is to prove the theorems stated below using Hoare logic.  Do *not*
appeal directly to the operational semantics!  Using the Hoare logic is much
more automated and pleasant, and using completely manual derivations with
operational semantics would be particularly unpleasant (especially for the
last problem!).

Here is an example, to help you orient yourself:

First, a program:
|*)

Example add_two_inputs :=
  ("x" <-- input;;
   "y" <-- input;;
   output ("x" + "y"))%cmd.

(*|
Second, its specification and proof.  We'll demonstrate four versions:

- A proof ignoring the Hoare logic (but don't do this!)
- A proof using the Hoare logic by hand (usually not needed)
- A proof using the `ht1` automated tactic (great for debugging)
- A proof using the full `ht` automation (great after trying `ht1` for a bit).

The `ht` tactic is simple but powerful.  In particular, it runs `simplify`
and `eauto`, so you can add new rewritings to it using `Hint Rewrite …` and
new lemmas to it using `Hint Resolve …: core`.
|*)

Lemma add_two_inputs_ok0 :
  forall tr h v tr' h' v',
    exec tr h v add_two_inputs tr' h' v' ->
    tr = nil ->
    exists vx vy, tr' = [Out (vx + vy); In vy; In vx].
Proof.
  simplify.
  unfold add_two_inputs.
  invert H.
  invert H6.
  invert H10.
  invert H4.
  invert H8.
  simplify; subst; eauto.
Qed.

Lemma add_two_inputs_ok1:
  forall tr h v tr' h' v',
    exec tr h v add_two_inputs tr' h' v' ->
    tr = nil ->
    exists vx vy, tr' = [Out (vx + vy); In vy; In vx].
Proof.
  eapply hoare_triple_big_step
    with (pre := fun/inv tr _ _ => tr = nil)
         (post := fun/inv tr _ _ => exists vx vy, tr = [Out (vx + vy); In vy; In vx]).
  eapply HtSeq.
  eapply HtInput.
  eapply HtSeq.
  eapply HtInput.
  eapply HtStrengthenPost.
  eapply HtOutput.
  cleanup.
  autosolve.
Qed.

Lemma add_two_inputs_ok2:
  forall tr h v tr' h' v',
    exec tr h v add_two_inputs tr' h' v' ->
    tr = nil ->
    exists vx vy, tr' = [Out (vx + vy); In vy; In vx].
Proof.
  eapply hoare_triple_big_step.
  ht1.
  ht1.
  ht1.
  ht1.
  ht1.
  ht1.
  cleanup.
  autosolve.
Qed.

Lemma add_two_inputs_ok:
  forall tr h v tr' h' v',
    exec tr h v add_two_inputs tr' h' v' ->
    tr = nil ->
    exists vx vy, tr' = [Out (vx + vy); In vy; In vx].
Proof.
  eapply hoare_triple_big_step; ht.
Qed.

(*|
Notice how we started by applying `hoare_triple_big_step`.  In the following,
we'll give you goals phrased directly in terms of Hoare-logic triples.

Simple programs
===============

Your turn! The following program finds the maximum of three numbers.  Try to
step through the execution with `ht1` before handing control to `ht`!.
|*)

Example max3 :=
  ("x" <-- input;;
   "y" <-- input;;
   "z" <-- input;;
   when "x" < "y" then
     when "y" < "z" then
       output "z"
     else
       output "y"
     done
   else
     when "x" < "z" then
       output "z"
     else
       output "x"
     done
   done)%cmd.

Definition max3_spec (tr: trace): Prop :=
  exists x y z,
    tr = [Out (max x (max y z)); In z; In y; In x].

Theorem max3_ok:
  <{ fun/inv tr _ _ => tr = [] }>
  max3
  <{ fun/inv tr' _ _ => max3_spec tr' }>.
Proof.
Admitted.

(*|
Streaming Fibonacci sequence
----------------------------

Our first example with loops recycles our favorite example, an iterative
computation of the Fibonnaci sequence, but with a twist: it outputs all
intermediate results.

The definition below is parametric in an invariant ‘inv’ — the key part of
your job is to define an ‘inv’ that is correct and strong enough to make the
proof go through.
|*)

Example fibonacci n inv :=
  ("cnt" <- 0;;
   "x" <- 0;;
   output "x";;
   "y" <- 1;;
   output "y";;
   {{ inv }}
   while "cnt" < n loop
     "tmp" <- "y";;
     "y" <- "x" + "y";;
     "x" <- "tmp";;
     "cnt" <- "cnt" + 1;;
     output "y"
   done)%cmd.

Inductive fibonacci_spec : trace -> Prop :=
| FibInit: fibonacci_spec [Out 1; Out 0]
| FibRec: forall x y tr,
    fibonacci_spec (Out y :: Out x :: tr) ->
    fibonacci_spec (Out (x + y) :: Out y :: Out x :: tr).

(*|
Here's the definition of the loop invariant that you will have to modify to complete the proof:
|*)

Definition fibonacci_invariant (n: nat) : assertion :=
   fun/inv _ _ _ => True.

Local Hint Unfold fibonacci_invariant : core.
Local Hint Constructors fibonacci_spec : core.

Theorem fibonacci_ok (n: nat):
  <{ fun/inv tr _ _ => tr = [] }>
  fibonacci n (fibonacci_invariant n)
  <{ fun/inv tr' _ _ => fibonacci_spec tr' }>.
Proof.
Admitted.

(*|
Streaming factorial
-------------------

The Fibonnaci example above cheats somewhat: the number of iteration of the
main loop, `n`, is a compile-time constant.  In the ‘fact’ example below,
which streams partial results of a factorial computation, "n" is a regular
variable taken by the program as input.  As before, the definition of ‘fact’
takes an arbitrary invariant, and the hardest part of your job is to find one
that makes the proof go through.
|*)

Example fact inv :=
  ("cnt" <- 0;;
   "x" <- 1;;
   output "x";;
   {{ inv }}
   while "cnt" < "n" loop
     "cnt" <- 1 + "cnt";;
     "x" <- "x" * "cnt";;
     output "x"
   done)%cmd.

Inductive fact_spec : nat -> trace -> Prop :=
| FactInit: fact_spec 0 [Out 1]
| FactRec: forall x n tr,
    fact_spec n (Out x :: tr) ->
    fact_spec (S n) (Out (x * S n) :: Out x :: tr).

Definition fact_invariant (n: nat) : assertion :=
   fun/inv _ _ _ => True.

Local Hint Unfold fact_invariant : core.
Local Hint Constructors fact_spec : core.

Theorem fact_ok (n: nat):
  <{ fun/inv tr _ v => tr = [] /\ v $! "n" = n }>
  fact (fact_invariant n)
  <{ fun/inv tr' _ _ => fact_spec n tr' }>.
Proof.
Admitted.

Fixpoint fact_rec (n: nat) :=
  match n with
  | 0 => 1
  | S n => fact_rec n * S n
  end.

(* Sanity check: *)
Lemma fact_spec_fact_rec : forall n hd tl,
    fact_spec n (Out hd :: tl) -> fact_rec n = hd.
Proof.
  induct 1; simplify; equality.
Qed.

(*|
Heap-manipulating programs
==========================

Mailbox
-------

Let's spice things up a little by exploiting the heap, too.  The program
below implements a mailbox server: every time a client sends an address and a
value, the server stores the value and responds by outputting the previously
stored value.  The process stops as soon as a client tries to write to
address 0.
|*)

Example mailbox inv :=
  ("done" <- 0;;
   {{ inv }}
   while "done" = 0 loop
     "address" <-- input;;
     when "address" = 0 then
       "done" <- 1
     else
       "val" <-- input;;
       output *["address"];;
       *["address"] <- "val"
     done
   done)%cmd.

(*|
Take a moment to think about how you would specify this program before
reading the inductive spec below.
|*)

Inductive mailbox_spec : forall (h: heap) (tr: trace), Prop :=
| MBNil: mailbox_spec $0 []
| MBPut: forall h address val ret tr,
    address <> 0 ->
    ret = h $! address ->
    mailbox_spec h tr ->
    mailbox_spec (h $+ (address, val)) (Out ret :: In val :: In address :: tr).

Inductive mailbox_done (h: heap) : trace -> Prop :=
| MBDone: forall tr,
    mailbox_spec h tr ->
    mailbox_done h (In 0 :: tr).

(*|
Here is an example to help you understand how the spec works:
|*)

Goal mailbox_done
       ($0 $+ (5, 41)  (* From request 1 *)
           $+ (3, 11)  (* From request 2 *)
           $+ (5, 18)  (* From request 3 *)
           $+ (3, 39)) (* From request 4 *)
       [(* Final request: stop program by writing at 0 *)
        In 0;
        (* Fourth request: put 39 at address 3 (returns 11 from request 2) *)
        Out 11; In 39; In 3;
        (* Third request: put 18 at address 5 (returns 41 from request 1) *)
        Out 41; In 18; In 5;
        (* Second request: put 11 at address 3 (returns 0) *)
        Out 0; In 11; In 3;
        (* First request: put 41 at address 5 (returns 0) *)
        Out 0; In 41; In 5].
Proof.
  econstructor.
  econstructor; [ simplify; equality.. | ].
  econstructor; [ simplify; equality.. | ].
  econstructor; [ simplify; equality.. | ].
  econstructor; [ simplify; equality.. | ].
  econstructor.
Qed.

(*|
As always, the key part of the proof is the choice of invariant.
|*)

Definition mailbox_invariant : assertion :=
   fun/inv _ _ _ => True.

Local Hint Unfold mailbox_invariant : core.
Local Hint Constructors mailbox_spec mailbox_done : core.

Theorem mailbox_ok:
  <{ fun/inv tr h _ => tr = [] /\ h = $0 }>
  mailbox mailbox_invariant
  <{ fun/inv tr' h' _ => mailbox_done h' tr' }>.
Proof.
Admitted.

(*|
Streaming search
----------------

Our final example is the trickiest.  It takes the address of an array (“ptr”)
and its length ("length") as local variables, then reads a value to search
for (“needle”) as input and outputs the indices of all positions in the
array at which the value is found.
|*)

Example search inv :=
  ("needle" <-- input;;
   {{ inv }}
   while 0 < "length" loop
     "length" <- "length" - 1;;
     when *["ptr" + "length"] = "needle" then
       output "length" done
   done)%cmd.

(*|
The specification of this program is a bit trickier. There are three cases:

- Searching an empty array doesn't produce output.
- Searching an array that ends with the right value produces one output and
  continues the search.
- Searching an array that ends with another value continues the search
  without producing output.

The key to understand the definition of this predicate is to remember that
the most recent output is at the front of the trace, and we're searching from
the end of the array.
|*)

Inductive search_spec (needle: nat) : forall (offset: nat) (haystack: list nat), trace -> Prop :=
| SearchNil: forall offset,
    search_spec needle offset [] [In needle]
| SearchConsYes: forall n offset haystack tr,
    0 < offset ->
    n = needle ->
    search_spec needle offset haystack tr ->
    search_spec needle (offset - 1) (n :: haystack) (Out (offset - 1) :: tr)
| SearchConsNo: forall n offset haystack tr,
    0 < offset ->
    n <> needle ->
    search_spec needle offset haystack tr ->
    search_spec needle (offset - 1) (n :: haystack) tr.

Inductive search_done haystack tr : Prop :=
| SearchDone: forall needle offset,
    offset = 0 ->
    search_spec needle offset haystack tr ->
    search_done haystack tr.

(*|
Here is an example to help you understand how the spec works:
|*)

Goal search_done [1; 82; 9; 3; 8; 82; 8] [Out 1; Out 5; In 82].
Proof.
  apply SearchDone with (offset := 0) (needle := 82); auto.
  change 0 with (7 - 1 - 1 - 1 - 1 - 1 - 1 - 1) at 2.
  constructor; [ linear_arithmetic | equality | ].
  constructor; [ linear_arithmetic | equality | ].
  constructor; [ linear_arithmetic | equality | ].
  constructor; [ linear_arithmetic | equality | ].
  constructor; [ linear_arithmetic | equality | ].
  constructor; [ linear_arithmetic | equality | ].
  constructor; [ linear_arithmetic | equality | ].
  constructor.
Qed.

(*|
The predicate `array_at h ptr data` asserts that the values in `data` are found in
the range [ptr; ptr + length [data]) in memory.
|*)

Inductive array_at (h: heap) : nat -> list nat -> Prop :=
| ArrayEmpty : forall ptr, array_at h ptr []
| ArrayCons : forall ptr hd tl,
    h $! ptr = hd ->
    array_at h (S ptr) tl ->
    array_at h ptr (hd :: tl).

(*|
Here's an example: the heap below contains the array [12; 8; 7] starting at
address 3: address 3 contains the value 12, address 4 contains 8, and address
5 contains 7.
|*)

Goal array_at
     ($0 $+ (3, 12) $+ (1, 6) $+ (4, 8) $+ (12, 9) $+ (5, 7))
     3
     [12; 8; 7].
Proof.
  econstructor.
  simplify; equality.
  econstructor.
  simplify; equality.
  econstructor.
  simplify; equality.
  econstructor.
Qed.

(*|
You'll need to customize this invariant:
|*)

Definition search_invariant (ptr: nat) (data: list nat) : assertion :=
   fun/inv _ _ _ => True.

Local Hint Unfold search_invariant : core.
Local Hint Constructors search_spec search_done : core.
Arguments List.nth: simpl nomatch.

Theorem search_ok ptr data:
  <{ fun/inv tr h v =>
       tr = [] /\
       v $! "ptr" = ptr /\
       v $! "length" = Datatypes.length data /\
       array_at h ptr data }>
  search (search_invariant ptr data)
  <{ fun/inv tr' h' _ =>
       array_at h' ptr data /\
       search_done data tr' }>.
Proof.
Admitted.

(*|
Congratulations!  If you have extra time and you'd like to explore
opportunities for automation, here is a teaser: with appropriate hints added
to the `core` database (`Hint Resolve`, `Hint Extern` for linear arithmetic, and
`Hint Rewrite`), our proofs for all programs above are just `ht.`.
|*)

End Impl.

Module ImplCorrect : Pset9Sig.S := Impl.

(*|
Authors:

- Clément Pit-Claudel
- Joonwon Choi
- Adam Chlipala
|*)


From Hammer Require Import Hammer.

Require Import Compare.
Require Import Rbase.
Require Import Rfunctions.
Require Import Rseries.
Require Import PartSum.
Require Import Binomial.
Require Import Omega.
Local Open Scope R_scope.

Fixpoint prod_f_R0 (f:nat -> R) (N:nat) : R :=
match N with
| O => f O
| S p => prod_f_R0 f p * f (S p)
end.

Notation prod_f_SO := (fun An N => prod_f_R0 (fun n => An (S n)) N).

Lemma prod_SO_split :
forall (An:nat -> R) (n k:nat),
(k < n)%nat ->
prod_f_R0 An n =
prod_f_R0 An k * prod_f_R0 (fun l:nat => An (k +1+l)%nat) (n - k -1).
Proof. hammer_hook "Rprod" "Rprod.prod_SO_split".
intros; induction  n as [| n Hrecn].
absurd (k < 0)%nat; omega.
cut (k = n \/ (k < n)%nat);[intro; elim H0; intro|omega].
replace (S n - k - 1)%nat with O; [rewrite H1; simpl|omega].
replace (n+1+0)%nat with (S n); ring.
replace (S n - k-1)%nat with (S (n - k-1));[idtac|omega].
simpl; replace (k + S (n - k))%nat with (S n).
replace (k + 1 + S (n - k - 1))%nat with (S n).
rewrite Hrecn; [ ring | assumption ].
omega.
omega.
Qed.

Lemma prod_SO_pos :
forall (An:nat -> R) (N:nat),
(forall n:nat, (n <= N)%nat -> 0 <= An n) -> 0 <= prod_f_R0 An N.
Proof. hammer_hook "Rprod" "Rprod.prod_SO_pos".
intros; induction  N as [| N HrecN].
simpl; apply H; trivial.
simpl; apply Rmult_le_pos.
apply HrecN; intros; apply H; apply le_trans with N;
[ assumption | apply le_n_Sn ].
apply H; apply le_n.
Qed.

Lemma prod_SO_Rle :
forall (An Bn:nat -> R) (N:nat),
(forall n:nat, (n <= N)%nat -> 0 <= An n <= Bn n) ->
prod_f_R0 An N <= prod_f_R0 Bn N.
Proof. hammer_hook "Rprod" "Rprod.prod_SO_Rle".
intros; induction  N as [| N HrecN].
elim  H with O; trivial.
simpl; apply Rle_trans with (prod_f_R0 An N * Bn (S N)).
apply Rmult_le_compat_l.
apply prod_SO_pos; intros; elim (H n (le_trans _ _ _ H0 (le_n_Sn N))); intros;
assumption.
elim (H (S N) (le_n (S N))); intros; assumption.
do 2 rewrite <- (Rmult_comm (Bn (S N))); apply Rmult_le_compat_l.
elim (H (S N) (le_n (S N))); intros.
apply Rle_trans with (An (S N)); assumption.
apply HrecN; intros; elim (H n (le_trans _ _ _ H0 (le_n_Sn N))); intros;
split; assumption.
Qed.

Lemma fact_prodSO :
forall n:nat, INR (fact n) = prod_f_R0 (fun k:nat =>
(match (eq_nat_dec k 0) with
| left   _ => 1%R
| right _ => INR k
end)) n.
Proof. hammer_hook "Rprod" "Rprod.fact_prodSO".
intro; induction  n as [| n Hrecn].
reflexivity.
simpl; rewrite <- Hrecn.
case n; auto with real.
intros; repeat rewrite plus_INR;rewrite mult_INR;ring.
Qed.

Lemma le_n_2n : forall n:nat, (n <= 2 * n)%nat.
Proof. hammer_hook "Rprod" "Rprod.le_n_2n".
simple induction n.
replace (2 * 0)%nat with 0%nat; [ apply le_n | ring ].
intros; replace (2 * S n0)%nat with (S (S (2 * n0))).
apply le_n_S; apply le_S; assumption.
replace (S (S (2 * n0))) with (2 * n0 + 2)%nat; [ idtac | ring ].
replace (S n0) with (n0 + 1)%nat; [ idtac | ring ].
ring.
Qed.

Lemma RfactN_fact2N_factk :
forall N k:nat,
(k <= 2 * N)%nat ->
Rsqr (INR (fact N)) <= INR (fact (2 * N - k)) * INR (fact k).
Proof. hammer_hook "Rprod" "Rprod.RfactN_fact2N_factk".
assert (forall (n:nat), 0 <= (if eq_nat_dec n 0 then 1 else INR n)).
intros; case (eq_nat_dec n 0); auto with real.
assert (forall (n:nat), (0 < n)%nat ->
(if eq_nat_dec n 0 then 1 else INR n) = INR n).
intros n; case (eq_nat_dec n 0); auto with real.
intros; absurd (0 < n)%nat; omega.
intros; unfold Rsqr; repeat rewrite fact_prodSO.
cut ((k=N)%nat \/ (k < N)%nat \/ (N < k)%nat).
intro H2; elim H2; intro H3.
rewrite H3; replace (2*N-N)%nat with N;[right; ring|omega].
case H3; intro; clear H2 H3.
rewrite (prod_SO_split (fun l:nat => if eq_nat_dec l 0 then 1 else INR l) (2 * N - k) N).
rewrite Rmult_assoc; apply Rmult_le_compat_l.
apply prod_SO_pos; intros; auto.
replace (2 * N - k - N-1)%nat with (N - k-1)%nat.
rewrite Rmult_comm; rewrite (prod_SO_split
(fun l:nat => if eq_nat_dec l 0 then 1 else INR l) N k).
apply Rmult_le_compat_l.
apply prod_SO_pos; intros; auto.
apply prod_SO_Rle; intros; split; auto.
rewrite H0.
rewrite H0.
apply le_INR; omega.
omega.
omega.
assumption.
omega.
omega.
rewrite <- (Rmult_comm (prod_f_R0 (fun l:nat =>
if eq_nat_dec l 0 then 1 else INR l) k));
rewrite (prod_SO_split (fun l:nat =>
if eq_nat_dec l 0 then 1 else INR l) k N).
rewrite Rmult_assoc; apply Rmult_le_compat_l.
apply prod_SO_pos; intros; auto.
rewrite Rmult_comm;
rewrite (prod_SO_split (fun l:nat =>
if eq_nat_dec l 0 then 1 else INR l) N (2 * N - k)).
apply Rmult_le_compat_l.
apply prod_SO_pos; intros; auto.
replace (N - (2 * N - k)-1)%nat with (k - N-1)%nat.
apply prod_SO_Rle; intros; split; auto.
rewrite H0.
rewrite H0.
apply le_INR; omega.
omega.
omega.
omega.
omega.
assumption.
omega.
Qed.

Lemma INR_fact_lt_0 : forall n:nat, 0 < INR (fact n).
Proof. hammer_hook "Rprod" "Rprod.INR_fact_lt_0".
intro; apply lt_INR_0; apply neq_O_lt; red; intro;
elim (fact_neq_0 n); symmetry ; assumption.
Qed.

Lemma C_maj : forall N k:nat, (k <= 2 * N)%nat -> C (2 * N) k <= C (2 * N) N.
Proof. hammer_hook "Rprod" "Rprod.C_maj".
intros; unfold C; unfold Rdiv; apply Rmult_le_compat_l.
apply pos_INR.
replace (2 * N - N)%nat with N.
apply Rmult_le_reg_l with (INR (fact N) * INR (fact N)).
apply Rmult_lt_0_compat; apply INR_fact_lt_0.
rewrite <- Rinv_r_sym.
rewrite Rmult_comm;
apply Rmult_le_reg_l with (INR (fact k) * INR (fact (2 * N - k))).
apply Rmult_lt_0_compat; apply INR_fact_lt_0.
rewrite Rmult_1_r; rewrite <- mult_INR; rewrite <- Rmult_assoc;
rewrite <- Rinv_r_sym.
rewrite Rmult_1_l; rewrite mult_INR; rewrite (Rmult_comm (INR (fact k)));
replace (INR (fact N) * INR (fact N)) with (Rsqr (INR (fact N))).
apply RfactN_fact2N_factk.
assumption.
reflexivity.
rewrite mult_INR; apply prod_neq_R0; apply INR_fact_neq_0.
apply prod_neq_R0; apply INR_fact_neq_0.
omega.
Qed.


From Coq Require Export ZArith NArith List Number Decimal.

Import ListNotations.

Record bits := Mk_bits { unbits : list bool }.

(* Reinterpret a decimal with only digits 0 and 1 in binary. *)
Fixpoint bindec_to_bits_ (d : Decimal.uint) : list bool :=
  match d with
  | D0 d => false :: bindec_to_bits_ d
  | D1 d => true :: bindec_to_bits_ d
  | Nil | _ => []
  end.

Definition bindec_to_bits (d : Number.uint) : option bits :=
  match d with
  | UIntDecimal d => Some (Mk_bits (bindec_to_bits_ d))
  | _ => None
  end.

Definition dummy_bits_to (b : bits) : option Number.uint := None.

Declare Scope bits_scope.
Number Notation bits bindec_to_bits dummy_bits_to : bits_scope.

Notation "'input' x .. y" := (cons (unbits x) .. (cons (unbits y) nil) ..) (at level 200, x at level 0).

#[global] Open Scope bits_scope.

Definition example : list _ := input
00100
11110
10110
10111
10101
01111
00111
11100
10000
11001
00010
01010
.

Fixpoint zip_with {A B C} (f : A -> B -> C) (xs : list A) (ys : list B) : list C :=
  match xs, ys with
  | x :: xs, y :: ys => f x y :: zip_with f xs ys
  | _, _ => nil
  end.

Fixpoint transpose {A} (xs : list (list A)) : list (list A) :=
  match xs with
  | x :: [] => map (fun y => cons y nil) x
  | x :: xs => zip_with cons x (transpose xs)
  | [] => []
  end.

Definition sum_bool_Z (xs : list bool) : Z :=
  fold_left (fun i (b : bool) => i + if b then 1 else -1)%Z xs 0%Z.

Fixpoint bits_to_N_ (acc : N) (xs : list bool) : N :=
  match xs with
  | [] => acc
  | x :: xs => bits_to_N_ (if x then acc * 2 + 1 else acc * 2) xs
  end.

Definition bits_to_N := bits_to_N_ 0.

Record PartOne := { gamma : list bool ; epsilon : list bool }.

Definition part_one (xs : list (list bool)) : PartOne :=
  let tmp := map (fun x => if (sum_bool_Z x <? 0)%Z then false else true) (transpose xs) in
  {| gamma := tmp ; epsilon := map negb tmp |}.

Fixpoint map_filter {A B} (f : A -> option B) (xs : list A) : list B :=
  match xs with
  | [] => []
  | x :: xs =>
    match f x with
    | None => map_filter f xs
    | Some y => y :: map_filter f xs
    end
  end.

Definition solve (xs : list (list bool)) : N :=
  let ans := part_one xs in
  bits_to_N (gamma ans) * bits_to_N (epsilon ans).

(* Compute solve example. *)

Definition head {A} (xs : list A) : option A :=
  match xs with
  | x :: _ => Some x
  | [] => None
  end.

Fixpoint brrr (n : nat) (switch : bool) (xs : list (list bool * list bool)) : list bool :=
  match n with
  | O => []
  | S n =>
    let bit := xorb switch (0 <=? sum_bool_Z (map_filter (fun '(x, _) => head x) xs))%Z in
    match map_filter (fun '(x, y) =>
      match x with
      | c :: x => if Bool.eqb bit c then Some (x, y) else None
      | _ => None
      end) xs
    with
    | [(_, x)] => x
    | xs => brrr n switch xs
    end
  end.

Definition brr switch xs := brrr (length xs) switch (map (fun x => (x, x)) xs).

Definition solve2 (xs : list (list bool)) : N :=
  let ogr := brr false xs in
  let csr := brr true xs in
  bits_to_N ogr * bits_to_N csr.

(* Compute solve2 example. *)

Definition solve12 (i : list (list bool)) : N * N :=
  (solve i, solve2 i).


Require Import Raxiom Rconvenient IZR Repsilon Rapprox Rseq.
Require Import Arith.

Module Rfunction (Import T : CReals).
  Module Rconvenient := Rconvenient T. Import Rconvenient.
  Module IZR := IZR T. Import IZR.
  Module Repsilon := Repsilon T. Import Repsilon.
  Module Rsequence := Rsequence T. Import Rsequence.
  Module Rapprox := Rapprox T. Import Rapprox.

  Definition Rcont_pt (f : R -> R) (x : R) : Type :=
    forall e, R0 < e ->
      sigT (fun d =>
        prod
          (R0 < d)
          (forall x', Rdist x x' d -> Rdist (f x) (f x') e)).

  Definition Rcont (f : R -> R) : Type := forall x, Rcont_pt f x.

  Definition Rcont_op (op : R -> R -> R) : Type :=
    prod
      (forall a, Rcont (op a))
      (forall a, Rcont (fun x => op x a)).

  Lemma Rcont_add : Rcont_op Radd.
  Admitted.

  Lemma Rcont_mul : Rcont_op Rmul.
  Admitted.

  Lemma Rcont_sub : Rcont_op Rsub.
  Admitted.

  Lemma Rcont_opp : Rcont Ropp.
  Admitted.

  Lemma Rcont_compose : forall f g, Rcont f -> Rcont g -> Rcont (fun x => f (g x)).
  Proof.
    intros f g cf cg x e epos.
    destruct (cf (g x) e epos) as (d, (dpos, hd)).
    destruct (cg x d dpos) as (c, (cpos, hc)).
    eauto.
  Qed.

  (* TODO : dire que ~~A→A est plus faible que ~A\/A *)
  (* TODO : formuler la décision de l'égalité *)
  (* TODO : dire que (WEAK Rle → Rle) → Décision de l'égalité *)

End Rfunction.


Require Import datatypes.

Definition read (t:Tape): Sym :=
           match t with (pair l r) => (hd r)
           end.

Definition is_value (T:Spec) (t:Tape) (q:State) :=
           tr T q (read t) = None.

(****************** INDUCTIVE Semantics *********************)

Inductive bf: Spec -> Tape -> State -> Tape -> State -> Prop :=

(* HALT move *)

   bfH: forall T:Spec, forall q:State,
        forall t:Tape,
        (is_value T t q) ->
        (bf T t q t q)

(* RIGHT move *)

 | bfR: forall T:Spec, forall p q i:State,
        forall l r:HTape, forall t:Tape,
        (tr T p (read (pair l r))) = (Some (i, R)) ->
        (bf T (pair (Cons (hd r) l) (tl r)) i t q) ->
        (bf T (pair l r) p t q)

(* LEFT move *)

 | bfL: forall T:Spec, forall p q i:State,
        forall l r:HTape, forall t:Tape,
        (tr T p (read (pair l r))) = (Some (i, L)) ->
        (bf T (pair (tl l) (Cons (hd l) r)) i t q) ->
        (bf T (pair l r) p t q)

(* WRITE move *)

 | bfW: forall T:Spec, forall p q i:State,
        forall l r:HTape, forall t:Tape, forall a:Sym,
        (tr T p (read (pair l r))) = (Some (i, (W a))) ->
        (bf T (pair l (Cons a (tl r))) i t q) ->
        (bf T (pair l r) p t q).

(****************** COINDUCTIVE Semantics *********************)

CoInductive bi: Spec -> Tape -> State -> Prop :=

(* RIGHT move *)

   biR: forall T:Spec, forall p q:State,
        forall l r:HTape,
        (tr T p (read (pair l r))) = (Some (q, R)) ->
        (bi T (pair (Cons (hd r) l) (tl r)) q) ->
        (bi T (pair l r) p)

(* LEFT move *)

 | biL: forall T:Spec, forall p q:State,
        forall l r:HTape,
        (tr T p (read (pair l r))) = (Some (q, L)) ->
        (bi T (pair (tl l) (Cons (hd l) r)) q) ->
        (bi T (pair l r) p)

(* WRITE move *)

 | biW: forall T:Spec, forall p q:State,
        forall l r:HTape, forall a:Sym,
        (tr T p (read (pair l r))) = (Some (q, (W a))) ->
        (bi T (pair l (Cons a (tl r))) q) ->
        (bi T (pair l r) p).


Require Import Coq.Init.Specif.
Require Import Setoid.
From research Require Import Utils.
From research Require Import ProbAxioms.

Theorem split_prob_thm :
  forall (A B :Type), Prob (A * B) -> ((Prob A) * (Prob B)).
Proof.
  intros A B H.
  split.
    - apply (prob_imp_independent (A * B) A (proj_left A B)). apply H.
    - apply (prob_imp_independent (A * B) B (proj_right A B)). apply H.
Qed.

Definition split_prob (A B : Type) (H : Prob (A * B)) : ((Prob A) * (Prob B))
  := (prob_imp_independent (A * B) A (proj_left A B) H,
      prob_imp_independent (A * B) B (proj_right A B) H).

Theorem comb_prob :
  forall (A B : Type), ((Prob A) + (Prob B)) -> Prob (A + B).
Proof.
  intros A B H.
  destruct H.
    - apply (prob_imp_independent A (A + B) (inj_left A B)). apply p.
    - apply (prob_imp_independent B (A + B) (inj_right A B)). apply p.
Qed.

Theorem prob_pair_to_union :
  forall (A B : Type), ((Prob A) * (Prob B)) -> ((Prob A) + (Prob B)).
Proof.
  intros.
  destruct X as [pA pB].
  left.
  apply pA.
Qed.

Theorem split_prob_general :
  forall (A : Type) (B : A -> Type),
  Prob (forall (a : A), B a) -> forall (a : A), Prob (B a).
Proof.
  intros A B H a.
  - assert (H2: (forall (a' : A), B a') -> (B a)).
    * intros f. apply (f a).
    * apply (prob_imp_independent (forall a : A, B a) (B a) H2).
      apply H.
Qed.

(*
#[universes(template)]
Inductive sigT (A:Type) (P:A -> Type) : Type :=
    existT : forall x:A, P x -> sigT P.
*)

Print sigT.

Check sigT.
Check existT.

Check sigT (fun (n : nat) => bool).
Check existT (fun (n : nat) => bool) 2.

Theorem comb_prob_general :
  forall (A : Type) (B : A -> Type),
  sigT (fun (a : A) => Prob (B a)) -> Prob (sigT B).
Proof.
  intros A B H.
  destruct H.
  assert (H2: (B x) -> sigT B).
    - intros b. apply existT in b. apply b.
    - apply (prob_imp_independent (B x) (sigT B) H2). apply p.
Qed.

(*
(* TODO exists requires its argument to be a Prop, not just any Type. *)
Theorem comb_prob_general :
  forall (A : Type) (B : A -> Type),
  (Sigma (a : A) (Prob (B a)). -> (Prob (exists (a : A) (b : (B a)), True))
Proof.
  intros.
  exists.
  Abort.
*)

(*
Definition type_equiv (A B : Type) : Type :=
  sigT (fun (f : A -> B) => (
    prod
    (sigT (fun (h : B -> A) => (homotopy_ind A A (fun (a : A) => (h (f a))) (id A))))
    (sigT (fun (g : B -> A) => (homotopy_ind B B (fun (b : B) => (f (g b))) (id B))))
  )).
*)

Definition based_type_equiv (A B : Type) (f: A -> B) : Type :=
    prod
    (sigT (fun (h : B -> A) => (homotopy_ind A A (fun (a : A) => (h (f a))) (id A))))
    (sigT (fun (g : B -> A) => (homotopy_ind B B (fun (b : B) => (f (g b))) (id B)))).

Definition indep (A B : Type) : Type :=
  based_type_equiv (Prob (A * B)) (prod (Prob A) (Prob B)) (split_prob A B).

Definition cond (A B : Type) (a : Prob A) : Type :=
  sigT (fun (p : Prob (A * B)) => (fst (split_prob A B p) = a)).

(* Why does Prob (A * B) -> sum a * Prob (B | a)
Prob (B | a) = exists an x : Prob (A * B) constructed with a

x : Prob(A * B) -> a : Prob A (split prob, left projection)
To get cond, we need an x, but we already have it

Prove that the projection of x to Prob A = a : Prob A

Now we need a second function

Once we have f and g, h should be equal to one of them
Then we need to prove that the two functions satisfy the equivalence
*)
Theorem f_thm :
  forall (A B : Type), (Prob (A * B)) -> (sigT (fun (a : Prob A) => cond A B a)).
Proof.
  intros A B p.
  apply existT with (x := fst (split_prob A B p)).
  unfold cond.
  apply existT with (x := p).
  reflexivity.
Qed.

Check f_thm.

Print f_thm.

Definition f (A B : Type) (p : Prob (A * B)) :
  {a : Prob A & cond A B a}
  := existT (fun a : Prob A => cond A B a) (fst (split_prob A B p))
  (existT
     (fun p0 : Prob (A * B) =>
      fst (split_prob A B p0) = fst (split_prob A B p)) p eq_refl).

Theorem g_thm :
  forall (A B : Type), (sigT (fun (a : Prob A) => cond A B a)) -> Prob (A * B).
Proof.
  intros A B p.
  destruct p as [a c].
  destruct c.
  apply x.
Qed.

Check g_thm.

Print g_thm.

Definition g (A B : Type) (p : {a : Prob A & cond A B a}) : (Prob (A * B))
  := let (a, c) := p in let (x, _) := c in x.

(*
Definition f (A B : Type) (p : Prob (A * B)) : (sigT (fun (a : Prob A) => cond A B a))
  := .
*)

(*
Theorem f_of_g :
  forall (A B : Type) (p : Prob (A * B)), g A B (f A B p) = p.
Proof.
  intros A B p.

Check existT.
*)

(* P(A * B) = sum (a * P(B | a) *)
Theorem pair_cond_equivalence :
  forall (A B : Type),
    type_equiv (Prob (A * B)) (sigT (fun (a : Prob A) => cond A B a)).
Proof.
  intros.
  unfold type_equiv.
  apply (existT _ (f A B)).
  apply pair.
    - apply existT with (x := g A B).
      unfold homotopy_ind. unfold homotopy. unfold id. reflexivity.
    - apply existT with (x := g A B).
      unfold homotopy_ind. unfold homotopy. unfold id.
      intros aXp.
      destruct aXp as [a c].
      simpl.
      destruct c.
      rewrite <- e.
      unfold f.
      reflexivity.
Qed.

Theorem cond_proj_right_thm : forall (A B : Type) (a : Prob A),
  cond A B a -> Prob B.
Proof.
  intros A B a c.
  destruct c as [x _].
  apply split_prob in x.
  apply proj_right in x.
  apply x.
Qed.

Print cond_proj_right_thm.

Definition cond_proj_right (A B : Type) (a : Prob A) (c : cond A B a) : Prob B :=
  let (x, _) := c in
  let x0 := split_prob A B x in let x1 := proj_right (Prob A) (Prob B) x0 in x1.

Definition marginal_prob (A B : Type) : Type :=
  forall (a : Prob A), based_type_equiv (cond A B a) (Prob B) (cond_proj_right A B a).

Theorem ind_to_pair_thm : forall (A B : Type) (H: marginal_prob A B),
  Prob A * Prob B -> Prob (A * B).
Proof.
  intros A B.
  unfold marginal_prob. unfold type_equiv. unfold homotopy_ind. unfold homotopy.
  unfold id.
  intros m.
  intros p.
  destruct p as [a b].
  assert (H : {f : cond A B a -> Prob B &
    ({h : Prob B -> cond A B a & forall a0 : cond A B a, h (f a0) = a0} *
     {g : Prob B -> cond A B a & forall a0 : Prob B, f (g a0) = a0})%type}).
  - apply m.
  - destruct H. destruct p as [h g]. destruct h as [fh eh].
    apply fh in b.
    destruct b.
    apply x0.
Qed.

Print ind_to_pair_thm.

Definition ind_to_pair (A B : Type)
  (m : forall a : Prob A,
       {f : cond A B a -> Prob B &
       ({h : Prob B -> cond A B a & forall a0 : cond A B a, h (f a0) = a0} *
        {g : Prob B -> cond A B a & forall a0 : Prob B, f (g a0) = a0})%type})
  (p : Prob A * Prob B) :=
  let (a, b) := p in
  let H := m a in
  let (x, p0) := H in
  let (h, _) := p0 in
  let (fh, _) := h in let b0 := fh b in let (x0, _) := b0 in x0.

(*
Theorem marginal_to_ind_thm :
  forall (A B : Type), (marginal_prob A B) -> (indep A B).
Proof.
  intros A B.
  unfold marginal_prob.
  unfold type_equiv. unfold homotopy_ind. unfold homotopy. unfold id.
  intros H.
  unfold indep. unfold type_equiv.
  unfold homotopy_ind. unfold homotopy. unfold id.
  apply existT with (x := split_prob A B).
  apply pair.
  - apply existT with (x := ind_to_pair A B H).
    intros p.
    unfold ind_to_pair. unfold split_prob.
    unfold prob_imp_independent.
    simpl. Abort.
*)

Check existT.

Theorem construct_cond_thm : forall (A B : Type) (a : Prob A) (b : Prob B)
  (fg : Prob A * Prob B -> Prob (A * B))
  (eg : forall a : Prob A * Prob B, split_prob A B (fg a) = a),
  (cond A B a).
Proof.
  intros.
  unfold cond.
  apply (existT _ (fg (pair a b))).
  assert (H: fst (split_prob A B (fg (a, b))) = a).
    { rewrite eg. simpl. reflexivity. }
  apply H.
Qed.

Print construct_cond_thm.

Print eq_refl.
Print eq_ind_r.
Check eq_ind_r.

Definition construct_cond (A B : Type) (a : Prob A) (b : Prob B)
  (fg : Prob A * Prob B -> Prob (A * B))
  (eg : forall a : Prob A * Prob B, split_prob A B (fg a) = a) : (cond A B a) :=
existT (fun p : Prob (A * B) => fst (split_prob A B p) = a)
  (fg (a, b))
  (let H : fst (split_prob A B (fg (a, b))) = a :=
     eq_ind_r (fun p : Prob A * Prob B => fst p = a) eq_refl (eg (a, b)) in
   H).

Theorem ind_to_marginal_thm :
  forall (A B : Type), (indep A B) -> (marginal_prob A B).
Proof.
  intros A B i.
  destruct i as [h g].
  unfold marginal_prob.
  intros a.
  unfold based_type_equiv.
  unfold homotopy_ind in h. unfold homotopy in h. unfold id in h.
  unfold homotopy_ind in g. unfold homotopy in g. unfold id in g.
  destruct h as [fh eh].
  destruct g as [fg eg].
  unfold homotopy_ind. unfold homotopy. unfold id.
  apply pair.
  - unfold homotopy_ind. unfold homotopy. unfold id.
    apply existT with (x := fun (b : Prob B) => construct_cond_thm A B a b fh eh fg eg).
    intros c. simpl.
    apply existT with (x := fun (b : Prob B) =>
      existT (fg (pair a b))).
    (*apply existT with (x := fun (b : Prob B) => fh (pair a b)).*)

Theorem ind_equivalence :
  forall (A B: Type), type_equiv (indep A B) (marginal_prob A B).
Proof.
  intros A B.
  unfold type_equiv.


Require Coq.Logic.Classical_Prop.
Require Import ProofCheckingEuclid.euclidean_axioms.
Require Import ProofCheckingEuclid.euclidean_defs.
Require Import ProofCheckingEuclid.euclidean_tactics.
Require Import ProofCheckingEuclid.lemma_NCdistinct.
Require Import ProofCheckingEuclid.lemma_betweennotequal.
Require Import ProofCheckingEuclid.lemma_collinear_ABC_ABD_BCD.
Require Import ProofCheckingEuclid.lemma_collinearorder.
Require Import ProofCheckingEuclid.lemma_collinearright.
Require Import ProofCheckingEuclid.lemma_congruenceflip.
Require Import ProofCheckingEuclid.lemma_congruencesymmetric.
Require Import ProofCheckingEuclid.lemma_congruencetransitive.
Require Import ProofCheckingEuclid.lemma_doublereverse.
Require Import ProofCheckingEuclid.lemma_droppedperpendicularunique.
Require Import ProofCheckingEuclid.lemma_equalitysymmetric.
Require Import ProofCheckingEuclid.lemma_extension.
Require Import ProofCheckingEuclid.lemma_extensionunique.
Require Import ProofCheckingEuclid.lemma_fiveline.
Require Import ProofCheckingEuclid.lemma_inequalitysymmetric.
Require Import ProofCheckingEuclid.lemma_interior5.
Require Import ProofCheckingEuclid.lemma_layoffunique.
Require Import ProofCheckingEuclid.lemma_planeseparation.
Require Import ProofCheckingEuclid.lemma_right_triangle_NC.
Require Import ProofCheckingEuclid.lemma_right_triangle_leg_change.
Require Import ProofCheckingEuclid.lemma_right_triangle_symmetric.
Require Import ProofCheckingEuclid.lemma_s_onray.
Require Import ProofCheckingEuclid.lemma_s_onray_assert_ABB.
Require Import ProofCheckingEuclid.lemma_s_onray_assert_bets_ABE.
Require Import ProofCheckingEuclid.lemma_s_os.
Require Import ProofCheckingEuclid.lemma_s_right_triangle.
Require Import ProofCheckingEuclid.lemma_samesidesymmetric.
Require Import ProofCheckingEuclid.proposition_12.

Section Euclid.

Context `{Ax:euclidean_neutral_ruler_compass}.

Lemma proposition_07 :
	forall A B C D,
	neq A B ->
	Cong C A D A ->
	Cong C B D B ->
	SS C D A B ->
	eq C D.
Proof.
	intros A B C D.
	intros neq_A_B.
	intros Cong_CA_DA.
	intros Cong_CB_DB.
	intros SS_C_D_AB.

	pose proof (lemma_inequalitysymmetric _ _ neq_A_B) as neq_B_A.

	pose proof (lemma_congruenceflip _ _ _ _ Cong_CA_DA) as (Cong_AC_AD & _ & _).
	pose proof (lemma_doublereverse _ _ _ _ Cong_CB_DB) as (Cong_BD_BC & Cong_BC_BD).

	pose proof (lemma_samesidesymmetric _ _ _ _ SS_C_D_AB) as (SS_D_C_AB & _ & _).
	destruct SS_C_D_AB as (_ & _ & _ & _ & _ & _ & _ & nCol_A_B_C & _).

	pose proof (proposition_12 _ _ _ nCol_A_B_C) as (F & Perp_at_CF_AB_F).
	destruct Perp_at_CF_AB_F as (H & _ & Col_A_B_F & Col_A_B_H & RightTriangle_HFC).

	pose proof (lemma_collinearorder _ _ _ Col_A_B_F) as (Col_B_A_F & _ & _ & Col_A_F_B & _).
	pose proof (lemma_collinearorder _ _ _ Col_A_B_H) as (Col_B_A_H & _ & _ & _ & _).

	pose proof (lemma_collinear_ABC_ABD_BCD _ _ _ _ Col_B_A_F Col_B_A_H neq_B_A) as Col_A_F_H.
	pose proof (lemma_collinearorder _ _ _ Col_A_F_H) as (_ & _ & _ & _ & Col_H_F_A).
	pose proof (lemma_collinear_ABC_ABD_BCD _ _ _ _ Col_A_B_F Col_A_B_H neq_A_B) as Col_B_F_H.
	pose proof (lemma_collinearorder _ _ _ Col_B_F_H) as (_ & _ & _ & _ & Col_H_F_B).

	pose proof (lemma_right_triangle_NC _ _ _ RightTriangle_HFC) as nCol_H_F_C.
	pose proof (lemma_NCdistinct _ _ _ nCol_H_F_C) as (_ & neq_F_C & _ & _ & neq_C_F & _).
	pose proof (lemma_extension _ _ _ _ neq_C_F neq_F_C) as (E & BetS_C_F_E & Cong_FE_FC).

	pose proof (lemma_congruenceflip _ _ _ _ Cong_FE_FC) as (_ & _ & Cong_FE_CF).
	pose proof (lemma_doublereverse _ _ _ _ Cong_FE_FC) as (_ & Cong_EF_CF).

	pose proof (lemma_s_os _ _ _ _ _ BetS_C_F_E Col_A_B_F nCol_A_B_C) as OS_C_AB_E.
	pose proof (lemma_planeseparation _ _ _ _ _ SS_D_C_AB OS_C_AB_E) as OS_D_AB_E.
	destruct OS_D_AB_E as (G & BetS_D_G_E & Col_A_B_G & _).
	pose proof (lemma_collinearorder _ _ _ Col_A_B_G) as (Col_B_A_G & _ & _ & _ & _).
	pose proof (lemma_collinear_ABC_ABD_BCD _ _ _ _ Col_A_B_G Col_A_B_F neq_A_B) as Col_B_G_F.
	pose proof (lemma_collinear_ABC_ABD_BCD _ _ _ _ Col_B_A_F Col_B_A_G neq_B_A) as Col_A_F_G.

	pose proof (axiom_betweennesssymmetry _ _ _ BetS_C_F_E) as BetS_E_F_C.
	pose proof (axiom_betweennesssymmetry _ _ _ BetS_D_G_E) as BetS_E_G_D.

	pose proof (lemma_extension _ _ _ _ neq_A_B neq_B_A) as (K & BetS_A_B_K & Cong_BK_BA).
	pose proof (lemma_extension _ _ _ _ neq_B_A neq_A_B) as (J & BetS_B_A_J & Cong_AJ_AB).
	pose proof (lemma_s_onray_assert_bets_ABE _ _ _ BetS_A_B_K neq_A_B) as OnRay_AB_K.
	pose proof (lemma_s_onray_assert_bets_ABE _ _ _ BetS_B_A_J neq_B_A) as OnRay_BA_J.
	assert (Col A B J) as Col_A_B_J by (unfold Col; one_of_disjunct BetS_B_A_J).
	assert (Col B A K) as Col_B_A_K by (unfold Col; one_of_disjunct BetS_A_B_K).
	pose proof (lemma_collinearorder _ _ _ Col_A_B_J) as (Col_B_A_J & _ & _ & _ & _).
	pose proof (lemma_collinearorder _ _ _ Col_B_A_J) as (_ & _ & _ & _ & Col_J_A_B).
	pose proof (lemma_collinearorder _ _ _ Col_B_A_K) as (Col_A_B_K & _ & _ & _ & _).
	pose proof (lemma_collinearorder _ _ _ Col_A_B_K) as (_ & _ & _ & _ & Col_K_B_A).

	pose proof (lemma_betweennotequal _ _ _ BetS_B_A_J) as (neq_A_J & _ & _).
	pose proof (lemma_betweennotequal _ _ _ BetS_A_B_K) as (neq_B_K & _ & _).
	pose proof (lemma_inequalitysymmetric _ _ neq_A_J) as neq_J_A.
	pose proof (lemma_inequalitysymmetric _ _ neq_B_K) as neq_K_B.

	pose proof (cn_congruencereflexive A B) as Cong_AB_AB.
	pose proof (cn_congruencereflexive A F) as Cong_AF_AF.
	pose proof (cn_congruencereflexive A G) as Cong_AG_AG.
	pose proof (cn_congruencereflexive B A) as Cong_BA_BA.
	pose proof (cn_congruencereflexive B F) as Cong_BF_BF.
	pose proof (cn_congruencereflexive B G) as Cong_BG_BG.
	pose proof (cn_congruencereflexive F B) as Cong_FB_FB.
	pose proof (cn_congruencereflexive G B) as Cong_GB_GB.

	assert (Cong A C A E) as Cong_AC_AE.
	assert (eq A F \/ neq A F) as [eq_A_F|neq_A_F] by (apply Classical_Prop.classic).
	{
		(* case eq_A_F *)
		assert (Cong A E A C) as Cong_AE_AC by (rewrite eq_A_F; exact Cong_FE_FC).
		pose proof (lemma_congruencesymmetric _ _ _ _ Cong_AE_AC) as Cong_AC_AE.

		exact Cong_AC_AE.
	}
	{
		(* case neq_A_F *)
		pose proof (lemma_collinearright _ _ _ _ RightTriangle_HFC Col_H_F_A neq_A_F) as RightTriangle_AFC.
		pose proof (lemma_right_triangle_symmetric _ _ _ RightTriangle_AFC) as RightTriangle_CFA.
		destruct RightTriangle_CFA as (P & BetS_C_F_P & Cong_CF_PF & Cong_CA_PA & _).

		pose proof (lemma_congruencetransitive _ _ _ _ _ _ Cong_FE_CF Cong_CF_PF) as Cong_FE_PF.
		pose proof (lemma_congruenceflip _ _ _ _ Cong_FE_PF) as (_ & _ & Cong_FE_FP).
		pose proof (lemma_extensionunique _ _ _ _ BetS_C_F_E BetS_C_F_P Cong_FE_FP) as eq_E_P.
		assert (Cong C A E A) as Cong_CA_EA by (rewrite eq_E_P; exact Cong_CA_PA).
		pose proof (lemma_congruenceflip _ _ _ _ Cong_CA_EA) as (Cong_AC_AE & _ & _).

		exact Cong_AC_AE.
	}
	(* asserted Cong_AC_AE *)

	pose proof (lemma_doublereverse _ _ _ _ Cong_AC_AE) as (Cong_EA_CA & _).
	pose proof (lemma_congruenceflip _ _ _ _ Cong_EA_CA) as (_ & Cong_AE_CA & _ ).
	pose proof (lemma_congruenceflip _ _ _ _ Cong_EA_CA) as (Cong_AE_AC & _ & _).
	pose proof (lemma_congruencetransitive _ _ _ _ _ _ Cong_AE_CA Cong_CA_DA) as Cong_AE_DA.
	pose proof (lemma_congruenceflip _ _ _ _ Cong_AE_DA) as (_ & _ & Cong_AE_AD).
	pose proof (lemma_congruencesymmetric _ _ _ _ Cong_AE_AD) as Cong_AD_AE.
	pose proof (lemma_congruenceflip _ _ _ _ Cong_AD_AE) as (Cong_DA_EA & _ & _).
	pose proof (lemma_congruenceflip _ _ _ _ Cong_AE_AD) as (Cong_EA_DA & _ & _).

	assert (Cong B C B E) as Cong_BC_BE.
	assert (eq B F \/ neq B F) as [eq_B_F|neq_B_F] by (apply Classical_Prop.classic).
	{
		(* case eq_B_F *)
		assert (Cong B E B C) as Cong_BE_BC by (rewrite eq_B_F; exact Cong_FE_FC).
		pose proof (lemma_congruencesymmetric _ _ _ _ Cong_BE_BC) as Cong_BC_BE.

		exact Cong_BC_BE.
	}
	{
		(* case neq_B_F *)
		pose proof (lemma_collinearright _ _ _ _ RightTriangle_HFC Col_H_F_B neq_B_F) as RightTriangle_BFC.
		pose proof (lemma_right_triangle_symmetric _ _ _ RightTriangle_BFC) as RightTriangle_CFB.
		destruct RightTriangle_CFB as (P & BetS_C_F_P & Cong_CF_PF & Cong_CB_PB & neq_F_B).

		pose proof (lemma_congruencetransitive _ _ _ _ _ _ Cong_FE_CF Cong_CF_PF) as Cong_FE_PF.
		pose proof (lemma_congruenceflip _ _ _ _ Cong_FE_PF) as (_ & _ & Cong_FE_FP).
		pose proof (lemma_extensionunique _ _ _ _ BetS_C_F_E BetS_C_F_P Cong_FE_FP) as eq_E_P.
		assert (Cong C B E B) as Cong_CB_EB by (rewrite eq_E_P; exact Cong_CB_PB).
		pose proof (lemma_congruenceflip _ _ _ _ Cong_CB_EB) as (Cong_BC_BE & _ & _).

		exact Cong_BC_BE.
	}
	(* asserted Cong_BC_BE *)

	pose proof (lemma_congruencetransitive _ _ _ _ _ _ Cong_BD_BC Cong_BC_BE) as Cong_BD_BE.
	pose proof (lemma_congruenceflip _ _ _ _ Cong_BD_BE) as (Cong_DB_EB & _ & _).
	pose proof (lemma_doublereverse _ _ _ _ Cong_BC_BE) as (Cong_EB_CB & _).
	pose proof (lemma_doublereverse _ _ _ _ Cong_BD_BE) as (Cong_EB_DB & _).

	assert (Cong G D G E) as Cong_GD_GE.
	destruct Col_A_B_G as [eq_A_B | [eq_A_G | [eq_B_G | [BetS_B_A_G | [BetS_A_B_G | BetS_A_G_B]]]]].
	{
		(* case eq_A_B *)
		contradict eq_A_B.
		exact neq_A_B.
	}
	{
		(* case eq_A_G *)
		assert (Cong G D G E) as Cong_GD_GE by (rewrite <- eq_A_G; exact Cong_AD_AE).
		exact Cong_GD_GE.
	}
	{
		(* case eq_B_G *)
		assert (Cong G D G E) as Cong_GD_GE by (rewrite <- eq_B_G; exact Cong_BD_BE).
		exact Cong_GD_GE.
	}
	{
		(* case BetS_B_A_G *)
		pose proof (
			axiom_5_line
			_ _ _ _
			_ _ _ _
			Cong_BA_BA
			Cong_AD_AE
			Cong_DB_EB
			BetS_B_A_G
			BetS_B_A_G
			Cong_DA_EA
			Cong_AG_AG
		) as Cong_GD_GE.
		exact Cong_GD_GE.
	}
	{
		(* case BetS_A_B_G *)
		pose proof (
			axiom_5_line
			_ _ _ _
			_ _ _ _
			Cong_AB_AB
			Cong_BD_BE
			Cong_DA_EA
			BetS_A_B_G
			BetS_A_B_G
			Cong_DB_EB
			Cong_BG_BG
		) as Cong_GD_GE.
		exact Cong_GD_GE.
	}
	{
		(* case BetS_A_G_B *)
		pose proof (
			lemma_interior5
			_ _ _ _
			_ _ _ _
			BetS_A_G_B
			BetS_A_G_B
			Cong_AG_AG
			Cong_GB_GB
			Cong_AD_AE
			Cong_BD_BE
		) as Cong_GD_GE.
		exact Cong_GD_GE.
	}
	(* asserted Cong_GD_GE *)

	pose proof (lemma_doublereverse _ _ _ _ Cong_GD_GE) as (Cong_EG_DG & _).

	assert (eq F G) as eq_F_G.
	assert (eq A G \/ neq A G) as [eq_A_G|neq_A_G] by (apply Classical_Prop.classic).
	{
		(* case eq_A_G *)
		assert (neq G B) as neq_G_B by (rewrite <- eq_A_G; exact neq_A_B).
		assert (BetS E A D) as BetS_E_A_D by (rewrite eq_A_G; exact BetS_E_G_D).

		pose proof (lemma_s_right_triangle _ _ _ _ BetS_E_G_D Cong_EG_DG Cong_EB_DB neq_G_B) as RightTriangle_EGB.
		pose proof (lemma_s_right_triangle _ _ _ _ BetS_E_A_D Cong_EA_DA Cong_EB_DB neq_A_B) as RightTriangle_EAB.
		pose proof (lemma_right_triangle_symmetric _ _ _ RightTriangle_EAB) as RightTriangle_BAE.
		pose proof (lemma_right_triangle_symmetric _ _ _ RightTriangle_EGB) as RightTriangle_BGE.

		pose proof (lemma_collinearright _ _ _ _ RightTriangle_BAE Col_B_A_J neq_J_A) as RightTriangle_JAE.

		assert (~ eq F B) as neq_F_B.
		{
			intros eq_F_B.

			assert (BetS E B C) as BetS_E_B_C by (rewrite <- eq_F_B; exact BetS_E_F_C).
			pose proof (lemma_s_right_triangle _ _ _ _ BetS_E_B_C Cong_EB_CB Cong_EA_CA neq_B_A) as RightTriangle_EBA.
			pose proof (lemma_right_triangle_leg_change _ _ _ _ RightTriangle_EBA OnRay_BA_J) as RightTriangle_EBJ.
			pose proof (lemma_right_triangle_symmetric _ _ _ RightTriangle_EBJ) as RightTriangle_JBE.
			pose proof (lemma_droppedperpendicularunique _ _ _ _ RightTriangle_JAE RightTriangle_JBE Col_J_A_B) as eq_A_B.

			contradict eq_A_B.
			exact neq_A_B.
		}

		pose proof (lemma_s_right_triangle _ _ _ _ BetS_E_F_C Cong_EF_CF Cong_EB_CB neq_F_B) as RightTriangle_EFB.
		pose proof (lemma_right_triangle_symmetric _ _ _ RightTriangle_EFB) as RightTriangle_BFE.
		pose proof (lemma_droppedperpendicularunique _ _ _ _ RightTriangle_BGE RightTriangle_BFE Col_B_G_F) as eq_G_F.
		pose proof (lemma_equalitysymmetric _ _ eq_G_F) as eq_F_G.

		exact eq_F_G.
	}
	{
		(* case neq_A_G *)
		pose proof (lemma_inequalitysymmetric _ _ neq_A_G) as neq_G_A.
		pose proof (lemma_s_right_triangle _ _ _ _ BetS_E_G_D Cong_EG_DG Cong_EA_DA neq_G_A) as RightTriangle_EGA.
		pose proof (lemma_right_triangle_symmetric _ _ _ RightTriangle_EGA) as RightTriangle_AGE.

		assert (eq A F \/ neq A F) as [eq_A_F|neq_A_F] by (apply Classical_Prop.classic).
		{
			(* case eq_A_F *)
			assert (neq F B) as neq_F_B by (rewrite <- eq_A_F; exact neq_A_B).
			assert (BetS E A C) as BetS_E_A_C by (rewrite eq_A_F; exact BetS_E_F_C).
			pose proof (lemma_s_right_triangle _ _ _ _ BetS_E_F_C Cong_EF_CF Cong_EB_CB neq_F_B) as RightTriangle_EFB.
			pose proof (lemma_s_right_triangle _ _ _ _ BetS_E_A_C Cong_EA_CA Cong_EB_CB neq_A_B) as RightTriangle_EAB.
			pose proof (lemma_right_triangle_leg_change _ _ _ _ RightTriangle_EAB OnRay_AB_K) as RightTriangle_EAK.
			pose proof (lemma_right_triangle_symmetric _ _ _ RightTriangle_EFB) as RightTriangle_BFE.
			pose proof (lemma_right_triangle_symmetric _ _ _ RightTriangle_EAB) as RightTriangle_BAE.
			pose proof (lemma_right_triangle_symmetric _ _ _ RightTriangle_EAK) as RightTriangle_KAE.

			assert (~ eq B G) as neq_B_G.
			{
				intros eq_B_G.

				assert (BetS E B D) as BetS_E_B_D by (rewrite eq_B_G; exact BetS_E_G_D).
				pose proof (lemma_s_right_triangle _ _ _ _ BetS_E_B_D Cong_EB_DB Cong_EA_DA neq_B_A) as RightTriangle_EBA.
				pose proof (lemma_right_triangle_symmetric _ _ _ RightTriangle_EBA) as RightTriangle_ABE.
				pose proof (lemma_collinearright _ _ _ _ RightTriangle_ABE Col_A_B_K neq_K_B) as RightTriangle_KBE.

				pose proof (lemma_droppedperpendicularunique _ _ _ _ RightTriangle_KBE RightTriangle_KAE Col_K_B_A) as eq_B_A.

				contradict eq_B_A.
				exact neq_B_A.
			}

			pose proof (lemma_inequalitysymmetric _ _ neq_B_G) as neq_G_B.
			pose proof (lemma_s_right_triangle _ _ _ _ BetS_E_G_D Cong_EG_DG Cong_EB_DB neq_G_B) as RightTriangle_EGB.
			pose proof (lemma_right_triangle_symmetric _ _ _ RightTriangle_EGB) as RightTriangle_BGE.
			pose proof (lemma_droppedperpendicularunique _ _ _ _ RightTriangle_BGE RightTriangle_BFE Col_B_G_F) as eq_G_F.
			pose proof (lemma_equalitysymmetric _ _ eq_G_F) as eq_F_G.

			exact eq_F_G.
		}
		{
			(* case neq_A_F *)
			pose proof (lemma_inequalitysymmetric _ _ neq_A_F) as neq_F_A.
			pose proof (lemma_s_right_triangle _ _ _ _ BetS_E_F_C Cong_EF_CF Cong_EA_CA neq_F_A) as RightTriangle_EFA.
			pose proof (lemma_right_triangle_symmetric _ _ _ RightTriangle_EFA) as RightTriangle_AFE.
			pose proof (lemma_droppedperpendicularunique _ _ _ _ RightTriangle_AFE RightTriangle_AGE Col_A_F_G) as eq_F_G.

			exact eq_F_G.
		}
	}

	assert (Cong A F A G) as Cong_AF_AG by (rewrite <- eq_F_G; exact Cong_AF_AF).
	assert (Cong B F B G) as Cong_BF_BG by (rewrite <- eq_F_G; exact Cong_BF_BF).
	assert (Cong F B G B) as Cong_FB_GB by (rewrite <- eq_F_G; exact Cong_FB_FB).

	assert (BetS E F D) as BetS_E_F_D by (rewrite eq_F_G; exact BetS_E_G_D).
	pose proof (lemma_s_onray _ _ _ _ BetS_E_F_D BetS_E_F_C) as OnRay_FD_C.
	pose proof (lemma_betweennotequal _ _ _ BetS_E_F_D) as (neq_F_D & _ & _).
	pose proof (lemma_s_onray_assert_ABB _ _ neq_F_D) as OnRay_FD_D.

	pose proof (
		lemma_fiveline
		_ _ _ _
		_ _ _ _
		Col_A_F_B
		Cong_AF_AG
		Cong_FB_GB
		Cong_AC_AD
		Cong_BC_BD
		Cong_AB_AB
		neq_A_B
	) as Cong_FC_GD.
	assert (Cong F C F D) as Cong_FC_FD by (setoid_rewrite eq_F_G at 2; exact Cong_FC_GD).

	pose proof (lemma_layoffunique _ _ _ _ OnRay_FD_C OnRay_FD_D Cong_FC_FD) as eq_C_D.

	exact eq_C_D.
Qed.

End Euclid.