Require Import Paths Equivalences UsefulEquivalences Funext UnivalenceAxiom HLevel.

(** This file defines some useful equivalences that require functional
   extensionality, usually involving equivalences between function
   spaces. *)

(** Currying and uncurrying are equivalences. *)

Definition curry_equiv A B C : (A * B -> C) <~> (A -> B -> C).
Proof.
  exists (fun f => fun a b => f (a,b)).
  apply (hequiv_is_equiv (fun f => fun (a : A)(b :B) => f (a, b))
                                   (fun g => fun x => g (fst x) (snd x))).
  intro f; apply funext; intro a; apply funext; intro b; auto.
  intro g; apply funext; intros [a b]; auto.
Defined.

(** Flipping the arguments of a two-variable function is an equivalence. *)

Definition flip_equiv A B C : (A -> B -> C) <~> (B -> A -> C).
Proof.
  exists (fun f => fun b a => f a b).
  apply hequiv_is_equiv with (fun g => fun a b => g b a).
  intro g; apply funext; intro a; apply funext; intro b; auto.
  intro f; apply funext; intro b; apply funext; intro a; auto.
Defined.

(** Pre- and post-composing by an equivalence is an equivalence. *)

Lemma precomp_equiv A B C (g : A <~> B) : (B -> C) <~> (A -> C).
Proof.
  exists (fun h => h o g).
  apply @hequiv_is_equiv with (g := fun k => k o (g ^-1));
    intros k; apply funext; intros a; unfold compose; simpl; apply map.
  apply inverse_is_retraction.
  apply inverse_is_section.
Defined.

Lemma postcomp_equiv A B C (g : B <~> C) : (A -> B) <~> (A -> C).
Proof.
  exists (fun h => g o h).
  apply @hequiv_is_equiv with (g := fun k => (g ^-1) o k);
    intros k; apply funext; intros a; unfold compose; simpl.
  apply inverse_is_section.
  apply inverse_is_retraction.
Defined.

Lemma postcomp_equiv_dep A P Q (g : forall a:A, P a <~> Q a) :
  (forall a, P a) <~> (forall a, Q a).
Proof.
  exists (fun f a => g a (f a)).
  apply @hequiv_is_equiv with (g := fun k a => (g a ^-1) (k a));
    intros k; apply funext_dep; intros a; unfold compose; simpl.
  apply inverse_is_section.
  apply inverse_is_retraction.
Defined.

(** The space of factorizations through an equivalence is contractible. *)

Lemma equiv_postfactor_contr A B C (g : B <~> C) (h : A -> C) :
  is_contr { f : A -> B &  g o f === h }.
Proof.
  apply contr_equiv_contr with ({f : A -> B & g o f == h}).
  unfold "===".
  apply total_equiv with (fun f => happly).
  intros f; apply strong_funext.
  refine (pr2 (postcomp_equiv _ _ _ g) h).
Defined.

Lemma equiv_prefactor_contr A B C (f : A <~> B) (h : A -> C) :
  is_contr { g : B -> C &  g o f === h }.
Proof.
  apply contr_equiv_contr with ({g : B -> C & g o f == h}).
  unfold "===".
  apply total_equiv with (fun g => happly).
  intros g; apply strong_funext.
  refine (pr2 (precomp_equiv _ _ _ f) h).
Defined.

(** It follows that [is_hiso] is a prop, and hence equivalent to [is_equiv].  *)

Theorem is_hiso_is_prop A B (f : A -> B) : is_prop (is_hiso f).
Proof.
  apply allpath_prop.
  intros [g1 h1] [g2 h2].
  set (feq := (f ; hiso_to_equiv f (g1,h1)) : A <~> B).
  apply prod_path; apply contr_path.
  refine (equiv_prefactor_contr _ _ _ feq (idmap A)).
  refine (equiv_postfactor_contr _ _ _ feq (idmap B)).
Defined.

Theorem is_equiv_is_hiso_equiv A B (f : A -> B) : is_equiv f <~> is_hiso f.
Proof.
  apply prop_iff_equiv.
  apply is_equiv_is_prop.
  apply is_hiso_is_prop.
  intros fiseq; exact (equiv_to_hiso (f; fiseq)).
  apply hiso_to_equiv.
Defined.

(** Cartesian products have the correct universal property. *)

Lemma prod_equiv A B T :
  (T -> A) * (T -> B) <~> (T -> A * B).
Proof.
  exists (fun fg => fun t => (fst fg t, snd fg t)).
  apply @hequiv_is_equiv with
    (fun h => (fun t => fst (h t), fun t => snd (h t))).
  intros h; apply funext; intros t; simpl.
  destruct (h t) as [a b]; auto.
  intros [f g]; apply prod_path; apply funext; intros t; auto.
Defined.

(** Given an iterated fibration, to give a section of the composite
   fibration is equivalent to giving a section of the first fibration and
   a section over that of the second.  *)

Lemma section_total_equiv A (P : A -> Type) (Q : forall a, P a -> Type) :
  (forall a, sigT (Q a)) <~> {s : forall a, P a & forall a, Q a (s a) }.
Proof.
  exists (fun f => (existT (fun s => forall a, Q a (s a))
    (fun a => pr1 (f a)) (fun a => pr2 (f a)))).
  apply hequiv_is_equiv with
    (g := fun sr:{s : forall a, P a & forall a, Q a (s a) } =>
      let (s,r) := sr in (fun a => existT (Q a) (s a) (r a))).
  intros [s r].
  set (p := funext_dep (f := eta_dep s) (g := s) (fun a => idpath (s a))).
  apply total_path with p; simpl.
  apply funext_dep; intros a.
  apply (concat (trans_map p
    (fun s' (r': forall a, Q a (s' a)) => r' a) (eta_dep r))).
  path_via (transport (happly_dep p a) (eta_dep r a)).
  unfold happly_dep.
  apply @map_trans with (f := fun h : forall a' : A, P a' => h a).
  path_via (transport (idpath (s a)) (eta_dep r a)).
  apply happly, map.
  apply funext_dep_compute with
    (f := eta_dep s) (g := s) (p := fun a' : A => idpath (s a')).
  intros f.
  apply funext_dep; intros a.
  destruct (f a); auto.
Defined.

(** The space of sections of fibrations is "associative". *)

Section SectionAssoc.

  Hypotheses (A:Type) (P : A -> Type) (Q : forall x, P x -> Type).

  Let sa1 : (forall (x:A) (p:P x), Q x p)
    -> forall xp:sigT P, Q (pr1 xp) (pr2 xp).
  Proof.
    intros f [x p]; exact (f x p).
  Defined.

  Let sa2 : (forall xp:sigT P, Q (pr1 xp) (pr2 xp))
    -> forall (x:A) (p:P x), Q x p.
  Proof.
    intros f x p; exact (f (x;p)).
  Defined.

  Definition section_assoc :
    (forall (x:A) (p:P x), Q x p) <~> (forall xp:sigT P, Q (pr1 xp) (pr2 xp)).
  Proof.
    exists sa1.
    apply hequiv_is_equiv with sa2.
    intros f; apply funext_dep; intros [x p]; auto.
    intros f; apply funext_dep; intros p; apply funext_dep; intros x; auto.
  Defined.

End SectionAssoc.

Section SectionAssocSum.

  Hypotheses (A:Type) (P : A -> Type) (Q : sigT P -> Type).

  Let sa1 : (forall (x:A) (p:P x), Q (x;p))
    -> forall xp:sigT P, Q xp.
  Proof.
    intros f [x p]; exact (f x p).
  Defined.

  Let sa2 : (forall xp:sigT P, Q xp)
    -> forall (x:A) (p:P x), Q (x;p).
  Proof.
    intros f x p; exact (f (x;p)).
  Defined.

  Definition section_assoc_sum :
    (forall (x:A) (p:P x), Q (x;p)) <~> (forall xp:sigT P, Q xp).
  Proof.
    exists sa1.
    apply hequiv_is_equiv with sa2.
    intros f; apply funext_dep; intros [x p]; auto.
    intros f; apply funext_dep; intros p; apply funext_dep; intros x; auto.
  Defined.

End SectionAssocSum.

(* And "commutative". *)

Definition section_comm (A:Type) (B:Type) (P : A -> B -> Type) :
  (forall a b, P a b) <~> (forall b a, P a b).
Proof.
  exists (fun f b a => f a b).
  apply hequiv_is_equiv with (fun f a b => f b a).
  intros f; apply funext_dep; intros y; apply funext_dep; intros x; auto.
  intros f; apply funext_dep; intros x; apply funext_dep; intros y; auto.
Defined.

(* The space of sections of a type dependent on paths with one end
   free is equivalent, by the eliminator, to the fiber over the
   identity path. *)

Program Definition section_paths_equiv A (x:A)
  (P : forall (b:A), x==b -> Type) :
  (forall (y:A) (p: x == y), P y p) <~> P x (idpath x)
  := (_ ; hequiv_is_equiv _ _ _ _).
Next Obligation.
  intros A x P Z.
  exact (Z x (idpath x)).
Defined.
Next Obligation.
  intros A x P z y p.
  induction p. exact z.
Defined.
Next Obligation.
  intros A x P z;
    unfold section_paths_equiv_obligation_1, section_paths_equiv_obligation_2.
  auto.
Defined.
Next Obligation.
  unfold section_paths_equiv_obligation_1, section_paths_equiv_obligation_2.
  intros A x P Z; apply funext_dep; intros y; apply funext_dep; intros p.
  induction p. auto.
Defined.

(* Finally, we can prove that [is_adjoint_equiv] is equivalent to [is_equiv]. *)

Theorem is_adjoint_equiv_equiv A B (f : A -> B) :
  is_equiv f <~> is_adjoint_equiv f.
Proof.
  unfold is_equiv, is_contr.
  apply @equiv_compose with
    (B := {g: forall y:B, hfiber f y & forall y y0, y0 == g y}).
  apply section_total_equiv.
  unfold hfiber.
  set (X := {g : B -> A & forall y:B, f (g y) == y}).
  set (Y := forall y : B, {x : A & f x == y}).
  set (k := equiv_inverse
    (section_total_equiv B (fun _ => A) (fun y x => f x == y)) : X <~> Y).
  apply @equiv_compose with
    (B := {gs : X & forall y y0, y0 == k gs y}).
  apply equiv_inverse.
  exists (total_map k (fun gs => idmap
    (forall (y : B) (y0 : {x : A & f x == y}), y0 == k gs y))).
  apply pullback_total_is_equiv with (f := k)
    (Q := fun g => forall (y : B) (y0 : {x : A & f x == y}), y0 == g y).
  unfold X.
  apply @equiv_compose with
    (B := {g : B -> A & { s : forall y, f (g y) == y &
      forall (y : B) (y0 : {x : A & f x == y}), y0 == k (g;s) y}}).
  apply equiv_inverse.
  apply total_assoc_sum with
    (Q := fun gs => forall (y : B) (y0 : {x : A & f x == y}), y0 == k gs y).
  unfold is_adjoint_equiv.
  cut (forall g,
    {s : forall y : B, f (g y) == y &
      forall (y : B) (y0 : {x : A & f x == y}), y0 == k (g ; s) y}
    <~>
    {is_section : forall y : B, f (g y) == y &
      {is_retraction : forall x : A, g (f x) == x &
        forall x : A, map f (is_retraction x) == is_section (f x)}}).
  intros H. apply total_equiv with (g := H). intros g; apply (pr2 (H g)).
  intros g.
  cut (forall s,
    (forall (y : B) (y0 : {x : A & f x == y}), y0 == k (g ; s) y)
    <~>
    {is_retraction : forall x : A, g (f x) == x &
      forall x : A, map f (is_retraction x) == s (f x)}).
  intros H. apply total_equiv with H.  intros s; apply (pr2 (H s)).
  intros s.
  apply @equiv_compose with
    (B := forall (y : B) (x : A) (p : f x == y), (x;p) == k (g;s) y).
  apply postcomp_equiv_dep. intros y.
  apply equiv_inverse.
  apply section_assoc_sum with (Q := fun y0 => y0 == k (g;s) y).
  apply @equiv_compose with
    (B := forall (y : B) (x : A) (p : f x == y),
      { q : x == pr1 (k (g;s) y) &
        transport q p == pr2 (k (g;s) y)}).
  apply postcomp_equiv_dep; intros y.
  apply postcomp_equiv_dep; intros x.
  apply postcomp_equiv_dep; intros p.
  apply total_paths_equiv.
  unfold k; simpl. clear X Y k.
  apply @equiv_compose with
    (B := forall (x : A) (y : B) (p : f x == y),
      {q : x == g y & transport (P := fun x0 : A => f x0 == y) q p == s y}).
  apply section_comm.
  apply @equiv_compose with
    (B := forall x:A, { r : g (f x) == x & map f r == s (f x)}).
  2:apply section_total_equiv.
  apply postcomp_equiv_dep; intros x.
  apply @equiv_compose with
    (B := forall (y : B) (p : f x == y),
      {q : x == g y & !map f q @ p == s y}).
  apply postcomp_equiv_dep; intros y.
  apply postcomp_equiv_dep; intros p.
  apply equiv_inverse.
  apply @equiv_compose with
    (B := {q : x == g y &
      transport (P := fun y0 => y0 == y) (map f q) p == s y}).
  apply total_equiv with
    (g := fun q:x == g y => concat (trans_is_concat_opp (map f q) p)).
  intros q; apply concat_is_equiv_left.
  apply total_equiv with
    (g := fun q:x == g y => concat (map_trans (fun y0 => y0 == y) f q p)).
  intros q; apply concat_is_equiv_left.
  apply @equiv_compose with
    (B := {r : x == g (f x) & !map f r @ idpath (f x) == s (f x)}).
  Focus 2.
  apply @equiv_compose with
    (B := {r : x == g (f x) & map f (!r) == s (f x)}).
  apply @equiv_compose with
    (B := {r : x == g (f x) & !map f r == s (f x)}).
  apply total_equiv with (fun r:x == g (f x) =>
    concat (!idpath_right_unit _ _ _ (!map f r))).
  intros r; apply concat_is_equiv_left.
  apply total_equiv with (fun r:x == g (f x) =>
    concat (opposite_map _ _ f _ _ r)).
  intros r; apply concat_is_equiv_left.
  exists (total_map
    (P := fun r => map f (!r) == s (f x))
    (Q := fun r => map f r == s (f x))
    (opposite_equiv x (g (f x)))
    (fun r => idmap (map f (!r) == s (f x)))).
  refine (pullback_total_is_equiv
    (fun r => map f r == s (f x)) (opposite_equiv x (g (f x)))).
  refine (section_paths_equiv B (f x)
    (fun y p => {q : x == g y & !map f q @ p == s y})).
Defined.

(** And therefore it is a prop. *)

Theorem is_adjoint_equiv_is_prop A B (f : A -> B) :
  is_prop (is_adjoint_equiv f).
Proof.
  apply allpath_prop; intros e1 e2.
  apply equiv_injective with
    (V := is_equiv f)
    (w := equiv_inverse (is_adjoint_equiv_equiv A B f)).
  apply is_equiv_is_prop.
Defined.


(** *   Euclidean chains *)

