(************************************************************************)
(* Copyright 2008-2010 Milad Niqui                                      *)
(* This file is distributed under the terms of the                      *)
(* GNU Lesser General Public License Version 3                          *)
(* A copy of the license can be found at                                *)
(*                  <http://www.gnu.org/licenses/lgpl-3.0.html>         *)
(************************************************************************)

(** Some examples illustrating the use of lambda-coiteration scheme.
*)

Require Import IntensionalLambdaBisimulation.
Require Import ZStreamCoalgebra.

(* Some useful fucntors. *)

(* X |------> X x X *)

Module Pairing_Functor:=product_as_Set_Functor identity_as_Set_Functor identity_as_Set_Functor.

(* X |------> B x X x X *)

Module B_Set_module_argument <: Set_module_argument.
Definition U:=B.
End B_Set_module_argument.

Module B_constant_as_Set_Functor:= constant_as_Set_Functor B_Set_module_argument.

Module B_Pairing_Functor:=product_as_Set_Functor B_constant_as_Set_Functor Pairing_Functor.

(* X |------> (B -> B) * X *)

Module B_arr_B_Set_module_argument <: Set_module_argument.
Definition U:=B->B.
End B_arr_B_Set_module_argument.

Module B_arr_B_constant_as_Set_Functor:= constant_as_Set_Functor B_arr_B_Set_module_argument.

Module B_map_S_Functor := product_as_Set_Functor B_arr_B_constant_as_Set_Functor identity_as_Set_Functor.

(*XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX*)
(* Some examples *)
(*XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX*)

Module Import Streams_Conv_LamCoiter := Lambda_Bisimulation_theory Streams_as_Weakly_Final_Coalgebra Pairing_Functor.

Lemma commutativity_Conv_fst_snd (Lambda:T_over_B_distributive) (BS: BT_coalgebroid) (x:BS.(bs_states)) :
 fst (Str.(transition) (Lam_coiterator Lambda BS x)) =
 fst( lift_B_ _ _ (Beta Lambda) (lift_B_ _ _  (lift_T_ _ _ (Lam_coiterator Lambda BS)) (bs_transition BS x))) /\
 snd (Str.(transition) (Lam_coiterator Lambda BS x)) (=)
 snd( lift_B_ _ _ (Beta Lambda) (lift_B_ _ _  (lift_T_ _ _ (Lam_coiterator Lambda BS)) (bs_transition BS x))).
Proof.
 apply -> rel_image_lift_F_Str_bisimilar_spelled.
 apply commutativity_Lam_coiterator_rel_image_lifting.
Qed.

Lemma commutativity_Conv_hd_tl (Lambda:T_over_B_distributive) (BS: BT_coalgebroid) (x:BS.(bs_states)) :
 hd (Lam_coiterator Lambda BS x) = fst (lift_B_ _ _ (Beta Lambda) (lift_B_ _ _  (lift_T_ _ _ (Lam_coiterator Lambda BS)) (bs_transition BS x))) /\
 tl (Lam_coiterator Lambda BS x) (=) snd( lift_B_ _ _ (Beta Lambda) (lift_B_ _ _  (lift_T_ _ _ (Lam_coiterator Lambda BS)) (bs_transition BS x))).
Proof.
 revert Lambda BS x.
 apply commutativity_Conv_fst_snd.
Qed.

Lemma commutativity_Conv_Cons_1 (Lambda:T_over_B_distributive) (BS: BT_coalgebroid) (x:BS.(bs_states)) :
 Lam_coiterator Lambda BS x (=) Cons (fst (lift_B_ _ _ (Beta Lambda) (lift_B_ _ _  (lift_T_ _ _ (Lam_coiterator Lambda BS)) (bs_transition BS x))))
                           (snd (lift_B_ _ _ (Beta Lambda) (lift_B_ _ _  (lift_T_ _ _ (Lam_coiterator Lambda BS)) (bs_transition BS x)))).
Proof.
 rewrite (hd_tl_id (Lam_coiterator Lambda BS x)).
 destruct (commutativity_Conv_hd_tl Lambda BS x) as [hyp_hd hyp_tl].
 constructor.
  rewrite hyp_hd; reflexivity.
  unfold tl at 1.
  match goal with
  | [ id1 : ?X1 (=) ?X2  |- _ ] => apply trans_bisimilar with X2; trivial
  end.
  apply refl_bisimilar.
Qed.

Lemma commutativity_Conv_Cons_2 (Lambda:T_over_B_distributive) (BS: BT_coalgebroid) (x:BS.(bs_states)) :
 Lam_coiterator Lambda BS x (=) Cons (fst (lift_B_ _ _ (fun s0=>Beta Lambda (lift_T_ _ _ (Lam_coiterator Lambda BS) s0)) (BS.(bs_transition) x)))
                           (snd (lift_B_ _ _ (fun s0 => Beta Lambda (lift_T_ _ _ (Lam_coiterator Lambda BS) s0)) (BS.(bs_transition) x))).
Proof.
 rewrite <- (lift_B_compose _ (T_ (Str.(states))) _).
 apply commutativity_Conv_Cons_1.
Qed.

Section Example_convolution.

(** Example:

Two types of convolution products:

<<
(x:xs) (X) (y:ys) = x.y : xs (X) (y:ys)   (+)   (x:xs) (X) ys

(x:xs) (.) (y:ys) = x.y : xs (.) (y:ys)   (+)   (x:zeros) (.) ys

zeros = 0 : zeros
>>

*)

Require Import ZArith.
Open Scope Z_scope.

Definition lambda_convolution (X:Set) (sbx:T_ (B_ X)) : B_ (T_ X) := ( fst (fst sbx)+ fst (snd sbx) , (snd (fst sbx), snd (snd sbx)) ).

Lemma lambda_convolution_natural: forall (X Y : Set) (f : X -> Y) (sbx : T_ (B_ X)),
    lambda_convolution Y (lift_T_ (B_ X) (B_ Y) (lift_B_ X Y f) sbx) =  lift_B_ (T_ X) (T_ Y) (lift_T_ X Y f) (lambda_convolution X sbx).
Proof.
 intros X Y f [[b0 x0] [b1 x1]]; trivial.
Qed.

Definition Lambda_convolution:T_over_B_distributive := Build_T_over_B_distributive lambda_convolution lambda_convolution_natural.

Definition pointwise_plus xs ys := Beta Lambda_convolution (xs,ys).

CoFixpoint enumFrom:Z->(Stream Z):=fun n => (Cons n (enumFrom (n+1))).

Definition test_str1:=enumFrom 0.
Definition test_str2:=enumFrom 10.
Fixpoint take (n:nat) (xs: Stream Z) {struct n} : List.list Z :=
  match n with
  | O => List.nil
  | S n => List.cons (hd xs) (take n (tl xs))
  end.

Lemma pointwise_plus_cofixed :forall xs ys, pointwise_plus xs ys =
                               Cons ((hd xs)+(hd ys)) (pointwise_plus (tl xs) (tl ys)).
Proof.
 intros xs ys.
 unfold pointwise_plus, Beta, Lambda_convolution, F_unfold.
 simpl; rewrite Str_unfold_unfolded.
 reflexivity.
Qed.

Section shuffle_product.
(**

<<
(x:xs) (X) (y:ys) = x.y : xs (X) (y:ys)   (+)   (x:xs) (X) ys
>>
*)

Definition coalgebra_shuffle: BT_coalgebroid :=
   Build_BT_coalgebroid (B_pow_inf * B_pow_inf)
                      (fun b0s_b1s : B_pow_inf * B_pow_inf =>
                       match b0s_b1s with
                       | (Cons x xs, Cons y ys) => (x * y, (xs, Cons y ys, (Cons x xs, ys)))
                       end).

Definition shuffle_product xs ys:=Lam_coiterator Lambda_convolution coalgebra_shuffle (xs,ys).

Lemma shuffle_product_cofixed :forall xs ys, shuffle_product xs ys (=)
                               Cons ((hd xs)*(hd ys)) (pointwise_plus (shuffle_product (tl xs) ys) (shuffle_product xs (tl ys))).
Proof.
 intros xs ys;
 assert (hyp_bis:=commutativity_Conv_Cons_1 Lambda_convolution coalgebra_shuffle (xs,ys));
 match goal with
 | [ id1 : ?X1 (=) ?X2  |- _ ] => apply trans_bisimilar with X2
 end;
 [ assumption
 |   destruct xs as [x xs']; destruct ys as [y ys']; apply refl_bisimilar
 ].
Qed.

End shuffle_product.

Section convolution_product.

(*
<<
(x:xs) (.) (y:ys) = x.y : xs (.) (y:ys)   (+)   (x:zeros) (.) ys

zeros = 0 : zeros
>>

*)

(* This works if B has 0 (it is at least a semi-ring). *)

Definition ZeroB : B :=0.

Definition zeros : B_pow_inf := Streams_as_Weakly_Final_Coalgebra.F_unfold (Streams_as_Weakly_Final_Coalgebra.Build_F_coalgebra unit (fun t=>(ZeroB,t))) tt.

Lemma zeros_cofixed: zeros = Cons ZeroB zeros.
Proof.
 unfold zeros, F_unfold; simpl; rewrite Str_unfold_unfolded at 1; trivial.
Qed.

Definition coalgebra_convolution: BT_coalgebroid :=
   Build_BT_coalgebroid (B_pow_inf * B_pow_inf)
                      (fun b0s_b1s : B_pow_inf * B_pow_inf =>
                       match b0s_b1s with
                       | (Cons x xs, Cons y ys) => (x * y, (xs, Cons y ys, (Cons x zeros, ys)))
                       end).

Definition convolution_product xs ys:=Lam_coiterator Lambda_convolution coalgebra_convolution (xs,ys).

Lemma convolution_product_cofixed :forall xs ys, convolution_product xs ys (=)
                  Cons ((hd xs)*(hd ys)) (pointwise_plus (convolution_product (tl xs) ys) (convolution_product (Cons (hd xs) zeros) (tl ys))).
Proof.
 intros xs ys;
 assert (hyp_bis:=commutativity_Conv_Cons_1 Lambda_convolution coalgebra_convolution (xs,ys));
 match goal with
 | [ id1 : ?X1 (=) ?X2  |- _ ] => apply trans_bisimilar with X2
 end;
 [ assumption
 | destruct xs as [x xs']; destruct ys as [y ys']; apply refl_bisimilar
 ].
Qed.

End convolution_product.

(*
Time Eval vm_compute in (take 10  (pointwise_plus test_str1 test_str2)).
Time Eval vm_compute in (take 10  (shuffle_product test_str1 test_str2)).
Time Eval vm_compute in (take 10  (convolution_product test_str1 test_str2)).
*)
(* [shuffle]       = 0 :: 10 :: 42 :: 132 :: 368 :: 960 :: 2400 :: 5824 :: 13824 :: 32256 :: nil *)
(* [convolution]   = 0 :: 10 :: 31 :: 64 :: 110 :: 170 :: 245 :: 336 :: 444 :: 570 :: nil *)

End Example_convolution.

(* XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX *)

Section Example_pow.
(** Example:

<<
pow = 1 : pow (+) pow
>>

*)
Open Scope Z_scope.

Definition lambda_pow := lambda_convolution.

Definition lambda_pow_natural := lambda_convolution_natural.

Definition Lambda_pow:T_over_B_distributive := Lambda_convolution.

Definition coalgebra_pow: BT_coalgebroid := Build_BT_coalgebroid unit (fun t : unit => ( 1, (t,t))).

Definition pow:=Lam_coiterator Lambda_convolution coalgebra_pow tt.

(*
Time Eval vm_compute in (take 16 pow).
*)

Lemma pow_cofixed : pow (=) Cons 1 (pointwise_plus pow pow).
Proof.
 assert (hyp_bis:=commutativity_Conv_Cons_1 Lambda_pow coalgebra_pow tt);
 match goal with
 | [ id1 : ?X1 (=) ?X2  |- _ ] => apply trans_bisimilar with X2
 end;
 [ assumption
 | apply refl_bisimilar
 ].
Qed.

End Example_pow.

Module Import Streams_map_S_LamCoiter := Lambda_Coiteration_theory Streams_as_Weakly_Final_Coalgebra B_map_S_Functor.

Lemma commutativity_map_S_fst_snd (Lambda:T_over_B_distributive) (BS: BT_coalgebroid) (x:BS.(bs_states)) :
 fst (Str.(transition) (Lam_coiterator Lambda BS x)) =
 fst( lift_B_ _ _ (Beta Lambda) (lift_B_ _ _  (lift_T_ _ _ (Lam_coiterator Lambda BS)) (bs_transition BS x))) /\
 snd (Str.(transition) (Lam_coiterator Lambda BS x)) (=)
 snd( lift_B_ _ _ (Beta Lambda) (lift_B_ _ _  (lift_T_ _ _ (Lam_coiterator Lambda BS)) (bs_transition BS x))).
Proof.
 apply -> rel_image_lift_F_Str_bisimilar_spelled.
 apply commutativity_Lam_coiterator_rel_image_lifting.
Qed.

Lemma commutativity_map_S_hd_tl (Lambda:T_over_B_distributive) (BS: BT_coalgebroid) (x:BS.(bs_states)) :
 hd (Lam_coiterator Lambda BS x) = fst (lift_B_ _ _ (Beta Lambda) (lift_B_ _ _  (lift_T_ _ _ (Lam_coiterator Lambda BS)) (bs_transition BS x))) /\
 tl (Lam_coiterator Lambda BS x) (=) snd( lift_B_ _ _ (Beta Lambda) (lift_B_ _ _  (lift_T_ _ _ (Lam_coiterator Lambda BS)) (bs_transition BS x))).
Proof.
 apply (commutativity_map_S_fst_snd Lambda BS x).
Qed.

Lemma commutativity_map_S_Cons_1 (Lambda:T_over_B_distributive) (BS: BT_coalgebroid) (x:BS.(bs_states)) :
 Lam_coiterator Lambda BS x (=) Cons (fst (lift_B_ _ _ (Beta Lambda) (lift_B_ _ _  (lift_T_ _ _ (Lam_coiterator Lambda BS)) (bs_transition BS x))))
                           (snd (lift_B_ _ _ (Beta Lambda) (lift_B_ _ _  (lift_T_ _ _ (Lam_coiterator Lambda BS)) (bs_transition BS x)))).
Proof.
 rewrite (hd_tl_id (Lam_coiterator Lambda BS x)).
 destruct (commutativity_map_S_hd_tl Lambda BS x) as [hyp_hd hyp_tl].
 constructor.
  rewrite hyp_hd; reflexivity.
  unfold tl at 1.
  match goal with
  | [ id1 : ?X1 (=) ?X2  |- _ ] => apply trans_bisimilar with X2; trivial
  end.
  apply refl_bisimilar.
Qed.

Section Example_map_S.

(** Example:

<<
nats = 0 :: map S nats
>>

*)

Open Scope Z_scope.

Definition lambda_map_S (X:Set) (sbx:T_ (B_ X)) : B_ (T_ X):=
       let (g, tmp) := sbx in let (b, x) := tmp in (g b,(g,x)).

Lemma lambda_map_S_natural: forall (X Y : Set) (f : X -> Y) (sbx : T_ (B_ X)),
    lambda_map_S Y (lift_T_ (B_ X) (B_ Y) (lift_B_ X Y f) sbx) =  lift_B_ (T_ X) (T_ Y) (lift_T_ X Y f) (lambda_map_S X sbx).
Proof.
 intros X Y f [phi [b x]]; trivial.
Qed.

Definition Lambda_map_S:T_over_B_distributive := Build_T_over_B_distributive lambda_map_S lambda_map_S_natural.

Definition coalgebra_map_S: BT_coalgebroid := Build_BT_coalgebroid unit (fun t : unit => (0,(fun x=>x+1,tt))).

Definition nats:=Lam_coiterator Lambda_map_S coalgebra_map_S tt.

(*
Time Eval vm_compute in (take 10 nats).
*)

Definition map_ g xs := Beta Lambda_map_S (g,xs).

Lemma map__cofixed :forall g xs, map_ g xs = Cons (g (hd xs)) (map_ g (tl xs)).
Proof.
 intros g xs.
 unfold map_, Beta, Lambda_map_S, F_unfold.
 simpl; rewrite Str_unfold_unfolded.
 reflexivity.
Qed.

Lemma nats_cofixed : nats (=)  Cons 0 (map_ (fun x=>x+1) nats).
Proof.
 assert (hyp_bis:=commutativity_map_S_Cons_1 Lambda_map_S coalgebra_map_S tt);
 match goal with
 | [ id1 : ?X1 (=) ?X2  |- _ ] => apply trans_bisimilar with X2
 end;
 [ assumption
 | apply refl_bisimilar
 ].
Qed.

End Example_map_S.

(* XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX *)

Module Import Streams_Fib_LamCoiter := Lambda_Coiteration_theory Streams_as_Weakly_Final_Coalgebra B_Pairing_Functor.

Lemma commutativity_Fib_fst_snd (Lambda:T_over_B_distributive) (BS: BT_coalgebroid) (x:BS.(bs_states)) :
 fst (Str.(transition) (Lam_coiterator Lambda BS x)) =
 fst( lift_B_ _ _ (Beta Lambda) (lift_B_ _ _  (lift_T_ _ _ (Lam_coiterator Lambda BS)) (bs_transition BS x))) /\
 snd (Str.(transition) (Lam_coiterator Lambda BS x)) (=)
 snd( lift_B_ _ _ (Beta Lambda) (lift_B_ _ _  (lift_T_ _ _ (Lam_coiterator Lambda BS)) (bs_transition BS x))).
Proof.
 apply -> rel_image_lift_F_Str_bisimilar_spelled.
 apply commutativity_Lam_coiterator_rel_image_lifting.
Qed.

Lemma commutativity_Fib_hd_tl (Lambda:T_over_B_distributive) (BS: BT_coalgebroid) (x:BS.(bs_states)) :
 hd (Lam_coiterator Lambda BS x) = fst (lift_B_ _ _ (Beta Lambda) (lift_B_ _ _  (lift_T_ _ _ (Lam_coiterator Lambda BS)) (bs_transition BS x))) /\
 tl (Lam_coiterator Lambda BS x) (=) snd( lift_B_ _ _ (Beta Lambda) (lift_B_ _ _  (lift_T_ _ _ (Lam_coiterator Lambda BS)) (bs_transition BS x))).
Proof.
 apply (commutativity_Fib_fst_snd Lambda BS x).
Qed.

Lemma commutativity_Fib_Cons_1 (Lambda:T_over_B_distributive) (BS: BT_coalgebroid) (x:BS.(bs_states)) :
 Lam_coiterator Lambda BS x (=) Cons (fst (lift_B_ _ _ (Beta Lambda) (lift_B_ _ _  (lift_T_ _ _ (Lam_coiterator Lambda BS)) (bs_transition BS x))))
                           (snd (lift_B_ _ _ (Beta Lambda) (lift_B_ _ _  (lift_T_ _ _ (Lam_coiterator Lambda BS)) (bs_transition BS x)))).
Proof.
 rewrite (hd_tl_id (Lam_coiterator Lambda BS x)).
 destruct (commutativity_Fib_hd_tl Lambda BS x) as [hyp_hd hyp_tl].
 constructor.
  rewrite hyp_hd; reflexivity.
  unfold tl at 1.
  match goal with
  | [ id1 : ?X1 (=) ?X2  |- _ ] => apply trans_bisimilar with X2; trivial
  end.
  apply refl_bisimilar.
Qed.

Section Example_fibonacci.

(** Example:

<<
fib = 0 :: plus_tl 1 fib fib

plus_tl x0 (x:xs) (y:ys) = x0+y :: plus_tl x xs ys
>>

*)

Open Scope Z_scope.

Definition lambda_fibonacci (X:Set) (sbx:T_ (B_ X)) : B_ (T_ X) :=
       let (b0, t0) := sbx in let (t1, t2) := t0 in let (b1, x1) := t1 in let (b2, x2) := t2 in
        (b0+b2, (b1, (x1, x2))).

Lemma lambda_fibonacci_natural: forall (X Y : Set) (f : X -> Y) (sbx : T_ (B_ X)),
    lambda_fibonacci Y (lift_T_ (B_ X) (B_ Y) (lift_B_ X Y f) sbx) =  lift_B_ (T_ X) (T_ Y) (lift_T_ X Y f) (lambda_fibonacci X sbx).
Proof.
 intros X Y f [b0 [[b1 x1] [b2 x2]]]; trivial.
Qed.

Definition Lambda_fibonacci:T_over_B_distributive := Build_T_over_B_distributive lambda_fibonacci lambda_fibonacci_natural.

Definition coalgebra_fibonacci: BT_coalgebroid := Build_BT_coalgebroid unit (fun t : unit => (0,(1,(tt,tt)))).

Definition fib:=Lam_coiterator Lambda_fibonacci coalgebra_fibonacci tt.

Definition pointwise_plus_tl x xs ys := Beta Lambda_fibonacci (x,(xs,ys)).

(*
Time Eval vm_compute in (take 20 fib).
*)

Lemma pointwise_plus_tl_cofixed :forall x xs ys, pointwise_plus_tl x xs ys =
                               Cons (x+(hd ys)) (pointwise_plus_tl (hd xs) (tl xs) (tl ys)).
Proof.
 intros x xs ys.
 unfold pointwise_plus_tl, Beta, Lambda_fibonacci, F_unfold.
 simpl; rewrite Str_unfold_unfolded.
 reflexivity.
Qed.

Lemma fib_cofixed : fib (=)  Cons 0 (pointwise_plus_tl 1 fib fib).
Proof.
 assert (hyp_bis:=commutativity_Fib_Cons_1 Lambda_fibonacci coalgebra_fibonacci tt);
 match goal with
 | [ id1 : ?X1 (=) ?X2  |- _ ] => apply trans_bisimilar with X2
 end;
 [ assumption
 | apply refl_bisimilar
 ].
Qed.

Section fib_satisfies_other_equation.

(* Proving an alternative bisimilarity for fib in two different ways. *)

Section using_cofix.

Lemma pointwise_plus_pointwise_plus_tl :forall x xs ys, pointwise_plus_tl x xs ys (=) pointwise_plus (Cons x xs) ys.
Proof.
 cofix.
 destruct xs as [x0 xs], ys as [y0 ys].
 rewrite (pointwise_plus_tl_cofixed x (Cons x0 xs) (Cons y0 ys)).
 rewrite pointwise_plus_cofixed.
 constructor; trivial.
  apply (pointwise_plus_pointwise_plus_tl x0 xs ys).
Qed.

Lemma pointwise_plus_comm :forall xs ys, pointwise_plus xs ys (=) pointwise_plus ys xs.
Proof.
 cofix.
 destruct xs as [x0 xs], ys as [y0 ys].
 rewrite pointwise_plus_cofixed.
 replace (pointwise_plus (Cons y0 ys) (Cons x0 xs)) with (Cons (y0 + x0) (pointwise_plus ys xs)); [|symmetry ; apply pointwise_plus_cofixed].
 constructor; simpl.
  auto with zarith.
  apply pointwise_plus_comm.
Qed.

Lemma fib_satisfies_other_equation : fib (=)  Cons 0 (Cons 1 (pointwise_plus (tl fib) fib)).
Proof.
 apply trans_bisimilar with (Cons 0 (pointwise_plus_tl 1 fib fib));[apply fib_cofixed|].
 constructor; trivial.
 apply trans_bisimilar with (pointwise_plus (Cons 1 fib) fib); [apply (pointwise_plus_pointwise_plus_tl 1 fib fib)|].
 rewrite pointwise_plus_cofixed.
 constructor; [trivial|simpl; apply pointwise_plus_comm].
Qed.

End using_cofix.

Section without_cofix.

Definition gamma_pointwise_plus_pointwise_plus_tl:
  let R':=fun xs ys => exists x0, exists xs0, exists ys0, xs = pointwise_plus_tl x0 xs0 ys0 /\ ys = pointwise_plus (Cons x0 xs0) ys0 in
              {s1s2 : states w * states w &  R' (fst s1s2) (snd s1s2)} ->
              Streams_as_Weakly_Final_Coalgebra.F_ {s1s2 : states w * states w &  R' (fst s1s2) (snd s1s2)}.
Proof.
 intros R' [[s1 s2] hypR'].
  simpl in hypR'.
  assert (hyp_tl:R' (tl s1) (tl s2)).
   destruct hypR' as (x & xs & ys & hyp1 & hyp2).
   subst R'; exists (hd xs); exists (tl xs); exists (tl ys).
   rewrite hyp1, hyp2, pointwise_plus_tl_cofixed, pointwise_plus_cofixed; split; simpl; trivial.
   rewrite <- hd_tl_id; trivial.
   refine (hd s1,_); exists (tl s1,tl s2); assumption.
Defined.

Lemma pointwise_plus_pointwise_plus_tl_2 :forall x xs ys, pointwise_plus_tl x xs ys (=) pointwise_plus (Cons x xs) ys.
Proof.
 intros x xs ys.
 destruct (maximal_bisimulation_is_maximal w w) as [_ hyp].
 set (R':=fun alpha beta => exists x, exists xs, exists ys, alpha = pointwise_plus_tl x xs ys /\ beta = pointwise_plus (Cons x xs) ys).
 apply (hyp R').
 assert (R'_bis:is_F_bisimulation_strong w w R') ;[|exists R'_bis; trivial].
  clear; exists (gamma_pointwise_plus_pointwise_plus_tl).
  intros [[xs ys] hyp]; split; simpl; trivial; f_equal.
  destruct hyp as (x0 & xs0 & ys0 & hyp1 & hyp2).
  simpl in hyp1,hyp2; rewrite hyp1, hyp2, pointwise_plus_cofixed, pointwise_plus_tl_cofixed; trivial.
 exists x; exists xs;exists ys; split; trivial.
Qed.

Definition gamma_pointwise_plus_comm:
  let R':=fun xs ys => exists xs0, exists ys0, xs = pointwise_plus xs0 ys0 /\ ys = pointwise_plus ys0 xs0 in
              {s1s2 : states w * states w &  R' (fst s1s2) (snd s1s2)} ->
              Streams_as_Weakly_Final_Coalgebra.F_ {s1s2 : states w * states w &  R' (fst s1s2) (snd s1s2)}.
Proof.
 intros R' [[s1 s2] hypR'].
  simpl in hypR'.
  assert (hyp_tl:R' (tl s1) (tl s2)).
   destruct hypR' as (xs & ys & hyp1 & hyp2).
   subst R'; exists (tl xs); exists (tl ys).
   rewrite hyp1, hyp2, pointwise_plus_cofixed; split; simpl; trivial.
   refine (hd s1,_); exists (tl s1,tl s2); assumption.
Defined.

Lemma pointwise_plus_comm_2 :forall xs ys, pointwise_plus xs ys (=) pointwise_plus ys xs.
Proof.
 intros xs ys.
 destruct (maximal_bisimulation_is_maximal w w) as [_ hyp].
 set (R':=fun alpha beta => exists xs, exists ys, alpha = pointwise_plus xs ys /\ beta = pointwise_plus ys xs).
 apply (hyp R').
 assert (R'_bis:is_F_bisimulation_strong w w R') ;[|exists R'_bis; trivial].
  clear; exists (gamma_pointwise_plus_comm).
  intros [[xs ys] hyp]; split; simpl; trivial; f_equal.
  destruct hyp as (xs0 & ys0 & hyp1 & hyp2).
  simpl in hyp1,hyp2; rewrite hyp1, hyp2, pointwise_plus_cofixed; simpl; auto with zarith.
 exists xs;exists ys; split; trivial.
Qed.

Lemma fib_satisfies_other_equation_2 : fib (=)  Cons 0 (Cons 1 (pointwise_plus (tl fib) fib)).
Proof.
 apply trans_bisimilar with (Cons 0 (pointwise_plus_tl 1 fib fib));[apply fib_cofixed|].
 constructor; trivial.
 apply trans_bisimilar with (pointwise_plus (Cons 1 fib) fib); [apply (pointwise_plus_pointwise_plus_tl_2 1 fib fib)|].
 rewrite pointwise_plus_cofixed.
 constructor; [trivial|simpl; apply pointwise_plus_comm_2].
Qed.

End without_cofix.

End fib_satisfies_other_equation.

End Example_fibonacci.

Module Import primitive_corecursion_Zstreams:= Primitive_Corecursion Streams_as_Weakly_Final_Coalgebra.

Import Corecursion_LamCoiter.

Lemma commutativity_Primitive_Corecursion_fst_snd (BT: BT_coalgebroid) (x:BT.(bs_states)) :
 fst (Str.(transition) (Corecursor BT x)) =
 fst (lift_B_ _ _ (prim_corec_tupling _ (Corecursor BT)) (BT.(bs_transition) x)) /\
 snd (Str.(transition) (Corecursor BT x)) (=)
 snd (lift_B_ _ _ (prim_corec_tupling _ (Corecursor BT)) (BT.(bs_transition) x)).
Proof.
 apply -> rel_image_lift_F_Str_bisimilar_spelled.
 apply commutativity_Corecursor_rel_image_lifting.
Qed.

Lemma commutativity_Primitive_Corecursion_hd_tl (BT: BT_coalgebroid) (x:BT.(bs_states)) :
 hd (Corecursor BT x) =
 fst (lift_B_ _ _ (prim_corec_tupling _ (Corecursor BT)) (BT.(bs_transition) x)) /\
 tl (Corecursor BT x) (=)
 snd (lift_B_ _ _ (prim_corec_tupling _ (Corecursor BT)) (BT.(bs_transition) x)).
Proof.
 apply (commutativity_Primitive_Corecursion_fst_snd BT x).
Qed.

Lemma commutativity_Primitive_Corecursion_Cons (BT: BT_coalgebroid) (x:BT.(bs_states)) :
 Corecursor BT x (=) Cons (fst (lift_B_ _ _ (prim_corec_tupling _ (Corecursor BT)) (BT.(bs_transition) x)))
                          (snd (lift_B_ _ _ (prim_corec_tupling _ (Corecursor BT)) (BT.(bs_transition) x))).
Proof.
 rewrite (hd_tl_id (Corecursor BT x)).
 destruct (commutativity_Primitive_Corecursion_hd_tl BT x) as [hyp_hd hyp_tl].
 constructor.
  rewrite hyp_hd; reflexivity.
  unfold tl at 1.
  match goal with
  | [ id1 : ?X1 (=) ?X2  |- _ ] => apply trans_bisimilar with X2; trivial
  end.
  apply refl_bisimilar.
Qed.

Section primitive_corecursion_example.

Section insert.

Definition coalgebra_insert: BT_coalgebroid :=
    (Build_BT_coalgebroid (B*B_pow_inf)
         (fun  pivot_xs: B * B_pow_inf =>
          match pivot_xs with
          | (pivot, Cons x0 xs' as xs) =>
              if Z_le_dec x0 pivot
              then (x0, il (B * Stream B) (pivot, xs'))
              else (pivot, ir (B * B_pow_inf) xs)
          end)).

Definition insert x ys:=Corecursor coalgebra_insert (x,ys).

Lemma insert_cofixed :forall x ys, insert x ys (=)
                      if Z_le_dec (hd ys) x
                      then Cons (hd ys) (insert x (tl ys))
                      else Cons x ys.
Proof.
 intros x ys;
 assert (hyp_bis:=commutativity_Primitive_Corecursion_Cons coalgebra_insert (x,ys));
 match goal with
 | [ id1 : ?X1 (=) ?X2  |- _ ] => apply trans_bisimilar with X2
 end;
 [ assumption
 | destruct ys as [y ys']; simpl; destruct (Z_le_dec y x); apply refl_bisimilar
 ].
Qed.

End insert.

End primitive_corecursion_example.


From Categories Require Import Essentials.Notations.
From Categories Require Import Essentials.Types.
From Categories Require Import Essentials.Facts_Tactics.
From Categories Require Import Category.Main.
From Categories Require Import Functor.Main.
From Categories Require Import Basic_Cons.Main.
From Categories Require Import Coq_Cats.Type_Cat.Type_Cat.
From Categories Require Import Coq_Cats.Type_Cat.Facts.
From Categories Require Import Algebras.Main.
From Categories Require Import Ext_Cons.Prod_Cat.Prod_Cat.
From Categories Require Import Cat.Facts.

Program Definition term_id : (Type_Cat --> (Type_Cat × Type_Cat))%functor :=
{|
  FO := fun a => (@CCC_term Type_Cat _, a);
  FA := fun a b f => (@id _ (@CCC_term Type_Cat _), f)
|}.

Definition S_nat_func : (Type_Cat --> Type_Cat)%functor :=
  ((+ᶠⁿᶜ Type_Cat _) ∘ term_id)%functor.

(* S_nat_func defined *)

Definition S_nat_alg_cat := Algebra_Cat S_nat_func.

Program Definition nat_alg : Algebra S_nat_func :=
{|
  Alg_Carrier := nat;
  Constructors :=
    fun x =>
      match x with
        | inl a => 0
        | inr n => S n
      end
|}.

(* morphism from nat_alg to another alg *)
Program Definition nat_alg_morph alg' : Algebra_Hom nat_alg alg' :=
  {|
    Alg_map :=
      fun x =>
        (fix f (n : nat) :=
        match n with
        | O => (Constructors alg') (inl tt)
        | S n' => (Constructors alg') (inr (f n'))
        end) x
  |}.

Next Obligation. (* alg_map_com *)
Proof.
  extensionality x.
  destruct x as [|[]]; cbn; trivial.
  repeat apply f_equal.
  match goal with [A : unit |- _] => destruct A; trivial end.
Qed.

Program Definition nat_alg_init : (𝟘_ S_nat_alg_cat)%object :=
  {|
    terminal := nat_alg;
    t_morph := nat_alg_morph
  |}.

Next Obligation.
Proof.
  destruct d as [algc algcons].
  destruct f as [f_morph f_com].
  destruct g as [g_morph g_com].
  apply Algebra_Hom_eq_simplify.
  extensionality x.
  simpl.
  induction x.
  {
    assert(H1 := equal_f f_com (inl tt)); cbv in H1; rewrite <- H1.
    assert(H2 := equal_f g_com (inl tt)); cbv in H2; rewrite <- H2.
    trivial.
  }
  {
    assert(H1 := equal_f f_com (inr x)); cbv in H1; rewrite <- H1.
    assert(H2 := equal_f g_com (inr x)); cbv in H2; rewrite <- H2.
    rewrite IHx.
    trivial.
  }
Qed.

CoInductive CoNat : Set :=
  | CoO : CoNat
  | CoS : CoNat -> CoNat
.

CoInductive CoNat_eq : CoNat -> CoNat -> Prop :=
  | CNOeq : CoNat_eq CoO CoO
  | CNSeq : forall (n n' : CoNat), CoNat_eq n n' -> CoNat_eq (CoS n) (CoS n')
.

Axiom CoNat_eq_eq : forall (n n' : CoNat), CoNat_eq n n' -> n = n'.

Definition S_nat_coalg_cat := @CoAlgebra_Cat Type_Cat S_nat_func.

Program Definition CoNat_coalg : @CoAlgebra Type_Cat S_nat_func :=
{|
  Alg_Carrier := CoNat;
  Constructors :=
    fun x : CoNat =>
       match x return unit + CoNat  with
       | CoO => inl tt
       | CoS x' => inr x'
       end
|}.

(* morphism from another alg to CoNat_coalg *)
Program Definition CoNat_coalg_morph coalg' : CoAlgebra_Hom CoNat_coalg coalg'
  :=
{|
  Alg_map :=
    cofix f (x : Alg_Carrier coalg') : CoNat :=
      match Constructors coalg' x return CoNat with
      | inl _ => CoO
      | inr s => CoS (f s)
      end
|}.

Next Obligation. (* coalg_map_com *)
Proof.
  extensionality x; cbn.
  destruct (Constructors coalg' x) as [x'|x']; cbn; trivial.
  replace x' with tt; trivial.
  cbn in *.
  match goal with [A : unit |- _] => destruct A; trivial end.
Qed.

(* CoNat_coalg_morph defined *)

(* The following two lemmas help go around Bug 5215. *)

Lemma inl_inr A B (x : A) (y : B) : inl x = inr y → False.
Proof.
  inversion 1.
Qed.

Lemma inr_inl A B (x : A) (y : B) : inr x = inl y → False.
Proof.
  inversion 1.
Qed.

Program Definition CoNat_alg_term : (𝟘_ S_nat_coalg_cat)%object :=
{|
  terminal := CoNat_coalg;
  t_morph := CoNat_coalg_morph
|}.

Next Obligation.
Proof.
  apply Algebra_Hom_eq_simplify.
  extensionality x; simpl.
  apply CoNat_eq_eq; revert x.
  cofix H.
  intros x.
  assert(H1 := equal_f (@Alg_map_com _ _ _ _ f) x); cbn in H1.
  assert(H2 := equal_f (@Alg_map_com _ _ _ _ g) x); cbn in H2.
  destruct (Constructors d x); destruct ((Alg_map f) x);
    destruct ((Alg_map g) x); try constructor;
      repeat match goal with
               H : _ = _ |- _ =>
               try (apply inl_inr in H || apply inr_inl in H); tauto
             end.
  inversion H1; inversion H2.
  trivial.
Qed.


Require Import ExtLib.Structures.Functor.
Require Import ExtLib.Structures.Applicative.
Require Import ExtLib.Tactics.Injection.

Set Printing Universes.

Section poption.
  Polymorphic Universe i.
  Polymorphic Variable T : Type@{i}.

  Polymorphic Inductive poption : Type@{i} :=
  | pSome : T -> poption
  | pNone.

  Global Polymorphic Instance Injective_pSome a b
  : Injective (pSome a = pSome b) :=
  { result := a = b
  ; injection := fun pf =>
                   match pf in _ = X
                         return a = match X with
                                    | pSome y => y
                                    | _ => a
                                    end
                   with
                   | eq_refl => eq_refl
                   end }.

  Global Polymorphic Instance Injective_pSome_pNone a
  : Injective (pSome a = pNone) :=
  { result := False
  ; injection := fun pf =>
                   match pf in _ = X
                         return match X with
                                | pSome y => True
                                | _ => False
                                end
                   with
                   | eq_refl => I
                   end }.

  Global Polymorphic Instance Injective_pNone_pSome a
  : Injective (pNone = pSome a) :=
  { result := False
  ; injection := fun pf =>
                   match pf in _ = X
                         return match X with
                                | pNone => True
                                | _ => False
                                end
                   with
                   | eq_refl => I
                   end }.

End poption.

Arguments pSome {_} _.
Arguments pNone {_}.

Section poption_map.
  Polymorphic Universes i j.
  Polymorphic Context {T : Type@{i}} {U : Type@{j}}.
  Polymorphic Variable f : T -> U.

  Polymorphic Definition fmap_poption (x : poption@{i} T) : poption@{j} U :=
    match x with
    | pNone => pNone@{j}
    | pSome x => pSome@{j} (f x)
    end.

  Polymorphic Definition ap_poption
              (f : poption@{i} (T -> U)) (x : poption@{i} T)
  : poption@{j} U :=
    match f , x with
    | pSome f , pSome x => pSome (f x)
    | _ , _ => pNone
    end.

End poption_map.

Polymorphic Definition Functor_poption@{i} : Functor@{i i} poption@{i} :=
{| fmap := @fmap_poption@{i i} |}.
Existing Instance Functor_poption.

Polymorphic Definition Applicative_poption@{i} : Applicative@{i i} poption@{i} :=
{| pure := @pSome@{i}
 ; ap   := @ap_poption |}.
Existing Instance Applicative_poption.


Require Import stdpp.list.
Require Import ssreflect.
From Tweetnacl Require Import Libs.Export.
From Tweetnacl Require Import ListsOp.Export.
From Tweetnacl Require Import Mid.M.
From Tweetnacl Require Import Low.Inner_M1.
From Tweetnacl Require Import Low.Outer_M1.
From Tweetnacl Require Import Low.Car25519.
Require Import Recdef.

Local Open Scope Z.

Definition M1_fix a b := outer_M_fix 16 0 a b [
  0;0;0;0;0;0;0;0;0;0;
  0;0;0;0;0;0;0;0;0;0;
  0;0;0;0;0;0;0;0;0;0;
  0].

Theorem M1_fix_eq_M1 : forall (a b:list Z),
  (length a = 16)%nat ->
  (length b = 16)%nat ->
    M1_fix a b = mult_1 a b.
Proof.
  intros.
  unfold M1_fix.
  repeat (destruct a ; tryfalse).
  repeat (destruct b ; tryfalse).
  orewrite outer_M_i_j_eq.
  change (Z.to_nat 16) with 16%nat.
  simpl.
  unfold update_M_i_j' ; simpl.
  unfold local_update_M.
  repeat rewrite <- nth_lookup.
  unfold nth.
  repeat rewrite Z.add_0_r.
  reflexivity.
Qed.

Theorem M1_fix_eq_M1Z : forall (a b:list Z),
  Zlength a = 16 ->
  Zlength b = 16 ->
    M1_fix a b = mult_1 a b.
Proof. convert_length_to_Zlength M1_fix_eq_M1. Qed.

Lemma M1_fix_length : forall (a b: list Z),
  (length a = 16)%nat ->
  (length b = 16)%nat ->
    length (M1_fix a b) = 31%nat.
Proof. intros; unfold M1_fix; rewrite outer_M_fix_length ; go. Qed.

Lemma M1_fix_Zlength : forall (a b o: list Z),
  Zlength a = 16 ->
  Zlength b = 16 ->
    Zlength (M1_fix a b) = 31.
Proof. convert_length_to_Zlength M1_fix_length. Qed.

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

Definition local_update_M2 (y:list Z) (j:nat) (x:Z) := x + 38 * (from_option id 0 (y !! j)).

Definition update_M2_i (i:nat) o := alter (local_update_M2 o (i + 16)) i o.

Lemma update_M2_id : forall k o,
  (16 <= k)%nat ->
  (length o <= 31)%nat  ->
    update_M2_i k o = o.
Proof.
  intros.
  unfold update_M2_i.
  simpl.
  unfold local_update_M2.
  orewrite (@lookup_ge_None_2 Z).
  simpl.
  apply list_alter_id ; auto.
  intros ; omega.
Qed.

Lemma update_M2_i_com: forall (i k: nat) (o: list Z),
  0 <= i ->
  0 <= k ->
  i < k ->
  i + 16 <> k ->
    update_M2_i i (update_M2_i k o) = update_M2_i k (update_M2_i i o).
Proof.
  intros.
  unfold update_M2_i.
  remember (local_update_M2 (alter (local_update_M2 o (k + 16)) k o) (i + 16)) as f.
  remember (local_update_M2 o (k + 16)) as g.
  remember (local_update_M2 (alter (local_update_M2 o (i + 16)) i o) (k + 16)) as m.
  remember (local_update_M2 o (i + 16)) as n.
  unfold local_update_M2 in *.
  move: Heqf ; orewrite (@list_lookup_alter_ne Z) => Heqf.
  move: Heqm ; orewrite (@list_lookup_alter_ne Z) => Heqm.
  assert(g = m) by go.
  assert(f = n) by go.
  rewrite <- H3.
  rewrite <- H4.
  rewrite list_alter_commute ; go.
Qed.

Function M2_fix (i : Z) (o : list Z) {measure Z.to_nat i} : list Z :=
  if (i <=? 0) then o else M2_fix (i - 1) (update_M2_i (Z.to_nat (i - 1)) o).
Proof. intros. apply Z2Nat.inj_lt ; move: teq ; rewrite Z.leb_gt => teq; omega. Qed.

Fixpoint M2_fix' (i : nat) (o : list Z) := match i with
  | 0%nat => o
  | S p => M2_fix' p (update_M2_i p o)
end.

Function M2_fix'' (i : Z) (o : list Z) {measure Z.to_nat i} : list Z :=
  if (i <=? 0) then o else update_M2_i (Z.to_nat (i - 1)) (M2_fix'' (i - 1) o).
Proof. intros. apply Z2Nat.inj_lt ;  move: teq ; rewrite Z.leb_gt => teq; omega. Qed.

Lemma M2_fix''_length : forall k l, 0 <= k -> length (M2_fix'' k l) = length l.
Proof.
  intros k l Hk; gen l.
  apply (natlike_ind (fun k => ∀ l : list ℤ, length (M2_fix'' k l) = length l)) ; try omega.
  intros ; rewrite M2_fix''_equation ; go.
  clear k Hk; intros i Hi iHi l.
  change (Z.succ i) with (i + 1).
  rewrite M2_fix''_equation.
  destruct (i + 1 <=? 0) ; auto.
  replace (i + 1 - 1) with (i) by omega.
  unfold update_M2_i.
  rewrite alter_length.
  apply iHi.
Qed.

Lemma M2_fix''_com : forall (i k : Z) (o : list Z),
  (length o <= 31)%nat ->
  0 <= i ->
  i <= k ->
  k <= 16 -> (*let us hope this will be enough ! *)
    update_M2_i (Z.to_nat k) (M2_fix'' i o) = M2_fix'' i (update_M2_i (Z.to_nat k) o).
Proof.
  intros i k o Ho Hi.
  gen k o.
  apply (natlike_ind (fun i => (∀ (k : ℤ) (o : list ℤ),
(length o ≤ 31)%nat
→ i ≤ k
→ k ≤ 16
    → update_M2_i (Z.to_nat k) (M2_fix'' i o) = M2_fix'' i (update_M2_i (Z.to_nat k) o)))) ; try omega.
  - intros ; rewrite M2_fix''_equation ; symmetry ; rewrite M2_fix''_equation ; auto.
  - clear Hi i ; intros i Hi iHi k o Ho Hik Hkk ; sort.
    change (Z.succ i) with (i + 1) in *.
    rewrite M2_fix''_equation ; symmetry ; rewrite M2_fix''_equation.
    flatten.
    replace (i + 1 - 1) with (i) by omega.
    rewrite <- iHi by omega.
    apply Z_le_lt_eq_dec in Hkk.
    destruct Hkk.
    rewrite update_M2_i_com ; repeat orewrite Z2Nat.id.
    reflexivity.
    subst k.
    change (Z.to_nat 16) with 16%nat.
    repeat rewrite (update_M2_id 16);
    unfold update_M2_i ; try rewrite alter_length ; try rewrite M2_fix''_length; try omega.
    reflexivity.
Qed.

Lemma update_M2_rec': forall (u:Z) (i:nat) (l:list Z),
  (update_M2_i (S i) (u::l)) = u::update_M2_i i l.
Proof.
  intros.
  unfold update_M2_i.
  unfold list_alter.
  reflexivity.
Qed.

Lemma update_M2_0: forall (x:Z) (l:list Z),
  (update_M2_i 0 (x::l)) =  x + 38 * (from_option id 0 ((x::l) !! 16%nat)) :: l.
Proof.
  intros.
  unfold update_M2_i.
  unfold list_alter.
  unfold local_update_M2.
  reflexivity.
Qed.

Lemma M2_fix_eq: forall (i: Z) (o: list Z),
  0 <= i ->
    M2_fix i o = M2_fix' (Z.to_nat i) o.
Proof.
  intros.
  gen i o.
  apply (natlike_ind (fun i => ∀ o : list ℤ, M2_fix i o = M2_fix' (Z.to_nat i) o)).
  intros ; rewrite M2_fix_equation ; auto.
  intros i Hi iHi o.
  change (Z.succ i) with (i + 1).
  replace (Z.to_nat (i + 1)) with (S (Z.to_nat i)).
  2: rewrite Z2Nat.inj_add ; try replace (Z.to_nat 1) with 1%nat by reflexivity ; omega.
  rewrite M2_fix_equation.
  flatten.
  apply Zle_bool_imp_le in Eq ; omega. (* silly case *)
  apply Z.leb_gt in Eq.
  replace (i + 1 - 1) with i by omega.
  rewrite iHi; go.
Qed.

Lemma M2_fix_eq'': forall (i: Z) (o: list Z),
  0 <= i->
  (length o <= 31)%nat ->
  i <= 16 ->
    M2_fix i o = M2_fix'' i o.
Proof.
  intros i o Hi. gen o.
  eapply (natlike_ind (fun i => ∀ o : list ℤ, (length o ≤ 31)%nat → i ≤ 16 → M2_fix i o = M2_fix'' i o)) ; try omega.
  - intros ; rewrite M2_fix_equation ; rewrite M2_fix''_equation ;  auto.
  - clear i Hi; intros i Hi iHi o Ho Hii.
    change (Z.succ i) with (i + 1) in *.
    rewrite M2_fix_equation.
    rewrite M2_fix''_equation.
    flatten.
    replace (i + 1 - 1) with i by omega.
    rewrite iHi ; try omega.
    2: unfold update_M2_i ; rewrite alter_length ; omega.
    rewrite M2_fix''_equation.
    symmetry; rewrite M2_fix''_equation.
    flatten.
    apply Z.leb_gt in Eq ; apply Z.leb_gt in Eq0.
    rewrite <- M2_fix''_com by omega.
    rewrite <- update_M2_i_com ; repeat rewrite Z2Nat.id ; try omega.
    reflexivity.
Qed.

Lemma M2_fix_0 : forall (o: list Z), (M2_fix 0 o) = o.
Proof. intro o ; rewrite M2_fix_equation ; flatten ; compute in Eq ; tryfalse. Qed.

Lemma M2_fix_eq_step : forall (i: Z) (o: list Z),
  (length o <= 31)%nat ->
  0 <= i->
  i <= 16 ->
    update_M2_i (Z.to_nat (i + 1)) (M2_fix i o) = M2_fix i (update_M2_i (Z.to_nat (i + 1)) o).
Proof.
  intros.
  orewrite M2_fix_eq''.
  rewrite M2_fix_eq'' ; try (unfold update_M2_i ; rewrite alter_length) ; try omega.
  apply Z_le_lt_eq_dec in H1.
  destruct H1.
  rewrite M2_fix''_com; try omega ; reflexivity.
  subst i.
  change (Z.to_nat (16 + 1)) with 17%nat.
  repeat rewrite (update_M2_id 17) ; go.
  rewrite M2_fix''_length ; omega.
Qed.

Lemma M2_fix_step : forall (i: Z) (o: list Z),
  (length o <= 31)%nat ->
  0 <= i->
  i <= 16 ->
    update_M2_i (Z.to_nat (i)) (M2_fix i o) = M2_fix (i + 1) o.
Proof.
  intros.
  symmetry.
  rewrite M2_fix_equation.
  flatten.
  apply Zle_bool_imp_le in Eq ; omega. (* silly case *)
  replace (i + 1 - 1) with i by omega.
  repeat (rewrite M2_fix_eq'' ; try (unfold update_M2_i ; rewrite alter_length); try omega).
  rewrite M2_fix''_com; try omega.
  reflexivity.
Qed.

Lemma M2_fix_stepZ : forall (i: Z) (o: list Z),
  Zlength o <= 31 ->
  0 <= i->
  i <= 16 ->
    update_M2_i (Z.to_nat (i)) (M2_fix i o) = M2_fix (i + 1) o.
Proof. convert_length_to_Zlength M2_fix_step. Qed.

Lemma M2_fix_length : forall (i: Z) (o: list Z),
  0 <= i ->
    length (M2_fix i o) = length o.
Proof.
  intros i l Hi; gen l.
  apply (natlike_ind (fun i => ∀ l : list ℤ, length (M2_fix i l) = length l)) ; try omega.
  - intros ; rewrite M2_fix_0 ; go.
  - clear i Hi; intros i Hi iHi l.
  change (Z.succ i) with (i + 1).
  rewrite M2_fix_equation.
  destruct (i + 1 <=? 0) ; auto.
  replace (i + 1 - 1) with (i) by omega.
  rewrite iHi.
  unfold update_M2_i.
  rewrite alter_length.
  auto.
Qed.

Lemma M2_fix_Zlength : forall (i: Z) (o: list Z),
  0 <= i ->
    Zlength (M2_fix i o) = Zlength o.
Proof. convert_length_to_Zlength M2_fix_length. Qed.

Theorem M2_fix_eq_M2 : forall (a:list Z),
  (length a = 31)%nat ->
  M2_fix 15 a = mult_2 a.
Proof.
intros.
repeat (destruct a ; tryfalse).
unfold mult_2 ; simpl.

repeat match goal with
  | [ |- context[Z.to_nat ?b] ] => change (Z.to_nat b) with b%nat
  | _ => progress unfold update_M2_i ; simpl
  | _ => progress unfold local_update_M2 ; repeat rewrite <- nth_lookup ; unfold nth
  | _ => reflexivity
  | _ => rewrite M2_fix_equation ; simpl
end.

Qed.

Theorem M2_fix_eq_M2Z : forall (a:list Z),
  Zlength a = 31 ->
  M2_fix 15 a = mult_2 a.
Proof. convert_length_to_Zlength M2_fix_eq_M2. Qed.

Theorem M2_fix_drop : forall i (a: list Z),
  0 <= i < 16 ->
  (length a = 31)%nat ->
  drop 16 (M2_fix i a) = drop 16 a.
Proof.
  intros i a Hi Hla.
  repeat (destruct a ; tryfalse).
  gen_i H i ; simpl M2_fix ; rewrite M2_fix_eq ; try omega; change_Z_to_nat ; simpl ; reflexivity.
Qed.

Theorem M2_fix_dropZ : forall i (a: list Z),
  0 <= i < 16 ->
  Zlength a = 31 ->
  drop 16 (M2_fix i a) = drop 16 a.
Proof. convert_length_to_Zlength M2_fix_drop. Qed.

Lemma M2_fix_bounds : forall m1 n1 p q (a: list Z) i,
  0 <= i ->
  i < 16 ->
  (fun x => m1 <= x <= n1) 0 ->
  Forall (fun x => m1 <= x <= n1) a ->
  (length a = 31)%nat ->
  p = m1 + 38 * m1 ->
  q = n1 + 38 * n1 ->
  Forall (fun x => p <= x <= q) (M2_fix i a).
Proof.
  intros m1 n1 p q a i Hi Hi' Hm1n1 Ha Hla Hp Hq.
  simpl in Hm1n1.
  assert(Hpm: p <= m1) by omega.
  assert(Hqn: n1 <= q) by omega.
  repeat (destruct a ; tryfalse).
  gen_i H i ; rewrite M2_fix_eq ; try omega; change_Z_to_nat ; simpl ; repeat match goal with
  | [H : context[Forall] |- _ ] => apply Forall_cons in H ; destruct H
  end;
  repeat match goal with
  | [ |- update_M2_i (S _) _ ] => rewrite update_M2_rec' ; simpl
  | [ |- context[local_update_M2]] => unfold local_update_M2 ; simpl
  | [ |- update_M2_i 0 (_ :: _) ] => rewrite update_M2_0 ; simpl
  | [ |- Forall _ [] ] => go
  | [ |- _ ≤ _ ∧ _ ≤ _ ] => omega
  | [ |- Forall _ _ ] => apply Forall_cons_2
  end.
Qed.

Lemma M2_fix_Zbounds : forall m1 n1 p q (a: list Z) i,
  0 <= i ->
  i < 16 ->
  (fun x => m1 <= x <= n1) 0 ->
  Forall (fun x => m1 <= x <= n1) a ->
  Zlength a = 31 ->
  p = m1 + 38 * m1 ->
  q = n1 + 38 * n1 ->
  Forall (fun x => p <= x <= q) (M2_fix i a).
Proof. convert_length_to_Zlength M2_fix_bounds; eapply M2_fix_bounds ; go. Qed.

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

Function M3_fix {T} (i : Z) (from : list T) (to : list T) {measure Z.to_nat i} : list T :=
  if (i <=? 0) then to else
    match from, to with
      | [], _  => to
      | _ , [] => []
      | f::from, t::to => f :: M3_fix (i - 1) from to
    end.
Proof. intros. apply Z2Nat.inj_lt ; move: teq ; rewrite Z.leb_gt => teq; omega. Qed.

Fixpoint M3_fix' {T} (i : nat) (from : list T) (to : list T) := match i, from, to with
  | 0%nat, _, to => to
  | _, [], to => to
  | _, _, [] => []
  | S p, f::from, t::to => f :: M3_fix' p from to
end.

Lemma M3_fix_eq : forall T (i:Z) (f t:list T), 0 <= i ->  M3_fix T i f t = M3_fix' (Z.to_nat i) f t.
Proof.
  intros T i f t Hi.
  gen i f t.
  apply (natlike_ind (fun i => ∀ f t : list T, M3_fix T i f t = M3_fix' (Z.to_nat i) f t)).
  intros; rewrite M3_fix_equation ; auto.
  intros i Hi iHi from to.
  change (Z.succ i) with (i + 1).
  replace (Z.to_nat (i + 1)) with (S (Z.to_nat i)).
  2: rewrite Z2Nat.inj_add ; try replace (Z.to_nat 1) with 1%nat by reflexivity ; omega.
  rewrite M3_fix_equation.
  flatten ;
  try (apply Zle_bool_imp_le in Eq ; omega); (* silly case *)
  apply Z.leb_gt in Eq ; replace (i + 1 - 1) with i by omega ; go.
Qed.

Lemma M3_fix_0 : forall T (f t:list T),
    M3_fix T 0 f t = t.
Proof.
  intros T f t.
  rewrite M3_fix_equation.
  destruct (0 <=? 0) eqn:H ; [| compute in H]; go.
Qed.

Lemma M3_fix_step : forall T (i:Z) (f t:list T) (d:T),
  0 <= i < 16 ->
  length t = 16%nat ->
  length f = 31%nat ->
    M3_fix T (i + 1) f t = ((take (Z.to_nat i) (M3_fix T i f t)) ++ [nth (Z.to_nat i) f d]) ++ drop (Z.to_nat i + 1) (M3_fix T i f t).
Proof.
intros.
do 16 (destruct f; tryfalse).
rename f into t16.
rename t into f.
repeat (destruct f; tryfalse).
repeat rewrite M3_fix_eq ; try omega.
rewrite Z2Nat.inj_add ; try omega.
remember ((Z.to_nat i)%nat) as j.
replace (Z.to_nat 1) with 1%nat by reflexivity.
replace (j + 1)%nat with (S j)%nat by omega.
assert((j < 16)%nat).
rewrite Heqj.
change (16%nat) with (Z.to_nat 16).
apply Z2Nat.inj_lt ; omega.
simpl; flatten ; simpl ; try reflexivity.
simpl.
exfalso.
omega.
Qed.

Lemma M3_fix_stepZ : forall T (i:Z) (f t:list T) (d:T),
  0 <= i < 16 ->
  Zlength t = 16 ->
  Zlength f = 31 ->
    M3_fix T (i + 1) f t = ((take (Z.to_nat i) (M3_fix T i f t)) ++ [nth (Z.to_nat i) f d]) ++ drop (Z.to_nat i + 1) (M3_fix T i f t).
Proof. convert_length_to_Zlength M3_fix_step. Qed.

Theorem M3_fix_eq_M3 : forall T (from:list Z) (to:list T) (f : Z -> T),
  (length from = 31)%nat ->
  (length to = 16)%nat ->
  M3_fix T 16 (map f from) to = map f (mult_3 from).
Proof.
  intros.
  repeat (destruct from ; tryfalse).
  repeat (destruct to ; tryfalse).
  orewrite M3_fix_eq.
  change (Z.to_nat 16) with 16%nat.
  reflexivity.
Qed.

Theorem M3_fix_eq_M3' : forall T (from:list Z) (to:list T) (f : Z -> T),
  (length from = 31)%nat ->
  (length to = 16)%nat ->
  M3_fix T 16 (map f from) to = map f (mult_3 from).
Proof.
  intros.
  repeat (destruct from ; tryfalse).
  repeat (destruct to ; tryfalse).
  orewrite M3_fix_eq.
  change (Z.to_nat 15) with 15%nat.
  simpl.
  unfold mult_3.
  simpl.
  reflexivity.
Qed.

Theorem M3_fix_eq_M3Z : forall T (from:list Z) (to:list T) (f : Z -> T),
  Zlength from = 31 ->
  Zlength to = 16 ->
  M3_fix T 16 (map f from) to = map f (mult_3 from).
Proof. convert_length_to_Zlength M3_fix_eq_M3. Qed.

Lemma M3_fix_length: forall T (i: Z)  (f t : list T),
  length t = length (M3_fix T i f t).
Proof. intros ; gen i f ; induction t ; intros ; rewrite M3_fix_equation; flatten; go. Qed.

Lemma M3_fix_Zlength: forall T (i: Z) (f t: list T),
  Zlength t = Zlength (M3_fix T i f t).
Proof. intros; repeat rewrite Zlength_correct; rewrite <- M3_fix_length ; reflexivity. Qed.

Close Scope Z.


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

Set Implicit Arguments.

#[local] Reserved Notation "'⟨' x '⟩₀'" (at level 0, x at level 200, format "⟨ x ⟩₀").
#[local] Reserved Notation "'⟨' y | t '⟩₁'" (at level 0, t at level 200, format "⟨ y | t ⟩₁").

(** Unary trees *)
Inductive utree (X Y : Type) :=
  | utree_leaf : X -> utree X Y
  | utree_node : Y -> utree X Y -> utree X Y.

Arguments utree_leaf {X Y}.
Arguments utree_node {X Y}.

Module utree_notations.

  Notation "⟨ x ⟩₀" := (utree_leaf x).
  Notation "⟨ y | t ⟩₁" := (utree_node y t).

End utree_notations.

Import utree_notations.


From HoTT Require Export HoTT.
From HoTT Require Import Pointed HIT.Pushout.
Require Import vK.WedgeSum Circ HitTactics.

Definition concatD {A : Type} {P : A -> Type} {a b c : A} (f : a = b) (g : b = c) {x : P a} {y : P b} {z : P c} : forall (p : f # x = y) (q : g # y = z), (f @ g) # x = z.
Proof.
destruct f,g. exact concat.
  (* match f, g return (forall (p : f # x = y) (q : g # y = z), (f @ g) # x = z) *)
  (* with idpath,idpath => fun p q => p @ q end. *)
(* exact (p @ q). *)
Defined.
Notation "p @D q" := (concatD _ _ p%path q%path) (at level 20) : path_scope.
(* TODO: See exercise 6.1 *)

Definition apD2 {A : Type} {C : A -> Type} (f : forall x, C x)
  {x x' : A} {p p': x = x'}
  (θ : p = p') : (transport (fun q => q # f x = f x') θ (apD f p)) = (apD f p').
Proof.
induction θ. reflexivity.
Defined.

Lemma apD_concat {A : Type} {C : A -> Type} (f : forall x, C x)
  {x y z : A} (p : x = y) (q : y = z) :
  apD f (p @ q) = apD f p @D apD f q.
Proof. induction p, q; simpl. reflexivity. Defined.
(* TODO: see apD_pp *)

Notation ap2 := ap02.
Notation ap2_concat := ap02_pp.

Module Export T.
Private Inductive T : Type0 :=
| b : T.
Axiom loop1 : b = b.
Axiom loop2 : b = b.
Axiom surf : loop1 @ loop2 = loop2 @ loop1.

Section T_ind.
  Variable P : T -> Type.
  Variable b' : P b.
  Variable p1 : loop1 # b' = b'.
  Variable p2 : loop2 # b' = b'.
  Variable s  : transport (fun p => p # b' = b') surf (p1 @D p2) = p2 @D p1.

  Definition T_ind : forall x : T, P x := fun x =>
    match x return (_ -> _ -> _ -> P x) with
    | b => fun _ _ _ => b'
    end p1 p2 s.

  Axiom T_ind_beta_loop1 : apD T_ind loop1 = p1.
  Axiom T_ind_beta_loop2 : apD T_ind loop2 = p2.

  (* To formulate the computational rule for the surface we need to
     transport the LHS along some path. This is due to the fact that
     [apD_concat] and [T_ind_beta_loop_a/b] are only propositional
     equalities. *)
  Definition γ :
    (transport (fun q => q # b' = b') surf (apD T_ind (loop1 @ loop2)) = apD T_ind (loop2 @ loop1))
     =
    (transport (fun q => q # b' = b') surf (p1 @D p2) = p2 @D p1).
  Proof.
  etransitivity.
  { apply (ap (fun z => transport (fun q => q # b' = b') surf z = apD T_ind (loop2 @ loop1)) (apD_concat _ loop1 loop2)). }
  etransitivity.
  { apply (ap (fun z => transport (fun q => q # b' = b') surf (_ @D _) = z) (apD_concat _ loop2 loop1)). }
  etransitivity.
  { apply (ap (fun z => transport (fun q => q # b' = b') surf (z @D _) = _ @D z) T_ind_beta_loop1). }
  { apply (ap (fun z => transport (fun q => q # b' = b') surf (_ @D z) = z @D _) T_ind_beta_loop2). }
  Defined.

  Axiom T_ind_beta_surf : transport idmap γ (apD2 T_ind surf) = s.

End T_ind.

Section T_rec.
  Variable P : Type.
  Variable b' : P.
  Variable p1 p2 : b' = b'.
  Variable s : p1 @ p2 = p2 @ p1.

  Definition T_rec : T -> P. (* := fun x => *)
    (* match x return (_ -> _ -> _ -> P) with *)
    (* | baseT => fun _ _ _ => b' *)
    (* end p1 p2 s. *)
Proof.
  simple refine (T_ind (fun _ => P) b' _ _ _); simpl.
  - refine (transport_const _ _ @ p1).
  - refine (transport_const _ _ @ p2).
  - refine (transport_paths_FlFr surf _ @ _).
    refine (ap (fun z => _ @ z) (ap_const _ _) @ _).
    refine ((concat_p1 _) @ _).

rewrite <- T_ind_beta_loop1.
Defined.

  Axiom T_rec_beta_loop1 : ap T_rec loop1 = p1.
  Axiom T_rec_beta_loop2 : ap T_rec loop2 = p2.

  Definition γrec :
    (ap T_rec (loop1 @ loop2) = ap T_rec (loop2 @ loop1))
    =
    (p1 @ p2 = p2 @ p1).
  Proof.
  etransitivity.
  { apply (ap (fun z => z = _) (ap_pp _ _ _)). }
  etransitivity.
  { apply (ap (fun z => _ = z) (ap_pp _ _ _)). }
  etransitivity.
  { apply (ap (fun z => (z @ _) = (_ @ z)) T_rec_beta_loop1). }
  { apply (ap (fun z => (_ @ z) = (z @ _)) T_rec_beta_loop2). }
  Defined.

  Axiom T_rec_beta_surf : transport idmap γrec (ap2 T_rec surf) = s.
End T_rec.
End T.

Instance Torus_recursion : HitRecursion T := {
  indTy := _; recTy := _;
  H_inductor := T_ind; H_recursor := T_rec }.

Section torus_subdivision.

Definition i1 : eight -> T.
Proof.
hrecursion.
- exact b.
- exact loop1.
- exact loop2.
Defined.

Definition i2 : Unit -> T := fun _ => b.

Definition e_circ : S1 -> eight.
Proof.
hrecursion.
- exact base8.
- exact (eight.loop1 @ eight.loop2 @ eight.loop1^ @ eight.loop2^).
Defined.

Definition T' : Type.
Proof.
  refine (@pushout S1 Unit eight _ _).
  - exact (fun _ => tt).
  - exact e_circ.
Defined.

Definition i : T' -> T.
Proof.
simple refine (pushout_rec T (sum_ind _ i2 i1) _).
hrecursion.
- cbv. reflexivity.
- rewrite transport_paths_FlFr. hott_simpl.
rewrite ap_compose.
rewrite S1_rec_beta_loop.
rewrite ?ap_pp. rewrite ?ap_V.
rewrite ?Eight_rec_beta_loop1.
rewrite ?Eight_rec_beta_loop2.
rewrite surf. hott_simpl.
Defined.

Definition j : T -> T'.
Proof.
hrecursion.
- exact (push  base).
- simple refine (ap pushr _). apply loop.
-
- rewrite <- (ap_pp (push o inr) eight.loop1 eight.loop2).
  rewrite <- (ap_pp (push o inr) eight.loop2 eight.loop1).

Defined.
End torus_subdivision.


(* This file is generated by Why3's Coq driver *)
(* Beware! Only edit allowed sections below    *)
Require Import BuiltIn.
Require BuiltIn.

(* Why3 assumption *)
Inductive t (a:Type) :=
  | T : a -> t a.
Axiom t_WhyType : forall (a:Type) {a_WT:WhyType a}, WhyType (t a).
Existing Instance t_WhyType.
Implicit Arguments T [[a]].

(* Why3 assumption *)
Inductive u (a:Type) :=
  | U1 : (t (u a)) -> u a
  | U2 : u a.
Axiom u_WhyType : forall (a:Type) {a_WT:WhyType a}, WhyType (u a).
Existing Instance u_WhyType.
Implicit Arguments U1 [[a]].
Implicit Arguments U2 [[a]].

Parameter f: forall {a:Type} {a_WT:WhyType a}, a.

(* Why3 assumption *)
Inductive v {a:Type} {a_WT:WhyType a}: (u a) -> Prop :=
  | v1 : forall (c:(u a)), (v (U1 (T c)))
  | v2 : (v (f : (u a))).

Parameter id: forall {a:Type} {a_WT:WhyType a}, a -> a.

Axiom ax : forall {a:Type} {a_WT:WhyType a}, forall (x:a), ((id x) = x).

(* Why3 goal *)
Theorem g1 : forall {a:Type} {a_WT:WhyType a}, exists x:a, ((id x) = x).
(* Why3 intros a a_WT. *)
Proof.
intros a a_WT.
exists why_inhabitant.
apply ax.
Qed.


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

Require Export formes_complexes.
Set Implicit Arguments.
Unset Strict Implicit.

Lemma Rinv_calcul :
 forall x y : R, x <> 0 :>R -> x * y = 1 :>R -> / x = y :>R.
intros.
apply Rmult_eq_reg_l with x; auto.
rewrite H0; auto with real.
Qed.
Hint Resolve Rinv_calcul: real.
Parameter Cplus : C -> C -> C.

Axiom
  Cplus_def :
    forall (z1 z2 : C) (x1 y1 x2 y2 : R),
    z1 = cons_cart x1 y1 ->
    z2 = cons_cart x2 y2 -> Cplus z1 z2 = cons_cart (x1 + x2) (y1 + y2).

Lemma Cplus_algebrique :
 forall x1 y1 x2 y2 : R,
 Cplus (cons_cart x1 y1) (cons_cart x2 y2) = cons_cart (x1 + x2) (y1 + y2).
intros.
rewrite
 (Cplus_def (z1:=cons_cart x1 y1) (z2:=cons_cart x2 y2) (x1:=x1) (y1:=y1)
    (x2:=x2) (y2:=y2)); auto.
Qed.
Hint Resolve Cplus_algebrique: geo.

Lemma Cplus_commutative : forall z1 z2 : C, Cplus z1 z2 = Cplus z2 z1.
intros.
elim existence_parties_relles_imaginaires with (z := z1); intros x1 H; elim H;
 intros y1 H0; try clear H; try exact H0.
elim existence_parties_relles_imaginaires with (z := z2); intros x2 H; elim H;
 intros y2 H1; try clear H; try exact H1.
rewrite (Cplus_def (z1:=z1) (z2:=z2) (x1:=x1) (y1:=y1) (x2:=x2) (y2:=y2));
 auto.
rewrite (Cplus_def (z1:=z2) (z2:=z1) (x1:=x2) (y1:=y2) (x2:=x1) (y2:=y1));
 auto.
replace (x1 + x2) with (x2 + x1); [ idtac | ring ].
replace (y1 + y2) with (y2 + y1); [ auto | ring ].
Qed.

Lemma Cplus_z_zeroC : forall z : C, Cplus z zeroC = z.
intros.
elim existence_parties_relles_imaginaires with (z := z); intros x1 H; elim H;
 intros y1 H0; try clear H; try exact H0.
rewrite (Cplus_def (z1:=z) (z2:=zeroC) (x1:=x1) (y1:=y1) (x2:=0) (y2:=0));
 auto.
replace (x1 + 0) with x1; [ idtac | ring ].
replace (y1 + 0) with y1; [ auto | ring ].
Qed.

Lemma Cplus_associative :
 forall z1 z2 z3 : C, Cplus z1 (Cplus z2 z3) = Cplus (Cplus z1 z2) z3.
intros.
elim existence_parties_relles_imaginaires with (z := z1); intros x1 H; elim H;
 intros y1 H0; try clear H; try exact H0.
elim existence_parties_relles_imaginaires with (z := z2); intros x2 H; elim H;
 intros y2 H1; try clear H; try exact H1.
elim existence_parties_relles_imaginaires with (z := z3); intros x3 H; elim H;
 intros y3 H2; try clear H; try exact H2.
rewrite (Cplus_def (z1:=z1) (z2:=z2) (x1:=x1) (y1:=y1) (x2:=x2) (y2:=y2));
 auto.
rewrite
 (Cplus_def (z1:=cons_cart (x1 + x2) (y1 + y2)) (z2:=z3) (x1:=
    x1 + x2) (y1:=y1 + y2) (x2:=x3) (y2:=y3)); auto.
rewrite (Cplus_def (z1:=z2) (z2:=z3) (x1:=x2) (y1:=y2) (x2:=x3) (y2:=y3));
 auto.
rewrite
 (Cplus_def (z1:=z1) (z2:=cons_cart (x2 + x3) (y2 + y3)) (x1:=x1) (y1:=y1)
    (x2:=x2 + x3) (y2:=y2 + y3)); auto.
replace (x1 + (x2 + x3)) with (x1 + x2 + x3); [ idtac | ring ].
replace (y1 + (y2 + y3)) with (y1 + y2 + y3); [ auto | ring ].
Qed.
Parameter Copp : C -> C.

Definition Cminus x y := Cplus x (Copp y).

Axiom
  Copp_def :
    forall (z : C) (x y : R),
    z = cons_cart x y -> Copp z = cons_cart (- x) (- y).

Lemma Copp_algebrique :
 forall x y : R, Copp (cons_cart x y) = cons_cart (- x) (- y).
intros.
rewrite (Copp_def (z:=cons_cart x y) (x:=x) (y:=y)); auto.
Qed.

Lemma Cplus_z_oppz : forall z : C, Cplus z (Copp z) = zeroC.
intros.
elim existence_parties_relles_imaginaires with (z := z); intros x1 H; elim H;
 intros y1 H0; try clear H; try exact H0.
unfold zeroC in |- *; rewrite H0; rewrite Copp_algebrique;
 rewrite Cplus_algebrique.
replace (x1 + - x1) with 0; [ idtac | ring ].
replace (y1 + - y1) with 0; [ auto | ring ].
Qed.
Hint Resolve Cplus_z_oppz Copp_algebrique Cplus_commutative Cplus_z_zeroC:
  geo.
Parameter Cmult : C -> C -> C.

Axiom
  Cmult_module : forall z z' : C, module (Cmult z z') = module z * module z'.

Axiom
  Cmult_argument :
    forall z z' : C,
    z <> zeroC ->
    z' <> zeroC -> argument (Cmult z z') = plus (argument z) (argument z').

Lemma Cmult_zeroC_z : forall z : C, Cmult zeroC z = zeroC.
intros.
apply module_nul_zeroC.
rewrite Cmult_module; rewrite module_zeroC; ring.
Qed.

Lemma Cmult_z_zeroC : forall z : C, Cmult z zeroC = zeroC.
intros.
apply module_nul_zeroC.
rewrite Cmult_module; rewrite module_zeroC; ring.
Qed.

Lemma nonzero_produit :
 forall z z' : C, z <> zeroC -> z' <> zeroC -> Cmult z z' <> zeroC.
intros.
apply nonzero_module.
rewrite Cmult_module.
apply Rmult_integral_contrapositive.
split; auto with geo.
Qed.
Hint Resolve Cmult_module Cmult_argument nonzero_produit Cmult_z_zeroC
  Cmult_zeroC_z: geo.

Lemma Cmult_z_z' :
 forall (z z' : C) (r a r' a' : R),
 z <> zeroC ->
 z' <> zeroC ->
 z = cons_pol r a ->
 z' = cons_pol r' a' -> Cmult z z' = cons_pol (r * r') (a + a').
intros.
apply forme_polaire_def; auto with geo.
rewrite Cmult_module.
rewrite (complexe_pol_module (z:=z) (r:=r) (a:=a)); auto with geo.
rewrite (complexe_pol_module (z:=z') (r:=r') (a:=a')); auto with geo.
rewrite Cmult_argument; auto with geo.
rewrite (complexe_pol_argument (z:=z) (r:=r) (a:=a)); auto with geo.
rewrite (complexe_pol_argument (z:=z') (r:=r') (a:=a')); auto with geo.
Qed.
Hint Resolve Cmult_z_z': geo.

Lemma Cmult_commutative : forall z z' : C, Cmult z z' = Cmult z' z.
intros.
elim (classic (z = zeroC)); intros.
rewrite H; rewrite Cmult_zeroC_z; rewrite Cmult_z_zeroC; auto.
elim (classic (z' = zeroC)); intros.
rewrite H0; rewrite Cmult_zeroC_z; rewrite Cmult_z_zeroC; auto.
elim existence_forme_polaire with (z := z);
 [ intros r H1; elim H1; intros a H2; elim H2; intros H3 H4;
    try clear H2 H1 existence_forme_polaire; try exact H3
 | auto with geo ].
elim existence_forme_polaire with (z := z');
 [ intros r' H5; elim H5; intros a' H6; elim H6; intros H7 H8;
    try clear H6 H5 existence_forme_polaire; try exact H7
 | auto with geo ].
rewrite (Cmult_z_z' (z:=z) (z':=z') (r:=r) (a:=a) (r':=r') (a':=a'));
 auto with geo.
rewrite (Cmult_z_z' (z:=z') (z':=z) (r:=r') (a:=a') (r':=r) (a':=a));
 auto with geo.
replace (r * r') with (r' * r); [ idtac | ring ].
replace (a + a') with (a' + a); [ auto | ring ].
Qed.

Lemma Cmult_associative :
 forall z1 z2 z3 : C, Cmult z1 (Cmult z2 z3) = Cmult (Cmult z1 z2) z3.
intros.
elim (classic (z1 = zeroC)); intros.
rewrite H.
repeat rewrite Cmult_zeroC_z; auto.
elim (classic (z2 = zeroC)); intros.
rewrite H0.
repeat rewrite Cmult_zeroC_z; repeat rewrite Cmult_z_zeroC;
 repeat rewrite Cmult_zeroC_z; auto.
elim (classic (z3 = zeroC)); intros.
rewrite H1.
repeat rewrite Cmult_z_zeroC; auto.
apply egalite_forme_polaire.
apply nonzero_produit; auto with geo.
apply nonzero_produit; auto with geo.
repeat rewrite Cmult_module; ring.
repeat rewrite Cmult_argument; auto with geo.
elim existence_argument with (z := z1);
 [ intros a H2; try clear existence_argument; try exact H2 | auto with geo ].
elim existence_argument with (z := z2);
 [ intros a0 H3; try clear existence_argument; try exact H3 | auto with geo ].
elim existence_argument with (z := z3);
 [ intros a1 H4; try clear existence_argument; try exact H4 | auto with geo ].
rewrite H2; rewrite H3; rewrite H4.
repeat rewrite <- add_mes_compatible.
replace (a + (a0 + a1)) with (a + a0 + a1); [ auto | ring ].
Qed.

Lemma Cmult_z_oneC : forall z : C, Cmult z oneC = z.
intros.
elim (classic (z = zeroC)); intros.
rewrite H.
repeat rewrite Cmult_zeroC_z; auto with geo.
apply egalite_forme_polaire; auto with geo.
rewrite Cmult_module; rewrite module_oneC; ring.
repeat rewrite Cmult_argument; auto with geo.
rewrite argument_oneC; auto with geo.
Qed.

Definition Csqr (z : C) := Cmult z z.
Hint Unfold Csqr: geo.

Lemma i_carre : Csqr i = Rinj (-1).
unfold Csqr in |- *.
apply egalite_forme_polaire; auto with geo.
rewrite Cmult_module; rewrite module_opp_un; rewrite module_i; ring.
repeat rewrite Cmult_argument; auto with geo.
rewrite argument_opp_un; rewrite argument_i.
rewrite <- add_mes_compatible; auto.
Qed.

Theorem Cmult_algebrique :
 forall x1 y1 x2 y2 : R,
 Cmult (cons_cart x1 y1) (cons_cart x2 y2) =
 cons_cart (x1 * x2 + - (y1 * y2)) (y1 * x2 + x1 * y2).
intros.
elim (classic (cons_cart x1 y1 = zeroC)); intros.
elim algebrique_zeroC with (a := x1) (b := y1);
 [ intros; try exact H1 | auto ].
rewrite H1; rewrite H0.
replace (0 * x2 + - (0 * y2)) with 0; [ idtac | ring ].
replace (0 * x2 + 0 * y2) with 0; [ idtac | ring ].
repeat rewrite Cmult_zeroC_z; auto.
elim (classic (cons_cart x2 y2 = zeroC)); intros.
elim algebrique_zeroC with (a := x2) (b := y2);
 [ intros; try exact H1 | auto ].
rewrite H1; rewrite H2.
replace (x1 * 0 + - (y1 * 0)) with 0; [ idtac | ring ].
replace (y1 * 0 + x1 * 0) with 0; [ idtac | ring ].
repeat rewrite Cmult_z_zeroC; auto.
elim existence_forme_polaire with (z := cons_cart x1 y1);
 [ intros r1 H1; elim H1; intros a1 H2; elim H2; intros H3 H4;
    try clear H2 H1; try exact H4
 | auto with geo ].
elim existence_forme_polaire with (z := cons_cart x2 y2);
 [ intros r2 H1; elim H1; intros a2 H2; elim H2; intros H5 H6;
    try clear H2 H1; try exact H6
 | auto with geo ].
generalize (Cmult_module (cons_cart x1 y1) (cons_cart x2 y2)); intros.
rewrite H5 in H1; rewrite H3 in H1.
lapply (Cmult_argument (z:=cons_cart x1 y1) (z':=cons_cart x2 y2)); intros;
 auto with geo.
rewrite H4 in H2; rewrite H6 in H2.
cut
 (Cmult (cons_cart x1 y1) (cons_cart x2 y2) = cons_pol (r1 * r2) (a1 + a2));
 intros.
rewrite
 (polaire_calcul_algebrique (z:=Cmult (cons_cart x1 y1) (cons_cart x2 y2))
    (r:=r1 * r2) (a:=a1 + a2)); auto with geo.
elim
 passage_polaire_algebrique
  with (z := cons_cart x1 y1) (r := r1) (a := a1) (x := x1) (y := y1);
 [ intros; try exact H8 | auto with geo | auto with geo | auto with geo ].
rewrite H8; rewrite H9.
elim
 passage_polaire_algebrique
  with (z := cons_cart x2 y2) (r := r2) (a := a2) (x := x2) (y := y2);
 [ intros | auto with geo | auto with geo | auto with geo ].
rewrite H10; rewrite H11.
rewrite cos_som; rewrite sin_som.
replace (r1 * r2 * (cos a1 * cos a2 + - (sin a1 * sin a2))) with
 (r1 * cos a1 * (r2 * cos a2) + - (r1 * sin a1 * (r2 * sin a2)));
 [ idtac | ring ].
replace (r1 * r2 * (sin a1 * cos a2 + sin a2 * cos a1)) with
 (r1 * sin a1 * (r2 * cos a2) + r1 * cos a1 * (r2 * sin a2));
 [ auto | ring ].
apply forme_polaire_def; auto with geo.
rewrite H2; auto.
rewrite <- add_mes_compatible; auto.
Qed.
Hint Resolve Cmult_algebrique: geo.

Theorem Cmult_distributive :
 forall z1 z2 z3 : C,
 Cmult z1 (Cplus z2 z3) = Cplus (Cmult z1 z2) (Cmult z1 z3).
intros.
elim existence_parties_relles_imaginaires with (z := z1); intros a1 H; elim H;
 intros b1 H0; try clear H; try exact H0.
elim existence_parties_relles_imaginaires with (z := z2); intros a2 H; elim H;
 intros b2 H1; try clear H; try exact H1.
elim existence_parties_relles_imaginaires with (z := z3); intros a3 H; elim H;
 intros b3 H2; try clear H; try exact H2.
rewrite H2; rewrite H1; rewrite H0.
repeat rewrite Cmult_algebrique; repeat rewrite Cplus_algebrique;
 repeat rewrite Cmult_algebrique.
replace (a1 * (a2 + a3) + - (b1 * (b2 + b3))) with
 (a1 * a2 + - (b1 * b2) + (a1 * a3 + - (b1 * b3)));
 [ idtac | ring ].
replace (b1 * (a2 + a3) + a1 * (b2 + b3)) with
 (b1 * a2 + a1 * b2 + (b1 * a3 + a1 * b3)); [ auto | ring ].
Qed.

Lemma Cplus_zeroC_z : forall z : C, Cplus zeroC z = z.
intros.
rewrite Cplus_commutative; auto with geo.
Qed.
Hint Resolve Cmult_z_oneC: geo.

Lemma Cmult_oneC_z : forall z : C, Cmult oneC z = z.
intros.
rewrite Cmult_commutative; auto with geo.
Qed.

Lemma Cmult_distributive_r :
 forall z1 z2 z3 : C,
 Cmult (Cplus z1 z2) z3 = Cplus (Cmult z1 z3) (Cmult z2 z3).
intros.
rewrite Cmult_commutative; rewrite Cmult_distributive.
rewrite Cmult_commutative; rewrite (Cmult_commutative z3 z2); auto with geo.
Qed.

Lemma CTheory :
 ring_theory zeroC oneC Cplus Cmult Cminus Copp (eq(A:=C)).
split.
exact Cplus_zeroC_z.
exact Cplus_commutative.
exact Cplus_associative.
exact Cmult_oneC_z.
exact Cmult_commutative.
exact Cmult_associative.
exact Cmult_distributive_r.
reflexivity.
exact Cplus_z_oppz.
Defined.
Add Ring Cring : CTheory.

Lemma algebrique_operations :
 forall x y : R, cons_cart x y = Cplus (Rinj x) (Cmult i (Rinj y)).
unfold i in |- *; unfold Rinj in |- *; intros.
rewrite Cmult_algebrique; rewrite Cplus_algebrique.
replace (x + (0 * y + - (1 * 0))) with x; [ idtac | ring ].
replace (0 + (1 * y + 0 * 0)) with y; [ auto | ring ].
Qed.

Lemma existence_inverse :
 forall z : C, z <> zeroC -> exists z' : C, Cmult z z' = oneC.
intros.
elim existence_forme_polaire with (z := z);
 [ intros r H1; elim H1; intros a H2; elim H2; intros H3 H4; try clear H2 H1;
    try exact H3
 | auto with geo ].
cut (r <> 0); intros.
cut (/ r <> 0); intros; auto with real.
cut (cons_pol (/ r) (- a) <> zeroC); intros.
exists (cons_pol (/ r) (- a)).
apply egalite_forme_polaire; auto with geo.
rewrite Cmult_module; rewrite module_oneC; rewrite complexe_polaire_module;
 rewrite H3; field; trivial.
rewrite Cmult_argument; auto with geo.
rewrite complexe_polaire_argument; auto with geo.
rewrite H4; rewrite argument_oneC.
rewrite <- add_mes_compatible.
replace (a + - a) with 0; [ auto | ring ].
auto with real geo.
rewrite <- H3; auto with geo.
Qed.

Lemma unicite_inverse :
 forall z z1 z2 : C,
 z <> zeroC -> Cmult z z1 = oneC -> Cmult z z2 = oneC -> z1 = z2.
intros.
cut (module z * module z1 = 1); intros.
cut (module z * module z2 = 1); intros.
cut (module z <> 0); intros; auto with geo.
cut (module z1 <> 0); intros.
cut (module z2 <> 0); intros.
cut (z1 <> zeroC); intros; auto with geo.
cut (z2 <> zeroC); intros; auto with geo.
apply egalite_forme_polaire; auto with geo.
replace (module z1) with (/ module z); auto with real.
auto with real.
cut (plus (argument z) (argument z1) = image_angle 0); intros.
cut (plus (argument z) (argument z2) = image_angle 0); intros.
rewrite (opp_angle (a:=argument z) (b:=argument z1)); auto.
rewrite (opp_angle (a:=argument z) (b:=argument z2)); auto.
rewrite <- Cmult_argument; auto with geo.
rewrite H1; rewrite <- argument_oneC; auto.
rewrite <- Cmult_argument; auto with geo.
rewrite H0; rewrite <- argument_oneC; auto.
cut (module z * module z2 <> 0); intros.
red in |- *; intros; apply H6.
rewrite H7; ring.
rewrite H3; discrR.
cut (module z * module z1 <> 0); intros.
red in |- *; intros; apply H5.
rewrite H6; ring.
rewrite H2; discrR.
rewrite <- Cmult_module; rewrite H1; rewrite <- module_oneC; auto.
rewrite <- Cmult_module; rewrite H0; rewrite <- module_oneC; auto.
Qed.
Parameter Cinv : C -> C.

Axiom Cinv_def : forall z : C, z <> zeroC -> Cmult z (Cinv z) = oneC.

Axiom
  Cinv_def2 : forall z z' : C, z <> zeroC -> Cmult z z' = oneC -> Cinv z = z'.

Lemma Cinv_l : forall z : C, z <> zeroC -> Cmult (Cinv z) z = oneC.
intros.
rewrite <- (Cinv_def (z:=z)); auto.
ring.
Qed.
Hint Resolve Cinv_def Cinv_def2 Cinv_l: geo.

Lemma Cinv_module : forall z : C, z <> zeroC -> module (Cinv z) = / module z.
intros.
cut (module z * module (Cinv z) = 1); intros.
cut (module z <> 0); intros; auto with geo.
apply Rmult_eq_reg_l with (module z); auto.
rewrite H0; auto with real.
rewrite <- Cmult_module; rewrite Cinv_def; auto with geo.
Qed.
Hint Resolve Cinv_module: geo.

Lemma inv_nonzero : forall z : C, z <> zeroC -> Cinv z <> zeroC.
intros.
apply nonzero_module.
rewrite Cinv_module; auto with geo.
cut (module z <> 0); intros; auto with geo.
auto with real.
Qed.
Hint Resolve inv_nonzero: geo.

Lemma Cinv_argument :
 forall z : C, z <> zeroC -> argument (Cinv z) = opp (argument z).
intros.
cut (Cinv z <> zeroC); intros; auto with geo.
cut (plus (argument z) (argument (Cinv z)) = image_angle 0); intros.
apply opp_angle; auto.
rewrite <- argument_oneC.
rewrite <- Cmult_argument; auto with geo.
rewrite Cinv_def; auto with geo.
Qed.
Hint Resolve Cinv_argument: geo.
Parameter Cdiv : C -> C -> C.

Axiom
  Cdiv_def : forall z z' : C, z' <> zeroC -> Cdiv z z' = Cmult z (Cinv z').

Lemma Cdiv_module :
 forall z z' : C, z' <> zeroC -> module (Cdiv z z') = module z * / module z'.
intros.
rewrite Cdiv_def; auto with geo.
rewrite Cmult_module; rewrite Cinv_module; auto.
Qed.
Hint Resolve Cdiv_module: geo.

Lemma Cdiv_argument :
 forall z z' : C,
 z <> zeroC ->
 z' <> zeroC -> argument (Cdiv z z') = plus (argument z) (opp (argument z')).
intros.
rewrite Cdiv_def; auto with geo.
rewrite Cmult_argument; auto with geo.
rewrite Cinv_argument; auto with geo.
Qed.
Hint Resolve Cdiv_argument: geo.

Lemma Cintegre :
 forall z z' : C, z <> zeroC -> Cmult z z' = zeroC -> z' = zeroC.
intros.
replace z' with (Cmult (Cmult (Cinv z) z) z')
  by (rewrite Cinv_l; trivial; ring).
replace (Cmult (Cmult (Cinv z) z) z') with (Cmult (Cinv z) (Cmult z z'))
  by ring.
rewrite H0; ring.
Qed.

Lemma module_un_nonzero : forall a : R, cons_pol 1 a <> zeroC.
intros.
apply polaire_non_nul; try discrR.
Qed.
Hint Resolve module_un_nonzero: geo.

Lemma module_un_trivial : forall a : R, module (cons_pol 1 a) = 1.
intros; auto with geo.
Qed.

Lemma argument_module_un :
 forall a : R, argument (cons_pol 1 a) = image_angle a.
intros.
rewrite (complexe_polaire_argument (r:=1) a); intros; auto with geo.
discrR.
Qed.

Lemma polaire_produit :
 forall r a : R, r <> 0 -> cons_pol r a = Cmult (Rinj r) (cons_pol 1 a).
intros.
apply egalite_forme_polaire; auto with geo.
rewrite Cmult_module; rewrite module_un_trivial; rewrite module_reel;
  ring_simplify.
pattern r at 2 in |- *.
rewrite <- (complexe_polaire_module r a); auto with geo.
rewrite Cmult_argument; auto with geo.
rewrite argument_module_un.
rewrite argument_reel_pos; auto with geo.
rewrite complexe_polaire_argument; auto with geo.
rewrite plus_commutative; auto with geo.
cut (r >= 0); intros.
change (r > 0) in |- *.
elim H0; intros; auto.
absurd (r = 0); auto.
rewrite <- (complexe_polaire_module r a); auto with geo.
Qed.

Lemma affixe_vec_AB :
 forall (a b : C) (A B : PO),
 a = affixe A -> b = affixe B -> Cplus b (Copp a) = affixe_vec (vec A B).
intros.
elim existence_parties_relles_imaginaires with (z := a); intros a1 H2;
 elim H2; intros a2 H3; try clear H2; try exact H3.
elim existence_parties_relles_imaginaires with (z := b); intros b1 H4;
 elim H4; intros b2 H5; try clear H4; try exact H5.
elim
 cartvec_AB
  with
    (a1 := a1)
    (a2 := a2)
    (b1 := b1)
    (b2 := b2)
    (O := O)
    (I := I)
    (J := J)
    (A := A)
    (B := B);
 [ intros H1 H2; try clear cartvec_AB; try exact H2
 | eauto with geo
 | eauto with geo
 | eauto with geo
 | eauto with geo
 | eauto with geo ].
rewrite H5; rewrite H3; rewrite Copp_algebrique; rewrite Cplus_algebrique.
rewrite (absvec_ordvec_affixe (a:=b1 + - a1) (b:=b2 + - a2) (A:=A) (B:=B));
 auto.
Qed.

Lemma affixe_vec_AB_affixes :
 forall A B : PO, affixe_vec (vec A B) = Cplus (affixe B) (Copp (affixe A)).
intros.
elim existence_affixe_point with (M := A); intros a H; try exact H.
elim existence_affixe_point with (M := B); intros b; intros.
symmetry  in |- *; rewrite <- H; rewrite <- H0.
apply affixe_vec_AB; auto.
Qed.
Hint Resolve egalite_vecteur_distance: geo.

Lemma module_difference :
 forall (a b : C) (A B : PO),
 a = affixe A -> b = affixe B -> module (Cplus b (Copp a)) = distance A B.
intros.
cut (Cplus b (Copp a) = affixe_vec (vec A B)); intros.
elim existence_representant_vecteur with (A := O) (B := A) (C := B);
 intros D H2; intros; try exact H2.
cut (Cplus b (Copp a) = affixe D); intros.
rewrite (module_def (z:=Cplus b (Copp a)) (M:=D)); auto with geo.
cut (Cplus b (Copp a) = affixe_vec (vec O D)); intros; auto with geo.
rewrite H1; rewrite H2; auto.
apply affixe_vec_AB; auto.
Qed.

Lemma argument_difference :
 forall (a b : C) (A B : PO),
 A <> B ->
 a = affixe A ->
 b = affixe B -> argument (Cplus b (Copp a)) = cons_AV (vec O I) (vec A B).
intros.
cut (Cplus b (Copp a) = affixe_vec (vec A B)); intros.
elim existence_representant_vecteur with (A := O) (B := A) (C := B); intros D;
 intros.
cut (Cplus b (Copp a) = affixe D); intros.
rewrite (argument_def (M:=D) (z:=Cplus b (Copp a))); auto with geo.
rewrite H3; auto.
red in |- *; intros; apply H.
apply vecteur_nul_conf.
rewrite <- H3; rewrite <- H5; Ringvec.
cut (Cplus b (Copp a) = affixe_vec (vec O D)); intros; auto with geo.
rewrite H2; rewrite H3; auto with geo.
apply affixe_vec_AB; auto.
Qed.
Hint Resolve module_difference argument_difference: geo.

Lemma diff_nonzero :
 forall (a b : C) (A B : PO),
 a = affixe A -> b = affixe B -> A <> B :>PO -> Cplus b (Copp a) <> zeroC.
intros.
apply nonzero_module.
rewrite (module_difference (a:=a) (b:=b) (A:=A) (B:=B)); auto with geo.
Qed.
Hint Resolve diff_nonzero: geo.

Lemma module_quotient :
 forall (a b d e : C) (A B D E : PO),
 D <> E :>PO ->
 a = affixe A ->
 b = affixe B ->
 d = affixe D ->
 e = affixe E ->
 module (Cdiv (Cplus b (Copp a)) (Cplus e (Copp d))) =
 distance A B * / distance D E.
intros.
rewrite Cdiv_def.
rewrite Cmult_module; rewrite Cinv_module; auto with geo.
rewrite (module_difference (a:=a) (b:=b) (A:=A) (B:=B)); auto with geo.
rewrite (module_difference (a:=d) (b:=e) (A:=D) (B:=E)); auto with geo.
apply diff_nonzero with (3 := H); auto.
apply diff_nonzero with (3 := H); auto.
Qed.
Hint Resolve module_quotient Chasles_diff: geo.

Lemma argument_quotient :
 forall (a b d e : C) (A B D E : PO),
 A <> B :>PO ->
 D <> E :>PO ->
 a = affixe A ->
 b = affixe B ->
 d = affixe D ->
 e = affixe E ->
 argument (Cdiv (Cplus b (Copp a)) (Cplus e (Copp d))) =
 cons_AV (vec D E) (vec A B).
intros.
cut (Cplus b (Copp a) <> zeroC); intros.
cut (Cplus e (Copp d) <> zeroC); intros.
rewrite Cdiv_def; auto with geo.
rewrite Cmult_argument; auto with geo.
rewrite Cinv_argument; auto with geo.
rewrite (argument_difference (a:=a) (b:=b) (A:=A) (B:=B)); auto with geo.
rewrite (argument_difference (a:=d) (b:=e) (A:=D) (B:=E)); auto with geo.
apply diff_nonzero with (3 := H0); auto.
apply diff_nonzero with (3 := H); auto.
Qed.


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

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj20eqsynthconj3 : forall  (lv0 : natural) (lv1 : natural) (lv2 : natural), (@eq natural (plus (plus lv0 lv1) lv2) (plus lv1 (plus lv0 lv2))).
Admitted.
QuickChick conj20eqsynthconj3.


(** Commutation of path groupoid with polynomials *)
Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.

Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Groupoids.

Require Import UniMath.Bicategories.Core.Bicat.
Import Bicat.Notations.
Require Import UniMath.Bicategories.PseudoFunctors.Display.Base.
Require Import UniMath.Bicategories.PseudoFunctors.Display.Map1Cells.
Require Import UniMath.Bicategories.PseudoFunctors.Display.Map2Cells.
Require Import UniMath.Bicategories.PseudoFunctors.Display.Identitor.
Require Import UniMath.Bicategories.PseudoFunctors.Display.Compositor.
Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat.
Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor.
Import PseudoFunctor.Notations.
Require Import UniMath.Bicategories.PseudoFunctors.Examples.Identity.
Require Import UniMath.Bicategories.PseudoFunctors.Examples.Composition.
Require Import UniMath.Bicategories.Transformations.PseudoTransformation.
Require Import UniMath.Bicategories.Core.Examples.OneTypes.

Require Import signature.hit_signature.
Require Import prelude.all.
Require Import algebra.one_types_polynomials.
Require Import algebra.groupoid_polynomials.

Require Export hit_biadjunction.path_groupoid_commute.path_groupoid_const_id.
Require Export hit_biadjunction.path_groupoid_commute.path_groupoid_sum.
Require Export hit_biadjunction.path_groupoid_commute.path_groupoid_prod.

Local Open Scope cat.

Opaque comp_psfunctor.

(** Commutation of path groupoid with polynomials *)
Definition poly_path_groupoid
           (P : poly_code)
  : pstrans
      (comp_psfunctor
         (⦃ P ⦄)
         path_groupoid)
      (comp_psfunctor
         path_groupoid
         (⟦ P ⟧)).
Proof.
  induction P as [ A | | P₁ IHP₁ P₂ IHP₂ | P₁ IHP₁ P₂ IHP₂ ].
  - exact (const_path_groupoid A).
  - exact id_path_groupoid.
  - exact (path_groupoid_sum IHP₁ IHP₂).
  - exact (path_groupoid_prod IHP₁ IHP₂).
Defined.