(** ** Introduction

  In this module, we study a way to build efficiently efficient chains.
  Our approach is recursive (compositional?). Chains associated with big exponents are built by composition of smaller chains. Thus, the construction of a
small computation may be parameterized by the context in which it will be
  used. In other terms, we shall use Continuation Passing Style

  Euclidean chains are introduced by %\textbf{Add reference to litterature by Srecko, Pierre et al.}.

*)

Require Import Inverse_Image  Inclusion  Wf_nat.
Require Import Addition_Chains  NArith  Arith PArith  Compatibility.
Require Import More_on_positive.
Import Monoid_def  Pow.
Require Import Recdef Wf_nat.
Require Import  More_on_positive .
Require Import Wf_transparent Lexicographic_Product  Dichotomy BinaryStrat.
Generalizable All Variables.
Import Morphisms.
Import Monoid_def.

Ltac add_op_proper M H :=
 let h := fresh H in
   generalize (@Eop_proper _ _ _ _ M); intro h.

(**  * CPS chain construction
*)

(** Type of chain continuations *)

(* begin snippet FchainDef *)
Definition Fkont (A:Type) := A -> @computation A.

Definition Fchain := forall A, Fkont A -> A -> @computation A.
(* end snippet FchainDef *)

(** [F3 k x] computes $z = x^3$, then executes the computation associated
   with [k z] *)

(* begin snippet F3Def *)
Definition F3 : Fchain :=
 fun  A k  (x:A) =>
  y <--- x times x ;
  z <--- y times x ;
  k  z.
(* end snippet F3Def *)

(* begin snippet F1F2 *)
Definition F1 : Fchain :=
 fun A k (x:A) => k x.

Definition F2 : Fchain :=
fun  A k  (x:A) =>
  y <--- x times x ;
  k  y.
(* end snippet F1F2 *)

(** An Fchain [f] can be considered as a function that takes as
    argument another chain [c] for continueing the computation.
*)

(* begin snippet Fapply *)
Definition Fapply (f : Fchain) (c: chain) : chain  :=
 fun (A:Type) (x: A)  =>  f A (c A) x.
(* end snippet Fapply *)

(* begin snippet Fcompose *)
Definition Fcompose (f1 f2: Fchain) : Fchain  :=
 fun   A k x =>  f1  A (fun y => f2 A k y) x.
(* end snippet Fcompose *)

(** Any Fchain can be transformed into a plain chain *)

(* begin snippet F2C *)
Definition F2C (f : Fchain) : chain :=
 fun (A:Type) => f A Return .

Compute the_exponent (F2C F3).
(* end snippet F2C *)

(** Composition of Fchains

Fchains are used for building correct exponentiation schemes by composition
of correct components. So, we have to define composition of Fchains.

*)

(* begin snippet F9Def *)
Example F9 := Fcompose F3 F3.

Compute F9.
(* end snippet F9Def *)

(** Fchains associated with powers of 2 *)

(** computes $x^{2^n}$ then send this value to $k$ *)

(** The neutral element for Fcompose *)

(* begin snippet F1Neutral:: no-out  *)
Lemma F1_neutral_l : forall f, Fcompose F1 f = f.
Proof. reflexivity. Qed.

Lemma F1_neutral_r : forall f, Fcompose f F1 = f.
Proof. reflexivity. Qed.
(* end snippet F1Neutral *)

(* begin snippet Fexp2 *)
Fixpoint  Fexp2_of_nat (n:nat) : Fchain :=
 match n with O => F1
            | S p => Fcompose F2 (Fexp2_of_nat p)
 end.

Definition Fexp2 (p:positive) : Fchain :=
  Fexp2_of_nat (Pos.to_nat p).

Compute Fexp2 4.

Compute the_exponent (F2C (Fexp2 4)).
(* end snippet Fexp2 *)

(*
Compute F9.

= fun (A : Type) (x : Fkont A) (x0 : A) =>
       x1 <--- x0 times x0;
       x2 <--- x1 times x0; x3 <--- x2 times x2; x4 <--- x3 times x2; x x4
     : Fchain

*)

(* begin snippet F9Ok:: no-out *)
Remark F9_correct :chain_correct 9 (F2C F9).
param_chain_correct.
Qed.
(* end snippet F9Ok *)

Compute the_exponent (F2C F9).
(*
= 9
     : nat

*)

(** A first attempt to define Fchain correctness *)

(* begin snippet BadDefa *)
Module Bad.

Definition Fchain_correct (n:nat) (fc : Fchain) :=
  forall A `(M : @EMonoid A op E_one E_equiv) k (a:A),
    computation_execute op (fc A k  a)==
    computation_execute op (k  (a ^ n)).
(* end snippet BadDefa *)

(* begin snippet BadDefb *)
Theorem F3_correct : Fchain_correct 3 F3. (* .no-out *)
Proof.  (* .no-out *)
  intros  A op E_one E_equiv M k  a ; cbn. (* .no-out *)
  monoid_simpl M.
Abort.
End Bad.

(* end snippet BadDefb *)

(** Equivalence on computations *)

Definition computation_equiv {A:Type} (op: Mult_op A)
           (equiv : Equiv A)
           (c c': @computation A) :=
   computation_execute op c == computation_execute op c'.

#[ global ] Instance Comp_equiv {A:Type} (op: Mult_op A) (equiv : Equiv A):
  Equiv (@computation A) :=
  @computation_equiv A op equiv.

#[ global ] Instance comp_equiv_equivalence {A:Type} (op: Mult_op A)
           (equiv : Equiv A) : Equivalence  equiv ->
                               Equivalence (computation_equiv op equiv).
Proof.
intro H; split; red in equiv.
 - intro c; red;reflexivity.
 - intros x y H0; red; symmetry; auto.
 -intros x y z H0 H1; red;  transitivity (computation_execute op y);auto.
 Qed.

(** Fkonts that respect E_equiv *)

(* begin snippet FkontProper *)
Class Fkont_proper
      `(M : @EMonoid A op E_one E_equiv) (k: Fkont A )  :=
  Fkont_proper_prf:
    Proper (equiv ==> computation_equiv op E_equiv) k.
(* end snippet FkontProper *)

#[ global ] Instance Return_proper `(M : @EMonoid A op E_one E_equiv) :
  Fkont_proper M (@Return A).
Proof.
 intros x y Hxy; assumption.
Qed.

(** Fchain correctness (for exponent of type [nat] *)

(* begin snippet GoodFchainCorrect *)
Definition Fchain_correct_nat (n:nat) (f : Fchain) :=
 forall A `(M : @EMonoid A op E_one E_equiv) k
        (Hk :Fkont_proper M k)
        (a : A) ,
 computation_execute op (f A k  a) ==
 computation_execute op (k  (a ^ n)).

Definition Fchain_correct (p:positive) (f : Fchain) :=
 Fchain_correct_nat (Pos.to_nat p) f.
(* end snippet GoodFchainCorrect *)

(* begin snippet F1Ok:: no-out *)
Lemma F1_correct : Fchain_correct 1 F1.
Proof.
  intros until M ; intros k Hk a ; unfold F1; simpl.
  apply Hk; monoid_simpl M; reflexivity.
Qed.
(* end snippet F1Ok:: no-out *)

(* begin snippet F3Ok *)
Lemma F3_correct : Fchain_correct 3 F3. (* .no-out *)
Proof. (* .no-out *)
  intros until M; intros k Hk a; simpl.
  apply Hk.
  monoid_simpl M;  reflexivity.
Qed.
(* end snippet F3Ok *)

(* begin snippet F2Ok:: no-out *)
Lemma F2_correct : Fchain_correct 2 F2.
Proof.
  intros until M; intros k Hk a; simpl;
  apply  Hk;  monoid_simpl M;  reflexivity.
Qed.
(* end snippet F2Ok *)

(** F2C preserves correctness *)

Lemma F2C_correct (p:positive) (fc : Fchain) :
  Fchain_correct p fc ->  chain_correct p (F2C fc).
Proof.
  split;auto with chains;  intros until M;intro x; unfold F2C;
  specialize (H _ _ _ _ M (@Return A));
  unfold  Fapply, C1; red; unfold chain_apply;
  rewrite computation_eval_rw;
  apply H; apply Return_proper.
Qed.

(* begin snippet Bad2a:: no-out *)
Module Bad2.

Lemma Fcompose_correct :
  forall f1 f2 n1 n2,
    Fchain_correct n1 f1 ->
    Fchain_correct n2 f2 ->
    Fchain_correct (n1 * n2) (Fcompose f1 f2).
Proof.
  (* ... *)
(* end snippet Bad2a *)
 unfold Fchain_correct, Fcompose, Fchain_correct_nat; intros.
 specialize (H _  _ _ _ M (fun y : A => f2 A k y) ).
 specialize (H0 _ _ _ _ M).
 rewrite  H.
 rewrite H0.
 apply Hk.
 rewrite Pos2Nat.inj_mul.
 rewrite power_of_power.  rewrite Nat.mul_comm;reflexivity.
 auto.
 (* begin snippet Bad2b:: -.h#* .h#Hk .h#a .h#x .h#y .h#Hxy  *)
 intros x y Hxy;  red.
 (* end snippet Bad2b *)
 (* begin snippet Bad2c:: no-out *)
Abort.

End Bad2.
(* end snippet Bad2c *)

(** Fisrt attempt to define Fchain_proper *)

(* begin snippet Bad3 *)
Module Bad3.

Class Fchain_proper (fc : Fchain) := Fchain_proper_bad_prf :
 forall  `(M : @EMonoid A op E_one E_equiv) k  ,
    Fkont_proper M k ->
    forall x y, x == y ->
               @computation_equiv _ op E_equiv
                                  (fc A k x)
                                  (fc A k y).

(* end snippet Bad3 *)

(* begin snippet Bad3b:: no-out *)
#[ global ] Instance Fcompose_proper (f1 f2 : Fchain)
         (_ : Fchain_proper f1)
         (_ : Fchain_proper f2) :
  Fchain_proper (Fcompose f1 f2).
Proof.
 intros until M;intros k Hk x y Hxy; unfold Fcompose;cbn.
 apply (H _ _ _ _ M); auto.
 intros u v Huv;apply (H0 _ _ _ _ M);auto.
Qed.
(* end snippet Bad3b *)

(* begin snippet Bad3c *)
End Bad3.
(* end snippet Bad3c *)

(** Correct definition *)

(* begin snippet correctProper *)
Definition Fkont_equiv  `(M : @EMonoid A op E_one E_equiv)
 (k k': Fkont A )  :=
 forall x y : A, x == y ->
                 computation_equiv op E_equiv  (k x) (k' y).

Class Fchain_proper (fc : Fchain) := Fchain_proper_prf :
 forall  `(M : @EMonoid A op E_one E_equiv) k k' ,
    Fkont_proper M k -> Fkont_proper M k' ->
    Fkont_equiv M k k' ->
   forall x y,  x == y ->
               @computation_equiv _ op E_equiv
                                  (fc A k x)
                                  (fc A k' y).
(* end snippet correctProper *)

(* begin snippet F1proper:: no-out *)
#[ global ] Instance F1_proper : Fchain_proper F1.
Proof.
  intros until M ; intros k k' Hk Hk' H a b H0; unfold F1; cbn;
  now apply H.
Qed.
(* end snippet F1proper *)

(* begin snippet F3proper:: no-out *)
#[ global ] Instance F3_proper : Fchain_proper F3.
(* end snippet F3proper *)
Proof.
  intros  A op one equiv M  k k' Hk Hk'  Hkk' x y Hxy;
  apply Hkk'; add_op_proper M H; repeat rewrite Hxy;
  reflexivity.
Qed.

(* begin snippet F2proper:: no-out *)
#[ global ] Instance F2_proper : Fchain_proper F2.
(* end snippet F2proper *)
Proof.
  intros  A op one equiv M  k k' Hk Hk'  Hkk' x y Hxy;
  apply Hkk'; add_op_proper M H; repeat rewrite Hxy;
  reflexivity.
Qed.

(**  Fcompose respects correctness and properness *)

Lemma Fcompose_correct_nat : forall fc1 fc2 n1 n2,
                           Fchain_correct_nat n1 fc1 ->
                           Fchain_correct_nat n2 fc2 ->
                           Fchain_proper fc2 ->
                           Fchain_correct_nat (n1 * n2)%nat
                                              (Fcompose fc1 fc2).
Proof.
 unfold  Fcompose, Fchain_correct_nat; intros.
 assert (Fkont_proper M (fun y : A => fc2 A k y)).
 -  intros x y Hxy; apply H1 with E_one M;auto.
 - rewrite  (H _  _ _ _ M (fun y : A => fc2 A k y) H2 a).
   + rewrite (H0 _ _ _ _ M k Hk).
     * apply  Hk.
       rewrite power_of_power;auto;
       rewrite Nat.mul_comm;reflexivity.
Qed.

(* begin snippet FcomposeCorrect:: no-out *)
Lemma Fcompose_correct :
  forall fc1 fc2 n1 n2,
    Fchain_correct n1 fc1 ->
    Fchain_correct n2 fc2 ->
    Fchain_proper fc2 ->
    Fchain_correct (n1 * n2) (Fcompose fc1 fc2).
(* end snippet FcomposeCorrect *)
Proof.
 unfold Fchain_correct; intros.
 rewrite Pos2Nat.inj_mul.
  apply Fcompose_correct_nat;auto.
Qed.

(* begin snippet FcomposeProper:: no-out *)
#[ global ] Instance Fcompose_proper (fc1 fc2: Fchain)
                         (_ : Fchain_proper fc1)
                         (_ : Fchain_proper fc2) :
  Fchain_proper (Fcompose fc1 fc2).
(* end snippet FcomposeProper *)
Proof.
  unfold Fcompose; red;  intros.
  apply   (H _  _ _ _ M);
    (assumption ||
                intros u v Huv;  apply (H0 _ _ _ _ M);auto).
Qed.

#[ global ] Instance Fexp2_nat_proper (n:nat) :
                           Fchain_proper (Fexp2_of_nat n).
Proof.
  induction n; cbn.
   - apply F1_proper.
   - apply Fcompose_proper ; [apply F2_proper | apply IHn].
Qed.

Lemma  Fexp2_nat_correct (n:nat) :
                           Fchain_correct_nat (2  ^ n)
                                              (Fexp2_of_nat n).
Proof.
  induction n; cbn.
 - apply F1_correct.
 -  rewrite Nat.add_0_r;
   replace (2 ^ n + 2 ^ n)%nat with (2 * 2 ^n)%nat by  lia;
   apply Fcompose_correct_nat;auto.
   +  apply F2_correct.
   +  apply  Fexp2_nat_proper.
Qed.

(* begin snippet Fexp2Correct:: no-out *)
Lemma  Fexp2_correct (p:positive) :
  Fchain_correct (2 ^ p) (Fexp2 p).
(* end snippet Fexp2Correct *)
Proof.
 intros;red.
  rewrite Pos_pow_power, Pos2Nat_morph.
 generalize (Fexp2_nat_correct (Pos.to_nat p)).
 unfold Fexp2.
 change (Pos.to_nat 2) with 2%nat.
  replace (2 ^ Pos.to_nat p)%nat with (2%nat ^ Pos.to_nat p)%M.
 auto.
 now rewrite nat_power_ok.
Qed.

(* begin snippet Fexp2Proper:: no-out *)
#[ global ] Instance  Fexp2_proper (p:positive) : Fchain_proper (Fexp2 p).
(* end snippet Fexp2Proper *)
Proof.
  unfold  Fexp2; apply Fexp2_nat_proper.
Qed.

(** ** Remark

We are now  able to build chains for any exponent of the form
$2^k.3^p$, using Fcompose and previous lemmas.

Let us look at a simple example *)

(* begin snippet F144 *)
#[global] Hint Resolve F1_correct F1_proper
     F3_correct F3_proper Fcompose_correct Fcompose_proper
     Fexp2_correct Fexp2_proper : chains.

Example F144:  {f : Fchain | Fchain_correct 144 f /\
                             Fchain_proper f}. (* .no-out *)
Proof. (* .no-out *)
 change 144 with ( (3 * 3) * (2 ^ 4))%positive.
 exists (Fcompose (Fcompose F3 F3) (Fexp2 4)); auto with chains.
Defined.

Compute proj1_sig F144.
(* end snippet F144 *)

(*** K chains

 Not every chain can be built efficiently  with [Fcompose]
 For instance, consider the exponent $n=87 = 3 \times 29$.
29 is a prime
  number, thus it cannot be decomposed  as a product
  $p\times q$.
  On the other hand, consider the equality  $87 = 10 \times 8 + 7$.  We can plan to build a chain $c_1$ for computing $y = x^10$, then
 compose it with a chain $c_2$ for computing $y^8$, and finally
 multiply the result by $x^7$.
 But, if the chain $c_1$ contains also a computation of $x^7$,
 this value can be used for computing $x^{87} = x^{80}\times x^7$.

 In simpler words, we want to build computation schemes that
 compute two distinct powers of a given value $x$.
  Like in some programming languages
 that allow  "multiple values", we chosed to express this feature
 in terms of continuations that accept two arguments

*)

(** Bad solution *)

Module Bad4.

(* begin snippet Fplus:: no-out *)
Definition Fplus (f1 f2 : Fchain) : Fchain :=
  fun A k x => f1 A
                  (fun y =>
                     f2 A
                        (fun z => t <--- z times y; k t) x) x.

Example F23 := Fplus F3 (Fplus (Fexp2 4) (Fexp2 2)).

Lemma  F23_ok : chain_correct 23 (F2C F23).
Proof.
 param_chain_correct.
Qed.

(* end snippet Fplus *)

(* begin snippet Fplusb *)
Compute F23.
(* end snippet Fplusb *)

End Bad4.

(* begin snippet KchainDef *)
(** Continuations with two arguments *)

Definition Kkont A:=  A -> A -> @computation A.

(** CPS chain builders for  two exponents  *)

Definition Kchain :=  forall A, Kkont A -> A -> @computation A.

(* end snippet KchainDef *)

(** Kchain for $x^3$ and $x$ *)
(* begin snippet K31 *)

Example k3_1 : Kchain := fun A (k:Kkont A) (x:A) =>
  x2 <--- x times x ;
  x3 <--- x2 times x ;
  k x3 x.

(* end snippet K31 *)

(** Kchain for $x^37$ and $x^3$ *)

(* begin snippet K73 *)
Example k7_3 : Kchain := fun A (k:Kkont A)   (x:A) =>
  x2 <--- x times x;
  x3 <--- x2 times x ;
  x6 <--- x3 times x3 ;
  x7 <--- x6 times x ;
  k  x7 x3.
(* end snippet K73 *)

(** The Definition of correct chains and proper chains and
  continuations are adapted to Kchains *)

(* begin snippet KkontDefs *)
Definition Kkont_proper `(M : @EMonoid A op E_one E_equiv)
           (k : Kkont A) :=
 Proper (equiv ==> equiv ==> computation_equiv op E_equiv) k .

Definition Kkont_equiv  `(M : @EMonoid A op E_one E_equiv)
           (k k': Kkont A )  :=
 forall x y : A, x == y -> forall z t, z == t ->
         computation_equiv op E_equiv   (k  x z) (k' y t).
(* end snippet KkontDefs *)

(** A Kchain is correct with respect to two exponents $n$ and $p$
  if it computes $a ^ n$ and $a ^ p$ for every $a$ *)

About EMonoid.

(* begin snippet KchainCorrectDef *)
Definition Kchain_correct_nat (n p : nat) (kc : Kchain) :=
  forall  (A : Type) (op : Mult_op A) (E_one : A) (E_equiv : Equiv A)
          (M : EMonoid op E_one E_equiv)
          (k : Kkont A),
    Kkont_proper M k ->
    forall  (a : A) ,
      computation_execute op (kc  A k  a) ==
      computation_execute op (k  (a ^ n) (a ^ p)).

Definition Kchain_correct (n p : positive) (kc : Kchain) :=
  Kchain_correct_nat  (Pos.to_nat n) (Pos.to_nat p) kc.

Class Kchain_proper (kc : Kchain) :=
Kchain_proper_prf :
 forall `(M : @EMonoid A op E_one E_equiv) k k' x y ,
   Kkont_proper M k ->
   Kkont_proper M k' ->
   Kkont_equiv M k k' ->
   E_equiv x y ->
   computation_equiv op E_equiv (kc A k x) (kc A k' y).
(* end snippet KchainCorrectDef *)

(* begin snippet K73Ok:: no-out *)
#[ global ] Instance k7_3_proper : Kchain_proper k7_3.
Proof.
  intros until M; intros; red; unfold k7_3; cbn;
  add_op_proper M H3; apply H1;  rewrite H2;   reflexivity.
Qed.

Lemma k7_3_correct : Kchain_correct 7 3 k7_3.
Proof.
intros until M; intros; red; unfold k7_3; simpl.
  apply H;  monoid_simpl M;  reflexivity.
Qed.
(* end snippet K73Ok *)

 (** conversion between several definitions of correctness *)

Lemma Kchain_correct_conv (kc : Kchain) (n p : nat) :
  0%nat <> n -> 0%nat <> p ->
  Kchain_correct_nat n p kc ->
  Kchain_correct (Pos.of_nat n) (Pos.of_nat p) kc.
Proof.
  red; intros; repeat rewrite Nat2Pos.id; auto.
Qed.

(** ** More chain combinators

  Since we are working with two types of functional chains, we have to define
  several ways of composing them. Each of these operators is certified to
 preserve correctnes and properness *)

(** Conversion of Kchains into Fchains *)

(* begin snippet K2FDef *)
Definition K2F (knp : Kchain) : Fchain :=
  fun A (k:Fkont A) => knp A (fun  y _ => k y).
(* end snippet K2FDef *)

Lemma K2F_correct_nat :
  forall knp n p, Kchain_correct_nat  n p knp ->
                 Fchain_correct_nat n (K2F knp).
Proof.
 red;intros; unfold K2F;
 apply  (H _ _ _ _ M (fun x y => k x));
 intros x1 y1 H1 x2 y2 H2; apply Hk;  auto.
Qed.

(* begin snippet K2FCorrect:: no-out *)
Lemma K2F_correct :
  forall kc n p, Kchain_correct n p kc ->
                 Fchain_correct n (K2F kc).
(* end snippet K2FCorrect *)
Proof.
 red;intros; unfold K2F, Fchain_correct.
 apply K2F_correct_nat with (Pos.to_nat p);
 apply H.
Qed.

(* begin snippet K2FProper:: no-out *)
#[ global ] Instance K2F_proper (kc : Kchain)(_ : Kchain_proper kc) :
  Fchain_proper (K2F kc).
(* end snippet K2FProper *)
Proof.
 red;intros; unfold K2F;red.
 apply (H _ _ _ _ M).
 - red;intros; red;intros.
   intros x1 y1 Hx1 x2 y2 Hx2; now apply H0.
 - intros x1 y1 Hx1 x2 y2 Hx2; now apply H1.
 - red;intros;now apply H2.
 -  assumption.
Qed.

(**
  Using [kbr] for  computing $x^b$ and $x^r$, then using [Cq] for
  computing $x^{bq}$, then sending $x^{bq+r}$ and $x^b$ to the continuation
*)

(* begin snippet KFKDef *)
Definition KFK (kbr : Kchain) (fq : Fchain) : Kchain  :=
  fun A k a =>
    kbr A  (fun xb xr =>
              fq A (fun y =>
                      z <--- y times xr; k z xb) xb) a.
(* end snippet KFKDef *)

(* begin snippet KFFDef *)
Definition KFF (kbr : Kchain) (fq : Fchain) : Fchain :=
  K2F (KFK kbr fq).
(* end snippet KFFDef *)

(* begin snippet FFKDef *)
Definition FFK (fp fq : Fchain) : Kchain :=
  fun A k a =>  fp A (fun xb  => fq A (fun y => k y xb) xb) a.
(* end snippet FFKDef *)

(* begin snippet FKDef *)
Definition FK (f : Fchain) : Kchain :=
  fun (A : Type) (k : Kkont A) (a : A) =>
    f A (fun y => k y a) a.
(* end snippet FKDef *)

Example k17_7 := KFK k7_3 (Fexp2 1).

(** In the following section, we prove that the constructions KFK and KFF
   respect properness and correctness *)

Section KFK_proof.
 Variables b q r: nat.
 Variable kbr : Kchain.
 Variable fq : Fchain.
 Hypothesis Hbr : Kchain_correct_nat b r kbr.
 Hypothesis Hq : Fchain_correct_nat q fq.
 Hypothesis Hbr_prop : Kchain_proper kbr.
 Hypothesis Hq_prop : Fchain_proper fq.

 Lemma KFK_correct_nat : Kchain_correct_nat (b * q + r)%nat b (KFK kbr fq).
 Proof.
  intros until M; intros k H a;  unfold KFK;   simpl.
  add_op_proper M Hop.

  (** simplifying the hypotheses *)
  specialize (Hq _ _ _ _ M).
  specialize (Hbr_prop _ _ _ _ M).
  specialize (Hq_prop _ _ _ _ M).
  specialize (Hbr _ _ _ _ M (fun xb xr : A =>
          fq A (fun y : A => z <--- y times xr; k z xb) xb)).

  assert
    (Kkont_proper M
                  (fun xb xr : A =>
                     fq A
                        (fun y : A => z <--- y times xr; k z xb)
                        xb)).
 - intros x y Hxy z t Hzt;simpl; red;simpl.
   assert
     (forall X Y,
        X == Y ->
        computation_equiv op E_equiv
                          ((fun y0 : A =>
                              z0 <--- y0 times z; k z0 x) X)
                               ((fun y0 : A =>
                                   z0 <--- y0 times t; k z0 y) Y)).
   +  intros;  simpl;  red;  simpl;   apply H; auto.
      rewrite H0, Hzt; reflexivity.
   +  specialize (H0 x y Hxy); red in H0; simpl; simpl in H0.
      assert (Proper (computation_equiv op E_equiv  ==> equiv)
                     (computation_execute op)).
     *  intros X Y HXY; red in HXY; auto.
     *   apply H1; red;apply Hq_prop.
        red;intros;simpl;red;simpl; intros x1 y1 Hx1;  apply H.
        rewrite Hzt, Hx1;reflexivity.
        reflexivity.
        intros x1 y1 Hx1 ;apply H.
        rewrite Hx1;reflexivity.
        reflexivity.
        intros x1 y1 Hx1;simpl;red;simpl.
        apply H.
        rewrite Hx1, Hzt; reflexivity.
        assumption.
        assumption.
   -  specialize (Hbr H0 a); rewrite Hbr.
      specialize (Hq
                    (fun y : A =>
                       z <--- y times a ^ r; k z (a ^ b))).
      assert ( Fkont_proper M
                            (fun y : A =>
                               z <--- y times a ^ r; k z (a ^ b))).
   +  red; intros  x y Hxy; red; simpl.
       apply H.
       rewrite Hxy;reflexivity.
       reflexivity.
   + rewrite  (Hq  H1);simpl;apply H.
     monoid_simpl M.
     rewrite  (power_of_power M a b q).
     rewrite (Nat.mul_comm q b).
     rewrite power_of_plus; reflexivity.
     reflexivity.
Qed.

 Lemma KFF_correct_nat : Fchain_correct_nat (b * q + r)%nat (KFF kbr fq).
 Proof.
   apply K2F_correct_nat with b;  apply KFK_correct_nat.
 Qed.

Lemma KFK_proper : Kchain_proper (KFK kbr fq).
 Proof.
   intros until M; intros k k' x y Hk Hk' ;  unfold KFK;   simpl.
   add_op_proper M Hop.
   specialize (Hbr_prop _ _ _ _ M).
   specialize (Hq_prop _ _ _ _ M).
    red; simpl; intros; apply Hbr_prop;auto.
    - intros  x1 y1 Hx1 x2 y2 Hx2; apply Hq_prop;auto.
      + red; intros;simpl; intros x' y' H'; red;simpl; apply Hk.
        rewrite H';reflexivity.
        reflexivity.
      +  intros x' y' H'; red;simpl; apply Hk.
         rewrite H';reflexivity.
         reflexivity.
      + intros y0 y3 H3;red;simpl; apply Hk.
        rewrite H3,Hx2;reflexivity.
        assumption.
    -  red;intros;intros u v Huv w t Hwt.
       apply Hq_prop;auto.
       + intros X Y HXY;red;simpl; apply Hk'.
         * rewrite HXY;reflexivity.
         * reflexivity.
       + intros X Y HXY;red;simpl; apply Hk'.
         * rewrite HXY;reflexivity.
         * reflexivity.
       + red;intros;red;simpl; apply Hk';auto.
         rewrite H1, Hwt; reflexivity.
    -  red;intros;apply Hq_prop;auto.
       + intros X Y HXY;red;simpl;  apply Hk.
         * rewrite HXY;reflexivity.
         * reflexivity.
       + intros X Y HXY;red;simpl;  apply Hk'.
         * rewrite HXY;reflexivity.
         * reflexivity.
       + red;intros;red;simpl;  apply H; auto.
         * rewrite H2, H3;reflexivity.
Qed.

#[global] Instance KFF_proper : Fchain_proper (KFF kbr fq).
 Proof.
   intros until M; intros k k' Hk Hk' H x y Hxy;
   unfold KFF;   simpl.
   add_op_proper M Hop.
   specialize (Hbr_prop _ _ _ _ M).
   specialize (Hq_prop _ _ _ _ M).
    red; simpl; intros; apply Hbr_prop;auto.
    - intros  x1 y1 Hx1 x2 y2 Hx2; apply Hq_prop;auto.
      + red; intros;simpl; intros x' y' H'; red;simpl.  apply Hk.
        rewrite H';reflexivity.
      +   intros x' y' H'; red;simpl; apply Hk.
         rewrite H';reflexivity.
      +  intros y0 y3 H3;red;simpl; apply Hk.
        rewrite H3,Hx2;reflexivity.
    -  red;intros;intros u v Huv w t Hwt.
       apply Hq_prop;auto.
       + intros X Y HXY;red;simpl; apply Hk'.
         * rewrite HXY;reflexivity.
       + intros X Y HXY;red;simpl; apply Hk'.
         * rewrite HXY;reflexivity.
       + red;intros;red;simpl; apply Hk';auto.
         rewrite H0, Hwt; reflexivity.
    -  red;intros;apply Hq_prop;auto.
       + intros X Y HXY;red;simpl;  apply Hk.
         * rewrite HXY;reflexivity.
       + intros X Y HXY;red;simpl;  apply Hk'.
         * rewrite HXY;reflexivity.
       + red;intros;red;simpl;  apply H; auto.
         * rewrite H2, H1;reflexivity.
Qed.

End KFK_proof.
(* begin snippet KFKCorrect:: no-out *)
Lemma KFK_correct :
  forall (b q r : positive) (kbr : Kchain) (fq : Fchain),
    Kchain_correct  b r kbr ->
    Fchain_correct q fq ->
    Kchain_proper kbr ->
    Fchain_proper fq ->
    Kchain_correct  (b * q + r) b (KFK kbr fq).
(* end snippet KFKCorrect *)
Proof.
 red; intros; rewrite Pos2Nat.inj_add, Pos2Nat.inj_mul;
 apply KFK_correct_nat;assumption.
Qed.

(* begin snippet KFKProper *)
Check  KFK_proper.
(* end snippet KFKProper *)

(* begin snippet KFFProper *)
Check  KFK_proper.
(* end snippet KFFProper *)

(* begin snippet KFFCorrect:: no-out *)
Lemma KFF_correct :
  forall (b q r : positive) (kbr : Kchain) (fq : Fchain),
    Kchain_correct b r kbr  ->
    Fchain_correct q fq ->
    Kchain_proper kbr ->
    Fchain_proper fq ->
    Fchain_correct (b * q + r) (KFF kbr fq).
(* end snippet KFFCorrect *)
Proof.
  red; intros;  rewrite Pos2Nat.inj_add, Pos2Nat.inj_mul;
  apply KFF_correct_nat;assumption.
Qed.

Lemma FFK_correct_nat :
  forall (p q  : nat) (fp fq : Fchain),
    Fchain_correct_nat p fp  ->
    Fchain_correct_nat q fq ->
    Fchain_proper fp ->
    Fchain_proper fq -> Kchain_correct_nat  (p * q) p (FFK fp fq).
Proof.
intros.
red;intros.
 unfold FFK;   simpl.
  add_op_proper M Hop.

  (** simplifying the hypotheses *)
  specialize (H _ _ _ _ M).
  specialize (H0 _ _ _ _ M).
  specialize (H1 _ _ _ _ M).
  specialize (H2 _ _ _ _ M).
  specialize (H (fun xb : A => fq A (fun y : A => k y xb) xb)).
  assert (Fkont_proper M
                        (fun xb  : A => fq A
                                             (fun y : A =>  k y xb)
                                             xb)).
 - intros x y Hxy ;simpl; red;simpl.
   apply H2.
   +   intros  u v Huv; apply H3; (assumption || reflexivity).
   + intros  u v Huv; apply H3; (assumption || reflexivity).
   + intros  u v Huv; apply H3; (assumption || reflexivity).
   + assumption.

 -  specialize (H  H4 a); rewrite H.
    specialize (H0  (fun y => k y (a ^ p))).
    assert (Fkont_proper M (fun y : A => k y (a ^ p))).
      +  red; intros  x y Hxy; red; simpl;  apply H3;
         (assumption || reflexivity).
      + rewrite (H0 H5);  apply H3; [| reflexivity].
        rewrite  (power_of_power M a p q), (Nat.mul_comm q p);
       reflexivity.
Qed.

(* begin snippet FFKCorrect:: no-out *)
Lemma FFK_correct  (p q  : positive) (fp fq : Fchain):
    Fchain_correct p fp  ->
    Fchain_correct q fq ->
    Fchain_proper fp ->
    Fchain_proper fq ->
    Kchain_correct  (p * q ) p (FFK fp fq).
(* end snippet FFKCorrect *)
Proof.
 intros;red; rewrite  Pos2Nat.inj_mul; now apply FFK_correct_nat.
Qed.

(* begin snippet FFKProper:: no-out *)
#[ global ] Instance FFK_proper
         (fp fq : Fchain)
         (_ :   Fchain_proper fp)
         (_ :  Fchain_proper fq)
  :  Kchain_proper (FFK fp fq).
(* end snippet FFKProper *)
Proof.
 red;intros;
 specialize (H _ _ _ _ M); specialize (H0 _ _ _ _ M).
  add_op_proper M Hop; unfold FFK;simpl.
  red; simpl; intros;  apply H;auto.
 - intros  x1 y1 Hx1 ; apply H0;auto.
      +  intros x' y' H'; red;simpl;  apply H1;
        (assumption || reflexivity).
      +   intros x' y' H'; red;simpl; apply H1;
          (assumption || reflexivity).
      +  intros y0 y3 H5;red;simpl; apply H1; auto.
 -  intros u v Huv ;  apply H0;auto.
    + intros X Y HXY;red;simpl; apply H2;
      (assumption || reflexivity).
    + intros X Y HXY;red;simpl; apply H2;
      (assumption || reflexivity).
    + red;intros;red;simpl; apply H2;auto.
 -  red;intros; apply H0;auto.
    + intros X Y HXY;red;simpl;  apply H1;
      (assumption || reflexivity).
    + intros X Y HXY;red;simpl;  apply H2;
      (assumption || reflexivity).
    + red;intros;red;simpl; apply H3; auto.
Qed.

Lemma FK_correct : forall (p: positive) (Fp : Fchain),
                     Fchain_correct  p Fp ->
                     Fchain_proper Fp ->
                     Kchain_correct  p 1 (FK Fp).
Proof.
  intros;red; unfold FK;  red; intros until M;intros k H1 a.
  specialize (H _ _ _ _ M (fun y : A => k y a)).
  specialize (H0 _ _ _ _ M);
  add_op_proper M Hop.
  assert (Fkont_proper M (fun y : A => k y a)).
 -   intros x y Hxy; apply H1; (assumption || reflexivity).
 -  specialize (H H2 a);rewrite H;apply H1.
    + reflexivity.
    + generalize (power_eq3 a);simpl;now symmetry.
Qed.

#[ global ] Instance  FK_proper  (Fp : Fchain) (_ : Fchain_proper Fp):
  Kchain_proper (FK Fp).
Proof.
  unfold FK; intros until M; intros k k' x y  H0 H1 H2 H3.
  apply (H _ _ _ _ M).
  -  intros u v Huv;  apply H0; (assumption || reflexivity).
  - intros u v Huv;  apply H1; (assumption || reflexivity).
  - intros  u v Huv; apply H2; auto.
  -  assumption.
Qed.

(* begin snippet HintKchains *)
#[global] Hint Resolve KFF_correct KFF_proper KFK_correct KFK_proper : chains.
(* end snippet HintKchains *)

Lemma k3_1_correct : Kchain_correct 3 1 k3_1.
Proof.
  intros until M;intros k H a.
  unfold k3_1; simpl;  apply H; monoid_simpl M;reflexivity.
Qed.

Lemma k3_1_proper : Kchain_proper k3_1.
Proof.
  intros until M; intros k k' x y H H0 H1 H2.
  unfold k3_1;simpl.
  apply H1;auto.
  add_op_proper M H3; rewrite H2; reflexivity.
Qed.

#[global] Hint Resolve k3_1_correct k3_1_proper : chains.

(** an example of correct chain construction  *)

(* begin snippet F87 *)

Definition F87 :=
 let k7_3 :=  KFK k3_1 (Fexp2 1) in
 let k10_7 := KFK k7_3 F1 in
 KFF k10_7 (Fexp2 3).

Compute the_exponent (F2C F87).
(* end snippet F87 *)

(* begin snippet F87Correct:: no-out *)

Lemma OK87 : Fchain_correct 87 F87.
Proof.
 unfold F87; change 87 with (10 * (2 ^ 3) + 7)%positive.
 apply KFF_correct;auto with chains.
 change 10 with (7 * 1 + 3);
   apply KFK_correct;auto with chains.
 change 7 with (3 * 2 ^ 1 + 1)%positive;
   apply KFK_correct;auto with chains.
Qed.
(* end snippet F87Correct *)

Ltac compute_chain ch :=
   let X := fresh "x" in
   let Y := fresh "y" in
   let X := constr:(ch) in
   let Y := (eval vm_compute in  X)
   in exact Y.

Definition C87' := ltac:( compute_chain C87 ).

Print C87'.

Lemma PF87:  parametric C87'.
Proof. parametric_tac. Qed.

(** *** Automatic generation of correct euclidean chains

We want to define a function that builds a correct chain
for any positive exponent, using the previously defined
and certified composition operators : Fcompose, KFK, etc.

Obviously, we have to define total mutually recursive functions:

 - A function that builds an Fchain for any positive exponent p
 - A function that builds a Kchain for any pair of exponents
   (n,p) where $1<p<n$

 In Coq, various ways of building functions are available:
  - Structural [mutual] recursion with [Fixpoint]
  - Using [Program Fixpoint]
  - Using [Function]

 For simplicity's sake, we chosed to avoid dependent elimination
 and used [Function] with a decreasing measure.
 For this purpose, we define a single data-type for associated with
 the generation of F- and K-chains.

For specifying the computation of a Kchain for $n$ and $p$
where $p<n$, we use the pair of positive numbers $(p,n-p)$,
thus avoiding to propagate the constraint $p<n$ in
our definitions.
*)

(* begin snippet signature *)

Inductive signature : Type :=
| gen_F (n:positive) (** Fchain for the exponent n *)
| gen_K (p d: positive) (** Kchain for the exponents p+d  and p *).
(* end snippet signature *)

(** Unifying  statements about chain generation *)

(* begin snippet dependentlyTypedFuns *)

Definition signature_exponent (s:signature) : positive :=
 match s with
| gen_F n => n
| gen_K p d  =>  p + d
end.

Definition kont_type (s: signature)(A:Type) : Type :=
match s with
| gen_F _  => Fkont A
| gen_K _ _   => Kkont A
end.

Definition chain_type (s: signature) : Type :=
 match s with
| gen_F _   => Fchain
|  gen_K _ _  => Kchain
end.

Definition correctness_statement (s: signature) :
chain_type s -> Prop :=
match s  with
  | gen_F p => fun ch => Fchain_correct p ch
  | gen_K p d   => fun ch => Kchain_correct  (p + d) p ch
end.

Definition proper_statement (s: signature) :
chain_type s -> Prop :=
match s  with
  | gen_F _ => fun ch => Fchain_proper ch
  | gen_K _ _   => fun ch => Kchain_proper ch
end.

(** ** Full correctness *)

Definition  OK (s: signature)
  := fun c: chain_type s => correctness_statement s c /\
                            proper_statement s c.

(* end snippet dependentlyTypedFuns *)

#[global] Hint Resolve pos_gt_3 : chains.

(* begin snippet GammaContext *)
Section Gamma.
Variable gamma: positive -> positive.
Context (Hgamma : Strategy gamma).

Definition signature_measure (s : signature) : nat :=
match s with
  | gen_F n => 2 * Pos.to_nat n
  | gen_K  p d => 2 * Pos.to_nat (p + d) +1
end.
(* end snippet GammaContext *)

(* Proof obligations for chain generation (generated by Function) *)
(* These lemmas are also applied in AM *)

 Lemma PO1 :forall (s : signature) (i : positive),
  s = gen_F i ->
  forall anonymous : i <> 1,
  pos_eq_dec i 1 = right anonymous ->
  forall anonymous0 : i <> 3,
  pos_eq_dec i 3 = right anonymous0 ->
  exact_log2 i = None ->
  forall q r : N,
  r = 0%N ->
  N.pos_div_eucl i (N.pos (gamma i)) = (q, 0%N) ->
  (signature_measure (gen_F (N2pos q)) < signature_measure (gen_F i))%nat.

   intros; unfold signature_measure.
     generalize (N.pos_div_eucl_spec i (N.pos (gamma i))).
      rewrite H4; N2pos_destruct q p. (*destruct q; [discriminate | ].*)

    subst r; repeat rewrite  N.add_0_r.
    injection 1.  intro H5 ;rewrite H5.
    gamma_bounds gamma i H12 H14.
    assert (H13 : p <> 1).

   +  intro Hp ; subst p.  simpl in H5.
       destruct (Pos.lt_irrefl i).
       now rewrite H5 at 1.

   +  assert (H11 := pos_lt_mul p (gamma i) H12).
      rewrite Pos2Nat.inj_lt in  H11.
      rewrite  Pos2Nat.inj_mul in *;  lia.
      Qed.

 Lemma PO2 :  forall (s : signature) (i : positive),
     s = gen_F i ->
     forall anonymous : i <> 1,
       pos_eq_dec i 1 = right anonymous ->
       forall anonymous0 : i <> 3,
         pos_eq_dec i 3 = right anonymous0 ->
         exact_log2 i = None ->
         forall q r : N,
           r = 0%N ->
           N.pos_div_eucl i (N.pos (gamma i)) = (q, 0%N) ->
           (signature_measure (gen_F (gamma i)) < signature_measure (gen_F i))%nat.
 Proof.
   intros; unfold signature_measure.
   rewrite <- Nat.mul_lt_mono_pos_l;
     [ apply Pos2Nat.inj_lt; apply gamma_lt|] ;  auto with chains.
 Qed.

 Lemma PO3 :  forall (s : signature) (i : positive),
  s = gen_F i ->
  forall anonymous : i <> 1,
  pos_eq_dec i 1 = right anonymous ->
  forall anonymous0 : i <> 3,
  pos_eq_dec i 3 = right anonymous0 ->
  exact_log2 i = None ->
  forall (q r : N) (p : positive),
  r = N.pos p ->
  N.pos_div_eucl i (N.pos (gamma i)) = (q, N.pos p) ->
  (signature_measure (gen_F (N2pos q)) < signature_measure (gen_F i))%nat.
 Proof.
    intros; unfold signature_measure.
    gamma_bounds gamma i H12 H14.  quotient_small H4  H5.
    rewrite <- Nat.mul_lt_mono_pos_l ; [ | auto with arith chains].
    apply Pos2Nat.inj_lt.
      destruct q; simpl in *.
      transitivity (gamma i);auto.
      now rewrite pos2N_inj_lt.
      Qed.

 Lemma PO4 : forall (s : signature) (i : positive),
  s = gen_F i ->
  forall anonymous : i <> 1,
  pos_eq_dec i 1 = right anonymous ->
  forall anonymous0 : i <> 3,
  pos_eq_dec i 3 = right anonymous0 ->
  exact_log2 i = None ->
  forall (q r : N) (p : positive),
  r = N.pos p ->
  N.pos_div_eucl i (N.pos (gamma i)) = (q, N.pos p) ->
  (signature_measure (gen_K (N2pos (N.pos p)) (gamma i - N2pos (N.pos p))) <
   signature_measure (gen_F i))%nat.
intros; unfold signature_measure.
    apply lt_S_2i;  rewrite Pplus_minus.
    gamma_bounds gamma i H5 H6.
    +  apply Pos2Nat.inj_lt;  auto.
    +  rest_small H4 H5; now  apply Pos.lt_gt.
Qed.

 Lemma PO6: forall (s : signature) (p d : positive),
  s = gen_K p d ->
  forall anonymous : p <> 1,
  pos_eq_dec p 1 = right anonymous ->
  forall q r : N,
  r = 0%N ->
  N.pos_div_eucl (p + d) (N.pos p) = (q, 0%N) ->
  (signature_measure (gen_F (N2pos q)) < signature_measure (gen_K p d))%nat.
Proof.
intros; unfold signature_measure.
    quotient_small H2 H5.
    destruct p; (discriminate || reflexivity).
    N2pos_destruct q q.
    +       destruct (pos_div_eucl_quotient_pos _ _ _ _ H2);auto with chains.
           rewrite pos2N_inj_add; apply N.le_add_r.
    +  simpl; rewrite <- pos2N_inj_lt in H5;
       rewrite Pos2Nat.inj_lt in H5.
       lia.
Qed.

Lemma PO8 :forall (s : signature) (p d : positive),
  s = gen_K p d ->
  forall anonymous : p <> 1,
  pos_eq_dec p 1 = right anonymous ->
  forall (q r : N) (p0 : positive),
  r = N.pos p0 ->
  N.pos_div_eucl (p + d) (N.pos p) = (q, N.pos p0) ->
  (signature_measure (gen_F (N2pos q)) < signature_measure (gen_K p d))%nat.
Proof.
  intros; unfold signature_measure.
     assert (N2pos q < p+d)%positive.
    quotient_small H2 H5.
    generalize anonymous;
      destruct p; simpl; try reflexivity.
    now destruct 1.
    generalize (pos_div_eucl_quotient_pos  _ _ _ _ H2).
    intros H6;  destruct q;auto.
    destruct H6;auto with chains.
    rewrite pos2N_inj_add;  apply N.le_add_r;auto with chains.
    + revert H3; pos2nat_inj_tac; intros;lia.
Qed.

 Lemma PO9 :forall (s : signature) (p d : positive),
  s = gen_K p d ->
  forall anonymous : p <> 1,
  pos_eq_dec p 1 = right anonymous ->
  forall (q r : N) (p0 : positive),
  r = N.pos p0 ->
  N.pos_div_eucl (p + d) (N.pos p) = (q, N.pos p0) ->
  (signature_measure (gen_K (N2pos (N.pos p0)) (p - N2pos (N.pos p0))) <
   signature_measure (gen_K p d))%nat.
Proof.
intros; unfold signature_measure.
    apply Nat.add_lt_mono_r.
    rewrite <- (Nat.mul_lt_mono_pos_l (S _)); [| auto with arith].

    rewrite Pplus_minus.
    +  apply Pos2Nat.inj_lt; apply Pos.lt_add_diag_r; cbn.
    +  generalize (N.pos_div_eucl_remainder (p + d) (N.pos p) );
      rewrite H2; cbn; unfold N.lt ; intro H5; red.
       simpl in H5; now rewrite Pos.compare_antisym, H5.
Qed.
(* begin snippet chainGen:: no-out *)
Function chain_gen  (s:signature) {measure signature_measure}
:  chain_type s :=
  match s  return chain_type s with
    | gen_F i =>
      if pos_eq_dec i 1 then F1 else
        if pos_eq_dec i 3
        then F3
        else
          match exact_log2 i with
              Some p => Fexp2 p
            | _ =>
              match N.pos_div_eucl i (Npos (gamma i))
              with
                | (q, 0%N) =>
                  Fcompose  (chain_gen (gen_F (gamma i)))
                            (chain_gen (gen_F (N2pos q)))
                | (q,r)  => KFF (chain_gen
                                   (gen_K (N2pos r)
                                          (gamma i - N2pos r)))
                                (chain_gen (gen_F (N2pos q)))
              end end
    | gen_K p d =>
      if pos_eq_dec p 1 then FK (chain_gen (gen_F (1 + d)))
      else
        match N.pos_div_eucl (p + d)  (Npos p) with
          | (q, 0%N) => FFK   (chain_gen (gen_F p))
                              (chain_gen (gen_F (N2pos q)))
          | (q,r)  => KFK (chain_gen (gen_K (N2pos r)
                                            (p - N2pos r)))
                          (chain_gen (gen_F (N2pos q)))
        end
  end.
(* 9 Proof Obligations generated *)
(* end snippet chainGen *)
Proof.
  - intros; eapply PO1; eauto.
  - intros; eapply PO2; eauto.
  - intros; eapply PO3; eauto.
  - intros; eapply PO4; eauto.
  - intros; unfold signature_measure; subst p;  lia.
  - intros; eapply PO6; eauto.
  - intros; unfold signature_measure; pos2nat_inj_tac; lia.
  - intros; eapply PO8; eauto.
  - intros; eapply PO9; eauto.
Defined.

(* begin snippet makeChain *)
Definition make_chain (n:positive) : chain :=
 F2C (chain_gen (gen_F n)).
(* end snippet makeChain *)

(* begin snippet chainGenOK:: no-out *)
Lemma chain_gen_OK : forall s:signature,
    OK s (chain_gen  s).
Proof.
  intro s; functional induction chain_gen s.
  (*  A lot of arithmetic sub-proofs ... *)
  (* end snippet chainGenOK *)
  - split; [apply F1_correct | apply F1_proper].

  - split; [apply F3_correct | apply F3_proper].

  - generalize (exact_log2_spec _ _ e2);intro; subst i; split;
      [apply Fexp2_correct | apply Fexp2_proper].

  -  destruct IHc, IHc0.
     generalize (N_pos_div_eucl_divides _ _ _ e3); intro eq_i.
     split.
     + cbn.   rewrite <- eq_i at 1 ; apply Fcompose_correct;auto.
     +  pattern i at 1 ; rewrite <- eq_i at 1; apply Fcompose_proper;auto.

  -  pattern i at 1;
       replace i with (gamma i * (N2pos q) + N2pos r).
     + destruct IHc, IHc0;split.
       *  apply KFF_correct;auto.
          simpl; simpl in H.
          replace (gamma i) with
              (N2pos r + (gamma i - N2pos r)) at 1.
          apply H.
          rewrite Pplus_minus;auto with chains.
          apply Pos.lt_gt;   rewrite  N2pos_lt_switch2.
          generalize
            (N.pos_div_eucl_remainder i (N.pos (gamma i) ));
            rewrite e3;  simpl;auto with chains.
          destruct r; [ contradiction | auto with chains].
       *  apply KFF_proper;auto with chains.

     + apply  N_pos_div_eucl_rest; auto with chains.
       destruct r;try contradiction; auto with chains.
       apply (div_gamma_pos   _ _ _ e3); auto with chains.
       apply pos_gt_3;auto with chains.
       destruct (exact_log2 i); [contradiction | reflexivity].

  - destruct IHc; split.
    +   apply FK_correct; auto with chains.
    +  apply FK_proper; auto with chains.

  - destruct IHc, IHc0;split.
    +   red; replace (p + d)%positive with (p * N2pos q)%positive.
        * apply FFK_correct; auto with chains.
        *  generalize  (N.pos_div_eucl_spec   (p + d) (N.pos p));
             rewrite e1;    rewrite N.add_0_r ; intro  H3;
               case_eq (q * N.pos p)%N.
           intro H4;  rewrite H4 in H3 ; discriminate.
           intros p0 H4; rewrite H4 in H3; injection H3;
             intro H5;   rewrite H5.
           N2pos_destruct q q.
           injection H4;auto with chains.
           rewrite  Pos.mul_comm;  auto with chains.
    +   apply FFK_proper;auto with chains.

  -   destruct IHc, IHc0; split.
      + red; replace (p+d) with (p * N2pos q + N2pos r).
        * apply KFK_correct;auto with chains.
          red in H;   replace (N2pos r + (p - N2pos r))%positive with p in H.
          apply H.
          rewrite Pplus_minus;  auto.
          generalize  (N.pos_div_eucl_remainder (p + d) (N.pos p));
            rewrite e1; cbn;  intro H3.
          apply Pos.lt_gt;  rewrite  N2pos_lt_switch2;auto with chains.
          destruct r; [contradiction | auto with chains].

        *   generalize  (N.pos_div_eucl_spec   (p + d) (N.pos p));
              rewrite e1; intros H3; clear H H0 H1 H2.
            case_eq q.
            {intro;   generalize (pos_div_eucl_quotient_pos _ _ _ _ e1).
             destruct 1;auto with chains.
             rewrite pos2N_inj_add;  apply N.le_add_r.
            }
            {
              intros p0 Hp0;subst q; cbn; destruct r; [ contradiction | ].
              simpl;  simpl in H3;  injection H3.
              rewrite Pos.mul_comm; auto with chains.
            }
      +   apply KFK_proper;  auto with chains.
Qed.

(* begin snippet makeChainCorrect:: no-out *)
Theorem make_chain_correct : forall p, chain_correct p (make_chain p).
Proof.
  intro p; destruct (chain_gen_OK (gen_F p)).
  unfold make_chain; apply F2C_correct; apply H.
Qed.

End Gamma.
(* end snippet makeChainCorrect *)
Arguments make_chain gamma {_} _ _ _ .

(* begin snippet C87Dicho *)
Compute the_exponent (make_chain  dicho 87).
(* end snippet C87Dicho *)

(** cf Coq workshop 2014 by Jason Grosss *)

Module  Examples.

Import Int31.
Compute cpower (make_chain dicho) 10 12.
Compute cpower (make_chain dicho) 87 12.

Definition fast_int31_power (x :positive)(n:N) : Z :=
  Int31.phi (cpower (make_chain dicho) n (snd (positive_to_int31 x))).

Definition slow_int31_power (x :positive)(n:N) : Z :=
  Int31.phi (power (snd (positive_to_int31 x)) (N.to_nat n) ).

Definition binary_int31_power (x :positive)(n:N) : Z :=
Int31.phi (N_bpow (snd (positive_to_int31 x)) n ).

About make_chain.

(** long computations ... *)
(**
Definition big_chain := ltac:(compute_chain  (make_chain dicho 6145319)).

Print big_chain.

(*
big_chain =
fun (A : Type) (x : A) =>
x0 <--- x times x;
x1 <--- x0 times x0;
x2 <--- x1 times x1;
x3 <--- x2 times x1;
x4 <--- x3 times x3;
x5 <--- x4 times x;
x6 <--- x5 times x5;
x7 <--- x6 times x6;
x8 <--- x7 times x1;
x9 <--- x8 times x5;
x10 <--- x9 times x8;
x11 <--- x10 times x9;
x12 <--- x11 times x11;
x13 <--- x12 times x11;
x14 <--- x13 times x10;
x15 <--- x14 times x14;
x16 <--- x15 times x11;
x17 <--- x16 times x16;
x18 <--- x17 times x17;
x19 <--- x18 times x18;
x20 <--- x19 times x19;
x21 <--- x20 times x20;
x22 <--- x21 times x21;
x23 <--- x22 times x22;
x24 <--- x23 times x23;
x25 <--- x24 times x24;
x26 <--- x25 times x25;
x27 <--- x26 times x26; x28 <--- x27 times x14; Return x28
     : forall A : Type, A -> computation

Arguments big_chain _%type_scope
 *)

Remark RM : (1 < 56789)%N. Proof. reflexivity. Qed.

Definition M := Nmod_Monoid _ RM.

Definition exp56789 x := chain_apply big_chain (M:=M) x.

Time Compute chain_apply big_chain (M:=M) 13%N.

Eval cbv iota  match delta [big_chain chain_apply computation_eval  ]  zeta beta in  fun x => chain_apply  big_chain (M:=M) x.

Definition C87' := ltac:( compute_chain C87 ).

Print big_chain.
Time   Compute  Int31.phi
   (chain_apply big_chain (snd (positive_to_int31  67777))) .

Compute  Int31.phi (chain_apply big_chain (snd (positive_to_int31  67777))) .

Compute chain_length  big_chain.

Goal parametric (make_chain dicho 45319).
Time parametric_tac.
Qed.

Remark big_correct :chain_correct 45319 (make_chain dicho 45319).
Time param_chain_correct.
(* Finished transaction in 4.054 secs (4.051u,0.s) (successful) *)
Qed.

Remark big_correct' : chain_correct 453 (make_chain dicho 453).
Time reflection_correct_tac.
Qed.

(*** Too long :-(
Remark big_correct'' : chain_correct (make_chain 45319) 45319.
Time reflection_correct_tac.

That's normal. The reflection tactic builds a linear term w.r.t. the exponent !

*)

Remark big_correct''' : chain_correct 453 (make_chain dicho 453).
Time apply make_chain_correct.
(* Finished transaction in 0. secs (0.u,0.s) (successful)
*)
Qed.

Compute make_chain dicho 87.
(*
 fun (A : Type) (x : A) =>
       x0 <--- x times x; (* x^2 *)
       x1 <--- x0 times x; (* x^3 *)
       x2 <--- x1 times x1; (* x ^6 *)
       x3 <--- x2 times x;  (* x ^7 *)
       x4 <--- x3 times x1; (* x ^10 *)
       x5 <--- x4 times x4; (* x ^20 *)
       x6 <--- x5 times x5; (* x ^40 *)
       x7 <--- x6 times x6; (* x ^80 *)
       x8 <--- x7 times x3;  (* x ^87 *)
        Return x8
     : chain
 *)

Compute make_chain half 87.

(*

    = fun (A : Type) (x : A) =>
       x0 <--- x times x; (* x ^ 2 *)
       x1 <--- x0 times x0; (* x ^ 4 *)
       x2 <--- x1 times x;  (* x ^ 5 *)
       x3 <--- x2 times x2; (* x ^ 10 *)
       x4 <--- x3 times x3; (* x ^ 20 *)
       x5 <--- x4 times x;  (* x ^ 21 *)
       x6 <--- x5 times x5; (* x ^42 *)
       x7 <--- x6 times x; (* x ^ 43 *)
       x8 <--- x7 times x7; (* x ^86 *)
       x9 <--- x8 times x; (* x ^87 *)
  Return x9
     : chain
 *)

Compute make_chain two 87.

(*
fun (A : Type) (x : A) =>
       x0 <--- x times x;  (* x ^2 *)
       x1 <--- x0 times x0; (* x ^ 4 *)
       x2 <--- x1 times x1; (* x ^ 8 *)
       x3 <--- x2 times x2; (* x ^ 16 *)
       x4 <--- x3 times x3; (* x ^ 32 *)
       x5 <--- x4 times x4; (* x ^ 64 *)
       x6 <--- x5 times x3; (* x ^ 80 *)
       x7 <--- x6 times x1; (* x ^ 84 *)
       x8 <--- x7 times x0; (* x ^ 86 *)
       x9 <--- x8 times x; (*  x ^ 87 *)
     Return x9
     : chain

 *)
(**
Compute chain_length (make_chain two 56789).
(* 25%nat *)

Compute chain_length (make_chain half 56789).
(* 25%nat *)

Compute chain_length (make_chain dicho 56789).
(* 21%nat *)

Compute chain_length (make_chain two 3456789).
(* 33%nat *)

 Compute chain_length (make_chain half 3456789).
(* 33%nat *)
*)
Compute chain_length (make_chain dicho 3456789).
(* 29%nat *)

End Examples.

Require Import Extraction.
Locate exp56789.
Extraction Language OCaml.
Extraction "bigmod" Examples.exp56789.

*)

End Examples.
Recursive Extraction cpower.
Recursive Extraction make_chain.


(** This file corresponds to [FSetEqProperties.v] in the standard
   library and provides the same results for the typeclass-based
   version.
   *)

(** This module proves many properties of finite sets that
    are consequences of the axiomatization in [FsetInterface]
    Contrary to the functor in [FsetProperties] it uses
    sets operations instead of predicates over sets, i.e.
    [mem x s=true] instead of [In x s],
    [equal s s'=true] instead of [Equal s s'], etc. *)
Require Import SetInterface SetFacts SetDecide SetProperties.
Require Import Bool Zerob Sumbool Omega Structures.DecidableTypeEx.
Set Implicit Arguments.
Unset Strict Implicit.

Generalizable All Variables.
Local Open Scope set_scope.

Section BasicProperties.
(** Some old specifications written with boolean equalities. *)
  Context `{HF : @FSetSpecs elt Helt F}.
  Variables s s' s'' : set elt.
  Variables x y z : elt.

  Lemma mem_eq : x === y -> mem x s = mem y s.
  Proof.
    intros; rewrite H; auto.
  Qed.

  Lemma equal_mem_1 : (forall a, mem a s = mem a s') -> equal s s' = true.
  Proof.
    intros; apply equal_1; unfold Equal; intros.
    do 2 rewrite mem_iff; rewrite H; tauto.
  Qed.

  Lemma equal_mem_2 : equal s s'=true -> forall a, mem a s=mem a s'.
  Proof.
    intros; rewrite (equal_2 H); auto.
  Qed.

  Lemma subset_mem_1 :
    (forall a, mem a s=true->mem a s'=true) -> subset s s'=true.
  Proof.
    intros; apply subset_1; unfold Subset; intros a.
    do 2 rewrite mem_iff; auto.
  Qed.

  Lemma subset_mem_2 :
    subset s s'=true -> forall a, mem a s=true -> mem a s'=true.
  Proof.
    intros H a; do 2 rewrite <- mem_iff; apply subset_2; auto.
  Qed.

  Lemma empty_mem : mem x empty=false.
  Proof.
    intros; rewrite <- not_mem_iff; auto with set.
    intro abs; contradiction (empty_1 abs).
  Qed.

  Lemma is_empty_equal_empty : is_empty s = equal s empty.
  Proof.
    intros; apply bool_1; split; intros.
    auto with set.
    rewrite <- is_empty_iff; auto with set.
  Qed.

  Lemma choose_mem_1 : choose s=Some x -> mem x s=true.
  Proof.
    auto with set.
  Qed.

  Lemma choose_mem_2 : choose s=None -> is_empty s=true.
  Proof.
    auto with set.
  Qed.

  Lemma add_mem_1 : mem x (add x s)=true.
  Proof.
    auto with set.
  Qed.

  Lemma add_mem_2 : x =/= y -> mem y (add x s)=mem y s.
  Proof.
    apply add_neq_b.
  Qed.

  Lemma remove_mem_1 : mem x (remove x s)=false.
  Proof.
    intros; rewrite <- not_mem_iff; auto with set.
  Qed.

  Lemma remove_mem_2 : x =/= y -> mem y (remove x s)=mem y s.
  Proof.
    apply remove_neq_b.
  Qed.

  Lemma singleton_equal_add : equal (singleton x) (add x empty)=true.
  Proof.
    intros; rewrite (singleton_equal_add x); auto with set.
  Qed.

  Lemma union_mem : mem x (union s s')=mem x s || mem x s'.
  Proof.
    apply union_b.
  Qed.

  Lemma inter_mem : mem x (inter s s')=mem x s && mem x s'.
  Proof.
    apply inter_b.
  Qed.

  Lemma diff_mem : mem x (diff s s')=mem x s && negb (mem x s').
  Proof.
    apply diff_b.
  Qed.

  (** properties of [mem] *)

  Lemma mem_3 : ~In x s -> mem x s=false.
  Proof.
    intros; rewrite <- not_mem_iff; auto.
  Qed.

  Lemma mem_4 : mem x s=false -> ~In x s.
  Proof.
    intros; rewrite not_mem_iff; auto.
  Qed.

  (** Properties of [equal] *)

  Lemma equal_refl : equal s s=true.
  Proof.
    auto with set.
  Qed.

  Lemma equal_sym : equal s s'=equal s' s.
  Proof.
    intros; apply bool_1; do 2 rewrite <- equal_iff; intuition.
  Qed.

  Lemma equal_trans : equal s s'=true -> equal s' s''=true -> equal s s''=true.
  Proof.
    intros; rewrite (equal_2 H); auto.
  Qed.

  Lemma equal_equal : equal s s'=true -> equal s s''=equal s' s''.
  Proof.
    intros; rewrite (equal_2 H); auto.
  Qed.

  Lemma equal_cardinal : equal s s'=true -> cardinal s=cardinal s'.
  Proof.
    auto with set.
  Qed.

  (* Properties of [subset] *)

  Lemma subset_refl : subset s s=true.
  Proof.
    auto with set.
  Qed.

  Lemma subset_antisym :
    subset s s'=true -> subset s' s=true -> equal s s'=true.
  Proof.
    auto with set.
  Qed.

  Lemma subset_trans :
    subset s s'=true -> subset s' s''=true -> subset s s''=true.
  Proof.
    intros; rewrite <- !subset_iff; intros.
    apply subset_trans with s'; auto with set.
  Qed.

  Lemma subset_equal : equal s s'=true -> subset s s'=true.
  Proof.
    auto with set.
  Qed.

(** Properties of [choose] *)

  Lemma choose_mem_3 :
    is_empty s=false -> {x:elt|choose s=Some x /\ mem x s=true}.
  Proof.
    intros.
    generalize (@choose_1 _ _ _ _ s) (@choose_2 _ _ _ _ s).
    destruct (choose s);intros.
    exists e;auto with set.
    generalize (H1 (refl_equal None)); clear H1.
    intros; rewrite (is_empty_1 H1) in H; discriminate.
  Qed.

  Lemma choose_mem_4 : choose empty=None.
  Proof.
    intros; generalize (@choose_1 _ _ _ _ empty).
    case (@choose _ _ _ empty);intros;auto.
    elim (@empty_1 _ _ _ _ e); auto.
  Qed.

  (** Properties of [add] *)

  Lemma add_mem_3 : mem y s=true -> mem y (add x s)=true.
  Proof.
    auto with set.
  Qed.

  Lemma add_equal : mem x s=true -> equal (add x s) s=true.
  Proof.
    auto with set.
  Qed.

  (** Properties of [remove] *)

  Lemma remove_mem_3 : mem y (remove x s)=true -> mem y s=true.
  Proof.
    rewrite remove_b; auto; intros H;destruct (andb_prop _ _ H); auto.
  Qed.

  Lemma remove_equal : mem x s=false -> equal (remove x s) s=true.
  Proof.
    intros; apply equal_1; apply remove_equal.
    rewrite not_mem_iff; auto.
  Qed.

  Lemma add_remove : mem x s=true -> equal (add x (remove x s)) s=true.
  Proof.
    intros; apply equal_1; apply add_remove; auto with set.
  Qed.

  Lemma remove_add : mem x s=false -> equal (remove x (add x s)) s=true.
  Proof.
    intros; apply equal_1; apply remove_add; auto.
    rewrite not_mem_iff; auto.
  Qed.

  (** Properties of [is_empty] *)

  Lemma is_empty_cardinal: is_empty s = zerob (cardinal s).
  Proof.
    intros; apply bool_1; split; intros.
    rewrite cardinal_1; simpl; auto with set.
    assert (cardinal s = 0) by (apply zerob_true_elim; auto).
    auto with set.
  Qed.

  (** Properties of [singleton] *)

  Lemma singleton_mem_1 : mem x (singleton x)=true.
  Proof.
    auto with set.
  Qed.

  Lemma singleton_mem_2 : x =/= y -> mem y (singleton x)=false.
  Proof.
    intros; rewrite singleton_b; auto.
    unfold eqb; destruct (eq_dec x y); intuition contradiction.
  Qed.

  Lemma singleton_mem_3 : mem y (singleton x)=true -> x === y.
  Proof.
    intros; apply singleton_1; auto with set.
  Qed.

  (** Properties of [union] *)

  Lemma union_sym : equal (union s s') (union s' s)=true.
  Proof.
    auto with set.
  Qed.

  Lemma union_subset_equal : subset s s'=true -> equal (union s s') s'=true.
  Proof.
    auto with set.
  Qed.

  Lemma union_equal_1 :
    equal s s'=true-> equal (union s s'') (union s' s'')=true.
  Proof.
    auto with set.
  Qed.

  Lemma union_equal_2 :
    equal s' s''=true-> equal (union s s') (union s s'')=true.
  Proof.
    auto with set.
  Qed.

  Lemma union_assoc :
    equal (union (union s s') s'') (union s (union s' s''))=true.
  Proof.
    auto with set.
  Qed.

  Lemma add_union_singleton : equal (add x s) (union (singleton x) s)=true.
  Proof.
    auto with set.
  Qed.

  Lemma union_add : equal (union (add x s) s') (add x (union s s'))=true.
  Proof.
    auto with set.
  Qed.

  (* caracterisation of [union] via [subset] *)

  Lemma union_subset_1 : subset s (union s s')=true.
  Proof.
    auto with set.
  Qed.

  Lemma union_subset_2 : subset s' (union s s')=true.
  Proof.
    auto with set.
  Qed.

  Lemma union_subset_3  :
    subset s s''=true -> subset s' s''=true -> subset (union s s') s''=true.
  Proof.
    intros; apply subset_1; apply union_subset_3; auto with set.
  Qed.

  (** Properties of [inter] *)

  Lemma inter_sym : equal (inter s s') (inter s' s)=true.
  Proof.
    auto with set.
  Qed.

  Lemma inter_subset_equal : subset s s'=true -> equal (inter s s') s=true.
  Proof.
    auto with set.
  Qed.

  Lemma inter_equal_1 :
    equal s s'=true -> equal (inter s s'') (inter s' s'')=true.
  Proof.
    auto with set.
  Qed.

  Lemma inter_equal_2 :
    equal s' s''=true -> equal (inter s s') (inter s s'')=true.
  Proof.
    auto with set.
  Qed.

  Lemma inter_assoc :
    equal (inter (inter s s') s'') (inter s (inter s' s''))=true.
  Proof.
    auto with set.
  Qed.

  Lemma union_inter_1 :
      equal (inter (union s s') s'') (union (inter s s'') (inter s' s''))=true.
  Proof.
    auto with set.
  Qed.

  Lemma union_inter_2 :
      equal (union (inter s s') s'') (inter (union s s'') (union s' s''))=true.
  Proof.
    auto with set.
  Qed.

  Lemma inter_add_1 :
    mem x s'=true -> equal (inter (add x s) s') (add x (inter s s'))=true.
  Proof.
    auto with set.
  Qed.

  Lemma inter_add_2 :
    mem x s'=false -> equal (inter (add x s) s') (inter s s')=true.
  Proof.
    intros; apply equal_1; apply inter_add_2.
    rewrite not_mem_iff; auto.
  Qed.

  (* caracterisation of [union] via [subset] *)

  Lemma inter_subset_1 : subset (inter s s') s=true.
  Proof.
    auto with set.
  Qed.

  Lemma inter_subset_2 : subset (inter s s') s'=true.
  Proof.
    auto with set.
  Qed.

  Lemma inter_subset_3 :
    subset s'' s=true -> subset s'' s'=true -> subset s'' (inter s s')=true.
  Proof.
    intros; apply subset_1; apply inter_subset_3; auto with set.
  Qed.

  (** Properties of [diff] *)

  Lemma diff_subset : subset (diff s s') s=true.
  Proof.
    auto with set.
  Qed.

  Lemma diff_subset_equal : subset s s'=true -> equal (diff s s') empty=true.
  Proof.
    auto with set.
  Qed.

  Lemma remove_inter_singleton :
    equal (remove x s) (diff s (singleton x))=true.
  Proof.
    auto with set.
  Qed.

  Lemma diff_inter_empty : equal (inter (diff s s') (inter s s')) empty=true.
  Proof.
    auto with set.
  Qed.

  Lemma diff_inter_all : equal (union (diff s s') (inter s s')) s=true.
  Proof.
    auto with set.
  Qed.

End BasicProperties.

Hint Immediate @empty_mem @is_empty_equal_empty @add_mem_1
  @remove_mem_1 @singleton_equal_add @union_mem @inter_mem
  @diff_mem @equal_sym @add_remove @remove_add : set.
Hint Resolve @equal_mem_1 @subset_mem_1 @choose_mem_1
  @choose_mem_2 @add_mem_2 @remove_mem_2 @equal_refl @equal_equal
  @subset_refl @subset_equal @subset_antisym
  @add_mem_3 @add_equal @remove_mem_3 @remove_equal : set.

(** General recursion principle *)

Lemma set_rec `{HF : @FSetSpecs A HA F} :
  forall (P: set A -> Type),
 (forall s s', equal s s'=true -> P s -> P s') ->
 (forall s x, mem x s=false -> P s -> P (add x s)) ->
 P empty -> forall s, P s.
Proof.
  intros.
  apply set_induction; auto; intros.
  apply X with empty; auto with set.
  apply X with (add x s0); auto with set.
  apply equal_1; intro a; rewrite add_iff; rewrite (H0 a); tauto.
  apply X0; auto with set; apply mem_3; auto.
Qed.

(** Properties of [fold] *)

Lemma exclusive_set `{HF : @FSetSpecs A HA F} :
  forall s s' x, ~(In x s/\In x s') <-> mem x s && mem x s'=false.
Proof.
  intros; do 2 rewrite mem_iff.
  destruct (mem x s); destruct (mem x s'); intuition.
Qed.

Section Fold.
  Context `{HF : @FSetSpecs elt Helt F}.

  Variable A : Type.
  Variable eqA : relation A.
  Context {st : Equivalence eqA}.

  Variable (f:elt->A->A).
  Context {Comp : Proper (_eq ==> eqA ==> eqA) f}.
  Hypothesis Ass :transpose eqA f.

  Variable (i:A).
  Variables (s s':set elt)(x:elt).

  Lemma fold_empty : (fold f empty i) = i.
  Proof.
    intros; apply (fold_empty); auto.
  Qed.

  Lemma fold_equal : equal s s'=true -> eqA (fold f s i) (fold f s' i).
  Proof.
    intros; apply (fold_equal (eqA:=eqA)); auto with set.
  Qed.

  Lemma fold_add :
    mem x s=false -> eqA (fold f (add x s) i) (f x (fold f s i)).
  Proof.
    intros; apply (fold_add (eqA:=eqA)); auto.
    rewrite not_mem_iff; auto.
  Qed.

  Lemma add_fold : mem x s=true -> eqA (fold f (add x s) i) (fold f s i).
  Proof.
    intros; apply (add_fold (eqA:=eqA)); auto with set.
  Qed.

  Lemma remove_fold_1 :
    mem x s=true -> eqA (f x (fold f (remove x s) i)) (fold f s i).
  Proof.
    intros; apply (remove_fold_1 (eqA:=eqA)); auto with set.
  Qed.

  Lemma remove_fold_2 :
    mem x s=false -> eqA (fold f (remove x s) i) (fold f s i).
  Proof.
    intros; apply (remove_fold_2 (eqA:=eqA)); auto.
    rewrite not_mem_iff; auto.
  Qed.

  Lemma fold_union :
    (forall x, mem x s && mem x s'=false) ->
    eqA (fold f (union s s') i) (fold f s (fold f s' i)).
  Proof.
    intros; apply (fold_union (eqA:=eqA)); auto.
    intros; rewrite exclusive_set; auto.
  Qed.
End Fold.

(** Properties of [cardinal] *)

Lemma add_cardinal_1 `{HF : @FSetSpecs A HA F} :
 forall s x, mem x s=true -> cardinal (add x s)=cardinal s.
Proof.
  auto with set.
Qed.

Lemma add_cardinal_2 `{HF : @FSetSpecs A HA F} :
  forall s x, mem x s=false -> cardinal (add x s)=S (cardinal s).
Proof.
  intros; apply add_cardinal_2; auto.
  rewrite not_mem_iff; auto.
Qed.

Lemma remove_cardinal_1 `{HF : @FSetSpecs A HA F} :
  forall s x, mem x s=true -> S (cardinal (remove x s))=cardinal s.
Proof.
  intros; apply remove_cardinal_1; auto with set.
Qed.

Lemma remove_cardinal_2 `{HF : @FSetSpecs A HA F} :
  forall s x, mem x s=false -> cardinal (remove x s)=cardinal s.
Proof.
  intros; apply Equal_cardinal; apply equal_2; auto with set.
Qed.

Lemma union_cardinal `{HF : @FSetSpecs A HA F} :
  forall s s', (forall x, mem x s && mem x s'=false) ->
    cardinal (union s s')=cardinal s+cardinal s'.
Proof.
  intros; apply union_cardinal; auto; intros.
  rewrite exclusive_set; auto.
Qed.

Lemma subset_cardinal `{HF : @FSetSpecs A HA F} :
  forall s s', subset s s'=true -> cardinal s<=cardinal s'.
Proof.
  intros; apply subset_cardinal; auto with set.
Qed.

Section Bool.
(** Properties of [filter] *)
  Context `{HF : @FSetSpecs elt Helt F}.

  Variable (f : elt -> bool).
  Context {Comp : Proper (_eq ==> @eq bool) f}.

  Definition Comp' : Proper (_eq ==> @eq bool) (fun x => negb (f x)).
  Proof.
    repeat intro; f_equal; auto.
  Qed.
  Hint Immediate Comp'.

  Lemma filter_mem : forall s x, mem x (filter f s)=mem x s && f x.
  Proof.
    intros; apply filter_b; auto.
  Qed.

  Lemma for_all_filter :
    forall s, for_all f s=is_empty (filter (fun x => negb (f x)) s).
  Proof.
    intros; apply bool_1; split; intros.
    apply is_empty_1.
    unfold Empty; intros.
    rewrite filter_iff; auto using Comp'.
    red; destruct 1.
    rewrite <- for_all_iff in H; auto.
    rewrite (H a H0) in H1; discriminate.
    apply for_all_1; auto; red; intros.
    revert H; rewrite <- is_empty_iff.
    unfold Empty; intro H; generalize (H x); clear H.
    rewrite filter_iff; auto using Comp'.
    destruct (f x); auto.
  Qed.

  Lemma exists_filter : forall s, exists_ f s=negb (is_empty (filter f s)).
  Proof.
    intros; apply bool_1; split; intros.
    destruct (exists_2 H) as (a,(Ha1,Ha2)).
    apply bool_6.
    red; intros; apply (@is_empty_2 _ _ _ _ _ H0 a); auto with set.
    generalize (@choose_1 _ _ _ _ (filter f s))
      (@choose_2 _ _ _ _ (filter f s)).
    destruct (choose (filter f s)).
    intros H0 _; apply exists_1; auto.
    exists e; generalize (H0 e); rewrite filter_iff; auto.
    intros _ H0.
    rewrite (is_empty_1 (H0 (refl_equal None))) in H; auto; discriminate.
  Qed.

  Lemma partition_filter_1 :
    forall s, equal (fst (partition f s)) (filter f s)=true.
  Proof.
    auto with set.
  Qed.

  Lemma partition_filter_2 :
    forall s, equal (snd (partition f s)) (filter (fun x => negb (f x)) s)=true.
  Proof.
    auto with set.
  Qed.

  Lemma filter_add_1 :
    forall s x, f x = true -> filter f (add x s) [=] add x (filter f s).
  Proof.
    red; intros; set_iff; do 2 (rewrite filter_iff; auto); set_iff.
    intuition.
    rewrite <- H; apply Comp; auto.
  Qed.

  Lemma filter_add_2 :
    forall s x, f x = false -> filter f (add x s) [=] filter f s.
  Proof.
    red; intros; do 2 (rewrite filter_iff; auto); set_iff.
    intuition.
    assert (f x = f a) by (apply Comp; auto).
    rewrite H in H1; rewrite H2 in H1; discriminate.
  Qed.

  Lemma add_filter_1 :
    forall s s' x,
      f x=true -> (Add x s s') -> (Add x (filter f s) (filter f s')).
  Proof.
    unfold Add; intros.
    repeat rewrite filter_iff; auto.
    rewrite H0; clear H0.
    assert (x === y -> f y = true) by
      (intro H0; rewrite <- (Comp H0); auto).
    tauto.
  Qed.

  Lemma add_filter_2 :
    forall s s' x, f x=false -> (Add x s s') -> filter f s [=] filter f s'.
  Proof.
    unfold Add, Equal; intros.
    repeat rewrite filter_iff; auto.
    rewrite H0; clear H0.
    assert (f a = true -> x =/= a).
    intros H0 H1.
    rewrite (Comp H1) in H.
    rewrite H in H0; discriminate.
    intuition contradiction.
  Qed.

  Lemma union_filter
    (g : elt -> bool) `{Compg : Proper _ (_eq ==> @eq bool) g} :
    forall s,
      union (filter f s) (filter g s) [=] filter (fun x=>orb (f x) (g x)) s.
  Proof.
    intros.
    unfold Equal; intros; set_iff; repeat rewrite filter_iff; auto.
    assert (f a || g a = true <-> f a = true \/ g a = true).
    split; auto with bool.
    intro H3; destruct (orb_prop _ _ H3); auto.
    tauto.
    repeat intro; rewrite H; auto.
  Qed.

  Lemma filter_union :
    forall s s', filter f (union s s') [=] union (filter f s) (filter f s').
  Proof.
    unfold Equal; intros; set_iff;
      repeat rewrite filter_iff; auto; set_iff; tauto.
  Qed.

  (** Properties of [for_all] *)

  Lemma for_all_mem_1 :
    forall s, (forall x, (mem x s)=true->(f x)=true) -> (for_all f s)=true.
  Proof.
    intros.
    rewrite for_all_filter; auto.
    rewrite is_empty_equal_empty.
    apply equal_mem_1;intros.
    rewrite filter_b; auto using Comp'.
    rewrite empty_mem.
    generalize (H a); case (mem a s);intros;auto.
    rewrite H0;auto.
  Qed.

  Lemma for_all_mem_2 :
    forall s, (for_all f s)=true -> forall x,(mem x s)=true -> (f x)=true.
  Proof.
    intros.
    rewrite for_all_filter in H; auto.
    rewrite is_empty_equal_empty in H.
    generalize (equal_mem_2 H x).
    rewrite filter_b; auto using Comp'.
    rewrite empty_mem.
    rewrite H0; simpl;intros.
    replace true with (negb false);auto;apply negb_sym;auto.
  Qed.

  Lemma for_all_mem_3 :
    forall s x,(mem x s)=true -> (f x)=false -> (for_all f s)=false.
  Proof.
    intros.
    apply (bool_eq_ind (for_all f s));intros;auto.
    rewrite for_all_filter in H1; auto.
    rewrite is_empty_equal_empty in H1.
    generalize (equal_mem_2 H1 x).
    rewrite filter_b; auto using Comp'.
    rewrite empty_mem.
    rewrite H.
    rewrite H0.
    simpl;auto.
  Qed.

  Lemma for_all_mem_4 :
    forall s, for_all f s=false -> {x:elt | mem x s=true /\ f x=false}.
  Proof.
    intros.
    rewrite for_all_filter in H; auto.
    destruct (choose_mem_3 H) as (x,(H0,H1));intros.
    exists x.
    rewrite filter_b in H1; eauto.
    elim (andb_prop _ _ H1).
    split;auto.
    replace false with (negb true);auto;apply negb_sym;auto.
    exact Comp'.
  Qed.

  (** Properties of [exists] *)

  Lemma for_all_exists :
    forall s, exists_ f s = negb (for_all (fun x =>negb (f x)) s).
  Proof.
    intros.
    rewrite for_all_b; auto using Comp'.
    rewrite exists_b; auto.
    induction (elements s); simpl; auto.
    destruct (f a); simpl; auto.
  Qed.

End Bool.

Section Bool'.
  Context `{HF : @FSetSpecs elt Helt F}.

  Variable (f : elt -> bool).
  Context {Comp : Proper (_eq ==> @eq bool) f}.

  Lemma exists_mem_1 :
    forall s, (forall x, mem x s=true->f x=false) -> exists_ f s=false.
  Proof.
    intros.
    rewrite for_all_exists; auto.
    rewrite for_all_mem_1;auto with bool; auto using Comp'.
    intros;generalize (H x H0);intros.
    symmetry;apply negb_sym;simpl;auto.
  Qed.

  Lemma exists_mem_2 :
    forall s, exists_ f s=false -> forall x, mem x s=true -> f x=false.
  Proof.
    intros; set (C' := Comp' (f:=f)).
    rewrite for_all_exists in H; auto.
    replace false with (negb true);auto;apply negb_sym;symmetry.
    eapply (for_all_mem_2 (f:= fun x => negb (f x)) (s:=s)); simpl; auto.
    replace true with (negb false);auto;apply negb_sym;auto.
  Qed.

  Lemma exists_mem_3 :
    forall s x, mem x s=true -> f x=true -> exists_ f s=true.
  Proof.
    intros.
    rewrite for_all_exists; auto.
    symmetry;apply negb_sym;simpl.
    apply for_all_mem_3 with x;auto using Comp'.
    rewrite H0;auto.
  Qed.

  Lemma exists_mem_4 :
    forall s, exists_ f s=true -> {x:elt | (mem x s)=true /\ (f x)=true}.
  Proof.
    intros; set (C' := Comp' (f:=f)).
    rewrite for_all_exists in H; auto.
    elim (for_all_mem_4 (f:=(fun x =>negb (f x))) (s:=s));intros.
    elim p;intros.
    exists x;split;auto.
    replace true with (negb false);auto;apply negb_sym;auto.
    replace false with (negb true);auto;apply negb_sym;auto.
  Qed.
End Bool'.

Section Sum.
  Context `{HF : @FSetSpecs elt Helt F}.

  (** Adding a valuation function on all elements of a set. *)
  Definition sum (f:elt -> nat)(s:set elt) := fold (fun x => plus (f x)) s 0.
  Notation compat_opL := (Proper (_eq ==> @eq nat ==> @eq nat)).
  Notation transposeL := (transpose (@Logic.eq _)).

  Lemma sum_plus :
    forall (f g : elt -> nat)
      `{Proper _ (_eq ==> @eq nat) f, Proper _ (_eq ==> @eq nat) g},
      forall s, sum (fun x =>f x+g x) s = sum f s + sum g s.
  Proof.
    unfold sum.
    intros f g Hf Hg.
    assert (fc : compat_opL (fun x:elt =>plus (f x))). repeat intro;  auto.
    assert (ft : transposeL (fun x:elt =>plus (f x))). red; repeat intro; omega.
    assert (gc : compat_opL (fun x:elt => plus (g x))). repeat intro; auto.
    assert (gt : transposeL (fun x:elt =>plus (g x))). red; repeat intro; omega.
    assert (fgc : compat_opL (fun x:elt =>plus ((f x)+(g x)))).
    repeat intro; auto.
    assert (fgt : transposeL (fun x:elt=>plus ((f x)+(g x)))).
    red; repeat intro; omega.
    assert (st : Equivalence (@Logic.eq nat)) by (split; congruence).
    intros s;pattern s; apply set_rec.
    intros.
    rewrite <- (fold_equal ft 0 H).
    rewrite <- (fold_equal gt 0 H).
    rewrite <- (fold_equal fgt 0 H); auto.
    intros; do 3 (rewrite fold_add;auto).
    rewrite H0;simpl;omega.
    repeat rewrite (fold_empty); auto.
  Qed.

  Lemma sum_filter :
    forall f `{Proper _ (_eq ==> @eq bool) f},
      forall s,
        (sum (fun x => if f x then 1 else 0) s) = (cardinal (filter f s)).
  Proof.
    unfold sum; intros f Hf.
    assert (st : Equivalence (@Logic.eq nat)) by (split; congruence).
    assert (cc : compat_opL (fun x => plus (if f x then 1 else 0))).
    red; repeat intro. rewrite (Hf _ _ H); auto.
    assert (ct : transposeL (fun x => plus (if f x then 1 else 0))).
    red; intros; omega.
    intros s;pattern s; apply set_rec.
    intros.
    rewrite <- (fold_equal ct 0 H).
    rewrite (filter_m (equal_2 H)) in H0; auto.
    intros; rewrite (fold_add ct); auto.
    generalize (@add_filter_1 _ _ _ _ f _ s0 (add x s0) x)
      (@add_filter_2 _ _ _ _ f _ s0 (add x s0) x) .
    assert (~ In x (filter f s0)).
    intro H1; rewrite (mem_1 (filter_1 H1)) in H; discriminate H.
    case (f x); simpl; intros.
    rewrite (cardinal_2 H1 (H2 (refl_equal true) (Add_add s0 x))); auto.
    rewrite <- (Equal_cardinal (H3 (refl_equal false) (Add_add s0 x))); auto.
    intros; rewrite (fold_empty);auto.
    rewrite cardinal_1; auto.
    unfold Empty; intros.
    rewrite filter_iff; auto; set_iff; tauto.
  Qed.

  Lemma fold_compat : forall
    (A : Type) (eqA : relation A) `{st : Equivalence A eqA}
    (f g : elt -> A -> A)
    `{Compf : Proper _ (_eq ==> eqA ==> eqA) f,
      Compg : Proper _ (_eq ==> eqA ==> eqA) g}
    (Assf : transpose eqA f) (Assg : transpose eqA g),
    forall (i:A)(s:set elt),
      (forall x:elt, (In x s) -> forall y, (eqA (f x y) (g x y))) ->
      (eqA (fold f s i) (fold g s i)).
  Proof.
    intros A eqA st f g fc ft gc gt i.
    intro s; pattern s; apply set_rec; intros.
    transitivity (fold f s0 i).
    apply (fold_equal (eqA:=eqA)); auto.
    rewrite equal_sym; auto.
    transitivity (fold g s0 i).
    apply H0; intros; apply H1; auto with set.
    elim  (equal_2 H x); auto with set; intros.
    apply (fold_equal (eqA:=eqA)); auto with set.
    transitivity (f x (fold f s0 i)).
    apply (fold_add (eqA:=eqA)); auto with set.
    transitivity (g x (fold f s0 i)); auto with set.
    transitivity (g x (fold g s0 i)); auto with set.
    apply ft; auto. apply H0. intros; apply H1; auto with set.
    symmetry; apply (fold_add (eqA:=eqA)); auto.
    repeat rewrite (fold_empty); auto; reflexivity.
  Qed.

  Lemma sum_compat
    (f g : elt -> nat)
    `{Compf : Proper _ (_eq ==> @eq nat) f,
      Compg : Proper _ (_eq ==> @eq nat) g} :
    forall s, (forall x, In x s -> f x=g x) -> sum f s=sum g s.
  Proof.
    intros.
    unfold sum; apply (fold_compat (eqA:=@eq nat)); auto.
    red; repeat intro; auto; omega.
    red; repeat intro; auto; omega.
    red; repeat intro; auto; omega.
    red; repeat intro; auto; omega.
  Qed.
End Sum.


Inductive tree (A : Type) : Type :=
| leaf : A -> tree A
| branch : A -> tree A -> tree A -> tree A.

Arguments leaf {A}.
Arguments branch {A} _ _ _.

Fixpoint flip_tree {A : Type} (t : tree A) : tree A :=
  match t with
  | leaf _ => t
  | branch a l r => branch a (flip_tree r) (flip_tree l)
  end.

Theorem flip_tree_sym : forall {A : Type} (t : tree A),
    t = flip_tree (flip_tree t).
Proof.
  intros.
  induction t.
  compute.
  reflexivity.
  simpl.
  rewrite <- IHt1.
  rewrite <- IHt2.
  reflexivity.
Qed.


Require Export XR_R.
Require Export XR_Rlt.
Require Export XR_total_order_T.

Implicit Type r : R.
Local Open Scope R_scope.

Lemma Rtotal_order : forall r1 r2, r1 < r2 \/ r1 = r2 \/ r2 < r1.
Proof.
  intros x y.
  destruct (total_order_T x y) as [ [ hxy | heq ] | hyx ].
  { left. exact hxy. }
  { right. left. exact heq. }
  { right. right. exact hyx. }
Qed.


(***************************************************************************

 Connected categories and groupoids

 A category is called connected if it is inhabited and for every two objects
 there is a zig-zag between them. A groupoid is called connected if it is
 inhabited and if for every two objects there is a morphism between them.

 Note: these two notions are in general not a proposition. The reason for
 that is that the choice of the zig-zag or of the morphism is not required
 to be natural. As such, different choices do not have to be equal up to
 isomorphism.

 Contents
 1. Definition of connected categories
 2. Categories with a (weak) terminal object are connected
 3. Categories with a (weak) initial object are connected
 4. Connected groupoids and connected categories

 ***************************************************************************)
Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Core.Univalence.
Require Import UniMath.CategoryTheory.categories.StandardCategories.
Require Import UniMath.CategoryTheory.categories.HSET.All.
Require Import UniMath.CategoryTheory.limits.terminal.
Require Import UniMath.CategoryTheory.limits.initial.
Require Import UniMath.CategoryTheory.Groupoids.
Require Import UniMath.CategoryTheory.ZigZag.

Local Open Scope cat.

(**
 1. Definition of connected categories
 *)
Definition connected_category
           (C : category)
  : UU
  := ob C × ∏ (x y : C), zig_zag x y.

Definition ob_of_connected_category
           {C : category}
           (H : connected_category C)
  : C
  := pr1 H.

Definition zig_zag_of_connected_category
           {C : category}
           (H : connected_category C)
           (x y : C)
  : zig_zag x y
  := pr2 H x y.

Definition make_connected_category
           {C : category}
           (c : C)
           (zs : ∏ (x y : C), zig_zag x y)
  : connected_category C
  := c ,, zs.

(**
 2. Categories with a (weak) terminal object are connected
 *)
Definition weakly_terminal_to_connected
           {C : category}
           (c : C)
           (fs : ∏ (w : C), w --> c)
  : connected_category C.
Proof.
  use make_connected_category.
  - exact c.
  - exact (λ x y, x -[ fs x ]-> c <-[ fs y ]- y ■).
Defined.

Definition terminal_to_connected
           {C : category}
           (T : Terminal C)
  : connected_category C.
Proof.
  use weakly_terminal_to_connected.
  - exact T.
  - exact (λ x, TerminalArrow T x).
Defined.

Definition HSET_connected_terminal
  : connected_category HSET.
Proof.
  use terminal_to_connected.
  exact TerminalHSET.
Defined.

(**
 3. Categories with a (weak) initial object are connected
 *)
Definition weakly_initial_to_connected
           {C : category}
           (c : C)
           (fs : ∏ (w : C), c --> w)
  : connected_category C.
Proof.
  use make_connected_category.
  - exact c.
  - exact (λ x y, x <-[ fs x ]- c -[ fs y ]-> y ■).
Defined.

Definition initial_to_connected
           {C : category}
           (I : Initial C)
  : connected_category C.
Proof.
  use weakly_initial_to_connected.
  - exact I.
  - exact (λ x, InitialArrow I x).
Defined.

Definition HSET_connected_initial
  : connected_category HSET.
Proof.
  use initial_to_connected.
  exact InitialHSET.
Defined.

(**
 4. Connected groupoids and connected categories
 *)
Definition connected_groupoid
           (G : groupoid)
  : UU
  := ob G × ∏ (x y : G), x --> y.

Definition ob_of_connected_groupoid
           {G : groupoid}
           (H : connected_groupoid G)
  : G
  := pr1 H.

Definition mor_of_connected_groupoid
           {G : groupoid}
           (H : connected_groupoid G)
           (x y : G)
  : x --> y
  := pr2 H x y.

Definition make_connected_groupoid
           {G : groupoid}
           (c : G)
           (zs : ∏ (x y : G), x --> y)
  : connected_groupoid G
  := c ,, zs.

Definition connected_groupoid_to_connected_category
           {G : groupoid}
           (H : connected_groupoid G)
  : connected_category G.
Proof.
  use make_connected_category.
  - exact (ob_of_connected_groupoid H).
  - exact (λ x y, x -[ mor_of_connected_groupoid H x y ]-> y ■).
Defined.

Definition connected_category_to_connected_groupoid
           {G : groupoid}
           (H : connected_category G)
  : connected_groupoid G.
Proof.
  use make_connected_groupoid.
  - exact (ob_of_connected_category H).
  - exact (λ x y, zig_zag_in_grpd_to_mor (zig_zag_of_connected_category H x y)).
Defined.

Definition unit_connected_category
  : connected_category unit_category.
Proof.
  apply connected_groupoid_to_connected_category.
  use make_connected_groupoid.
  - exact tt.
  - apply isapropunit.
Defined.


(** * Vector type with dependent length and arbitrary-length constructor *)

Inductive vec (A : Type) : nat -> Type :=
  | VecNil : vec A 0
  | VecCons (x : A) (n : nat) : vec A n -> vec A (S n).

Arguments VecNil {_}.
Arguments VecCons {_} _ _.

Check VecCons true _ (VecCons false _ (VecCons false _ VecNil)).

Fixpoint append {A n m} (v : vec A n) (w : vec A m) : vec A (n + m) :=
  match v with
  | VecNil => w
  | VecCons x _ v' => VecCons x _ (append v' w)
  end.

Fixpoint mkvec_type_ (A : Type) (n m : nat) : Type :=
  match n with
  | 0 => vec A m
  | S n => A -> mkvec_type_ A n (S m)
  end.
Definition mkvec_type (A : Type) (n : nat) : Type := mkvec_type_ A n 0.

Compute mkvec_type nat 0.
Compute mkvec_type nat 5.

Fixpoint mkvec_ (A : Type) (n m : nat) (v : vec A m) : mkvec_type_ A n m :=
  match n with
  | 0 => v
  | S n => fun a : A => mkvec_ A n (S m) (VecCons a _ v)
  end.
Definition mkvec (A : Type) (n : nat) : mkvec_type A n := mkvec_ A n 0 VecNil.

Compute mkvec nat 0.
Compute mkvec nat 5.
Compute mkvec nat 5 1 2 3 4 5.


From QuickChick Require Import QuickChick.

Require Import List. Import ListNotations.
Require Import String. Open Scope string.

Inductive Ty :=
| Unt : Ty
| Arr : Ty -> Ty -> Ty.

Derive (Arbitrary, Sized) for Ty.

Program Instance show_Ty : Show Ty := {
  show :=
    fix show' (ty: Ty) :=
    match ty with
    | Unt => "*"
    | Arr A B => "(" ++ show' A ++ " -> " ++ show' B ++ ")"
    end
}.

Instance eq_Ty (t1 t2 : Ty) : Dec (t1 = t2).
Proof. dec_eq. Qed.

Inductive Tm :=
| Tt : Tm (* : Unt *)
| Var : nat -> Tm
| Lam : Ty -> Tm -> Tm
| App : Tm -> Tm -> Tm.

Derive (Arbitrary, Sized) for Tm.

Program Instance show_Tm : Show Tm := {
  show :=
    fix show' (tm: Tm) :=
    match tm with
    | Tt => "*"
    | Var n => show n
    | Lam A b => "(λ " ++ show A ++ " => " ++ show' b ++ ")"
    | App f a => "(" ++ show' f ++ " " ++ show' a ++ ")"
    end
}.

Definition Ctx := list Ty.

Inductive typed_var : Ctx -> Ty -> nat -> Prop :=
| typed_var_O : forall gamma alpha,
    typed_var (alpha :: gamma) alpha O
| typed_var_S : forall gamma alpha beta n,
    typed_var gamma alpha n ->
    typed_var (beta :: gamma) alpha (S n).

Inductive typed : Ctx -> Ty -> Tm -> Prop :=
| typed_Tt : forall gamma,
    typed gamma Unt Tt
| typed_Var : forall gamma alpha n,
    typed_var gamma alpha n ->
    typed gamma alpha (Var n)
| typed_Lam : forall gamma alpha beta bod,
    typed (alpha :: gamma) beta bod ->
    typed gamma (Arr alpha beta) (Lam alpha bod)
| typed_App : forall gamma alpha beta apl arg,
    typed gamma (Arr alpha beta) apl ->
    typed gamma alpha arg ->
    typed gamma beta (App apl arg).

Fixpoint infer_type_var (gamma: Ctx) (n: nat): option Ty :=
  match gamma with
  | [] => None
  | alpha :: gamma' =>
    match n with
    | O => Some alpha
    | S n' => infer_type_var gamma' n'
    end
  end.

(* TODO: is this sufficient? *)
Derive DecOpt for (typed_var gamma alpha n).

Fixpoint is_typed_var (gamma: Ctx) (ty: Ty) (n: nat): bool :=
  match infer_type_var gamma n with
  | Some ty' => (ty = ty')?
  | None => false
  end.

(* TODO: why fail? *)
Fail Derive DecOpt for (typed gamma alpha t).

Fixpoint infer_type (gamma: Ctx) (tm: Tm): option Ty :=
  match tm with
  | Tt => Some Unt
  | Var n => infer_type_var gamma n
  | Lam alpha b =>
    match infer_type (alpha :: gamma) b with
    | None => None
    | Some beta => Some (Arr alpha beta)
    end
  | App f a =>
    match infer_type gamma f with
    | Some (Arr alpha beta) =>
      if is_typed gamma alpha a
        then Some beta
        else None
    | _ => None
    end
  end

with is_typed (gamma: Ctx) (ty: Ty) (tm: Tm): bool :=
  match tm with
  | Tt => (ty = Unt)?
  | Var n => is_typed_var gamma ty n
  | Lam alpha b =>
    match ty with
    | Arr alpha' beta =>
      andb ((alpha = alpha')?)
           (is_typed (alpha :: gamma) beta b)
    | _ => false
    end
  | App f a =>
    match infer_type gamma f with
    | Some (Arr alpha beta) =>
      andb (is_typed gamma alpha a)
           ((beta = ty)?)
    | _ => false
    end
  end.

Derive ArbitrarySizedSuchThat for (fun n => typed_var gamma alpha n).
Derive ArbitrarySizedSuchThat for (fun t => typed gamma alpha t).

(* mutation *)

Fixpoint mut_typed (gamma: Ctx) (ty: Ty) (tm: Tm): G (option Tm) :=
  let mut_here: G (option Tm) :=
        bind (genST (fun tm' => typed gamma ty tm')) (fun opt_tm' =>
        match opt_tm' with
        | None => ret (Some tm)
        | Some tm' => ret (Some tm')
        end)
  in
  match tm return G (option Tm) with
  | Tt => genST (fun t => typed gamma Unt t)
  | Var n =>
    freq_ (ret (Some tm))
      [ (* mut here *)
        (1, mut_here)
      ; (* mut n *)
        ( List.length gamma
        , bind (genST (fun n' => typed_var gamma ty n')) (fun opt_n' =>
          match opt_n' return G (option Tm) with
          | None => ret (Some tm)
          | Some n' => ret (Some (Var n'))
          end)
        )
      ]
  | Lam alpha b =>
    freq_ (ret (Some tm))
      [ (* mut here *)
        (1, mut_here)
      ; (* mut b *)
        ( size b
        , match ty with
          | Arr alpha beta =>
            bind (mut_typed gamma beta b) (fun opt_b' =>
            match opt_b' with
            | None => ret None
            | Some b' => ret (Some (Lam alpha b'))
            end)
          | _ => ret None
          end
        (* can't mut alpha since fixed by rel *)
        )
      ]
  | App f a =>
    freq_ (ret (Some tm))
      [ (* mut here *)
        (1, mut_here)
      ; (* mut f *)
        ( size f
        , match infer_type gamma f with
          | None => ret None
          | Some phi =>
            bind (mut_typed gamma phi f) (fun opt_f' =>
            match opt_f' with
            | None => ret None
            | Some f' => ret (Some (App f' a))
            end)
          end
        )
      ; (* mut a *)
        ( size a
        , match infer_type gamma a with
          | None => ret None
          | Some alpha =>
            bind (mut_typed gamma alpha a) (fun opt_a' =>
            match opt_a' with
            | None => ret None
            | Some a' => ret (Some (App f a'))
            end)
          end
        )
      ]
  end.

Definition mut_preserves_typed_prop gamma ty :=
  forAllMaybe (genST (fun tm => typed gamma ty tm)) (fun tm =>
  forAllMaybe (mut_typed gamma ty tm) (fun tm' =>
  is_typed gamma ty tm')).

QuickChick (mut_preserves_typed_prop [Unt] (Unt)).
(* QuickChick (mut_preserves_typed_prop [Unt] (Arr Unt Unt) (Lam Unt (Var 0))). *)

Definition G1 := [Unt; (Arr Unt Unt)].
Definition A1 := (Arr Unt Unt).
Definition T1 :=
  (App
    (Lam Unt (Var 1))
    (App
      (Lam Unt (Var 1))
      (Var 0))).
Definition T2 :=
  (App
    (Lam Unt (Var 1))
    (Var 0)).

(* QuickChick (ret (is_typed G1 A1 T2)). *)

QuickChick
  (mut_preserves_typed_prop
    [Unt; (Arr Unt Unt)]
    (Arr Unt Unt)
    (App
      (Lam Unt (Var 1))
      (App
        (Lam Unt (Var 1))
        (Var 0)))
  ).

Sample (genST (fun tm => typed [] Unt tm)).

Definition gen_is_typed (gamma: Ctx) (ty: Ty): G bool :=
  bind (genST (fun tm => typed gamma ty tm)) (fun opt_tm =>
  match opt_tm with
  | None => ret true
  | Some tm => ret (is_typed gamma ty tm)
  end).

(* QuickChick gen_is_typed. *)

Definition mut_preserves_typed (gamma: Ctx) (ty: Ty): G bool :=
  bind (genST (fun tm => typed gamma ty tm)) (fun opt_tm =>
  match opt_tm with
  | None => ret true
  | Some tm =>
    bind (mut_typed gamma ty tm) (fun opt_tm' =>
    match opt_tm' with
    | None => ret true
    | Some tm' => ret (is_typed gamma ty tm')
    end)
  end).

(* QuickChick mut_preserves_typed. *)